[Import simple-form library from tee-it-up
clinton@unknownlamer.org**20081209063126
 Most of the simple-form library will be integrated into ucw-forms soon
] {
hunk ./golgonooza.asd 15
+			 (:file "simple-form" :depends-on ("packages"))
hunk ./src/packages.lisp 25
+   ;; Query View
hunk ./src/packages.lisp 49
+(defpackage :org.unknownlamer.golgonooza.forms
+  (:use :cl :ucw-core :ucw :ucw-forms)
+  (:import-from :arnesi :defgeneric/cc :defmethod/cc :if-bind)
+  (:import-from :metabang.utilities :symbol->string)
+  (:nicknames :golgonooza-forms)
+  (:export
+   ;; Simple Form
+   :simple-form
+   :file-upload-form
+   :form-invalid-p
+   :validators
+   :form-fields-of
+   
+   :form-validator
+   :default-validp
+   :make-validators
+
+   :process-form
+   :cancel-form
+
+   :define-html-form))
+
addfile ./src/simple-form.lisp
hunk ./src/simple-form.lisp 1
-
+;; simple-form.lisp --- 
+
+;; Copyright (C) 2008 Clinton Ebadi <clinton@unknownlamer.org>
+
+;; Author: Clinton Ebadi <clinton@unknownlamer.org>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(in-package :org.unknownlamer.golgonooza.forms)
+
+;;; Most of this will be merged into ucw-forms soon
+
+(defcomponent simple-form (form-component-mixin)
+  ((%invalid :initform nil :accessor form-invalid-p)
+   (validators :initform nil :initarg :validators :accessor validators)
+   (%failed-validators :initform nil)
+   (%field-failed-validators :initform nil)))
+
+(defcomponent file-upload-form (simple-form)
+  ()
+  (:default-initargs :encoding-type "multipart/form-data"))
+
+(defmethod (setf form-invalid-p) :around (new-value (form simple-form))
+  (if (not new-value)
+      (setf (slot-value form '%failed-validators) nil
+	    (slot-value form '%field-failed-validators) nil))
+  (call-next-method))
+
+(defmethod form-field-validp ((form simple-form) field)
+  (multiple-value-bind (validp failed) (validp field)
+    (declare (ignore validp))
+    (let ((all-failed (append
+		       failed
+		       (cdr (assoc field
+				   (slot-value form '%field-failed-validators))))))
+      (values (null all-failed) all-failed))))
+
+(defclass form-validator (validator)
+  ((field :initarg :field :initform nil :accessor field)))
+
+(defmethod validate :around ((form simple-form) (validator form-validator))
+  (if (call-next-method)
+      t
+      (with-slots (field) validator
+	(if field
+	    (if-bind error-list-entry
+		(assoc (slot-value form field)
+		       (slot-value form '%field-failed-validators))
+	      (push validator (cdr error-list-entry))
+	      (push (list (slot-value form field) validator)
+		    (slot-value form '%field-failed-validators))))
+	nil)))
+
+(defmacro define-html-form (name (&rest supers)
+			    (&rest fields) (&rest slots)
+			    &rest options)
+  (flet ((massage-field-name (field-name)
+	   (if (listp field-name)
+	       (cons `(quote ,(car field-name)) (cdr field-name))
+	       (list `(quote ,field-name))))
+	 (massage-options (options)
+	   (if-bind validators (find :validators options :key #'car)
+	     `(,@(remove-if (lambda (k) (or (eq k :validators)
+				       (eq k :default-initargs)))
+			    options :key #'car)
+		 (:default-initargs
+		     ,@(cdr (find :default-initargs options :key #'car))
+		     :validators (list ,@(mapcar (lambda (v)
+						   `(make-instance ',(car v)
+								   ,@(cdr v)))
+						 (cdr validators)))))
+	     
+	     options)))
+    `(defcomponent ,name ,(or supers '(simple-form))
+       ,(append (mapcar (lambda (f)
+			  `(,(car f) :initform (make-instance
+						,@(massage-field-name (cadr f)))
+			     ,@(cddr f)))
+			fields)
+		slots)
+       ;; Need to yank out :validators and merge it with
+       ;; :default-initargs
+       ,@(massage-options options))))
+
+
+(defun make-validators (&rest validator-names)
+  "Create validator instances. validator-names should be a list of
+class names or sublists of class names and initargs"
+  (mapcar (lambda (name) (apply #'make-instance
+			   (if (listp name) name (list name))))
+	  validator-names))
+
+(defgeneric form-fields (form))
+
+(defgeneric/cc process-form (form))
+(defgeneric/cc cancel-form (form))
+
+(defaction cancel-form ((form simple-form))
+  (ok form))
+
+(defaction process-form :around ((form simple-form))
+  (multiple-value-bind (validp failed) (validp form)
+    (cond ((not validp)
+	   (setf (form-invalid-p form) t)
+	   (refresh-component form))
+	  (t (setf (form-invalid-p form) nil)
+	     (call-next-method form)))))
+
+(defmethod form-fields ((component simple-form))
+  (remove-if-not (arnesi:compose #'ucw-forms::form-field-p #'cdr)
+		 (mapcar (lambda (name) (cons name (slot-value component name)))
+			 (remove-if-not #'(lambda (name) (slot-boundp component name))
+					(mapcar #'c2mop:slot-definition-name
+						(c2mop:class-slots (class-of component)))))))
+
+(defmethod render ((form simple-form))
+  (<:div
+   :class "simple-form"
+   (if (form-invalid-p form)
+       (<:p :class "error"
+	    (<:h1 "Form Failed Validation")
+	    (if-bind failed-messages (mapcan (lambda (f)
+					       (if-bind msg (message f)
+						 (list msg)))
+					     (slot-value form '%failed-validators))
+	      (mapc (lambda (m) (<:h2 (<:as-html m)))
+		    failed-messages))))
+   (mapc
+    (lambda (c)
+      (<:div
+       :class "field-box"		; composite field-box (car c)?
+       (<:div :class "label"
+	      (<:as-html (symbol->string  (car c)))
+	      (if (form-invalid-p form)
+		  (multiple-value-bind (validp failed)
+		      (form-field-validp form (cdr c))
+		    (if (not validp)
+			(<:p :class "error"
+			     (<:format "Invalid ~@[(~{~A~^, ~})~]"
+				       (mapcan (lambda (v)
+						 (if-bind msg (ucw-forms::message v)
+						   (list msg)
+						   msg))
+					       failed)))))))
+       (<:div :class "widget" (render (cdr c)))))
+    (form-fields form))))
+
+(defmethod render :after ((form simple-form))
+  (<:div 
+   (<ucw:submit :value "Ok" :action (process-form form))
+   (<ucw:submit :value "Cancel" :action (cancel-form form))))
+
+(defgeneric form-fields-of (component))
+
+(defmethod form-fields-of ((form simple-form))
+  (mapcar #'cdr (form-fields form)))
+
+(defmethod form-fields-of ((component standard-component))
+  "Return slot values of COMPONENT which are FORM-FIELDs"
+  (remove-if-not #'ucw-forms::form-field-p
+		 (mapcar (arnesi:curry #'slot-value component)
+			 (remove-if-not #'(lambda (name) (slot-boundp component name))
+					(mapcar #'c2mop:slot-definition-name
+						(c2mop:class-slots (class-of component)))))))
+
+(defmethod form-fields-of ((field form-field))
+  (list field))
+
+(defun default-validp (form)
+  ;; Mostly yanked from ucw update (C) notices
+  (flet ((do-validate-field (field)
+           "Run validators on FIELD, return list of (FIELD . VALIDATOR) conses."
+           (multiple-value-bind (validp failed) (validp field)
+             (declare (ignore validp))
+             (mapcar #'(lambda (failed) (cons field failed))
+                     failed))))
+    (let ((failed (apply #'nconc
+                         (mapcar #'do-validate-field
+                                 (form-fields-of form)))))
+      (values (null failed) failed))))
+
+(defmethod validp ((form standard-component))
+  (default-validp form))
+
+(defmethod validp ((form simple-form))
+  (setf (slot-value form '%failed-validators) nil
+	(slot-value form '%field-failed-validators) nil)
+  (multiple-value-bind (validp field-failed) (call-next-method)
+    (declare (ignore validp))
+    (let* ((form-failed
+	    (if-bind validators (validators form)
+	     (mapcan  (lambda (v)
+			(if (not (ucw-forms::validate form v))
+			    (list v)))
+		      validators)))
+	   (failed
+	    (nconc
+	     field-failed
+	     (mapcar (lambda (v) (cons form v))
+		     (setf (slot-value form '%failed-validators) form-failed))
+	     (mapcar (lambda (e) (cons (car e) (cdr e)))
+		     (slot-value form '%field-failed-validators)))))
+      (values (null failed) failed))))
+
+(defmethod validp ((form-field date-field))
+  (default-validp form-field))
+
+(defmethod form-fields-of ((field date-field))
+  (list (ucw-forms::year field) (ucw-forms::month field) (ucw-forms::day field)))
}