[Move simple-form from golgonooza into ucw-forms
clinton@unknownlamer.org**20090206210038
 Relicensed to the same BSD license the rest of ucw-forms is under as well
] hunk ./src/package.lisp 61
+(defpackage :ucw-forms.simple-form
+  (:use :cl :ucw-core :ucw :ucw-forms)
+  (:import-from :arnesi :defgeneric/cc :defmethod/cc :if-bind)
+  (:nicknames :ucw-simple-form)
+  (:export
+   ;; Simple Form
+   :simple-form
+   :file-upload-form
+   :form-invalid-p
+   :form-fields
+   
+   :form-validator
+   :make-validators
+
+   :process-form
+   :cancel-form
+
+   :define-html-form))
+
addfile ./src/simple-form.lisp
hunk ./src/simple-form.lisp 1
-
+;; simple-form.lisp --- Part of UCW-Forms
+
+;; Copyright (C) 2008,2009 Clinton Ebadi <clinton@unknownlamer.org>
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;; 
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :ucw-forms.simple-form)
+
+(defun symbol->string (symbol)
+  (string-capitalize (substitute #\space #\- (if (symbolp symbol)
+						 (symbol-name symbol)
+						 symbol))))
+
+(defcomponent simple-form (form-component-mixin)
+  ((%invalid :initform nil :accessor form-invalid-p)
+   (validators :initform nil :initarg :validators :accessor validators)
+   (field-order :initform nil :accessor form-field-order :initarg :field-order)
+   (%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))
+
+(defgeneric form-field-validp (form field))
+
+(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))))
+
+;; rename simple-form-validator in merge
+(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))
+  (answer nil))
+
+(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))
+  (let ((fields
+	 (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))))))))
+    (if (form-field-order component)
+	(mapcar (lambda (name) (find name fields :key #'car))
+		(form-field-order component))
+	fields)))
+
+(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))))
+
+(defmethod form-fields-of ((form simple-form))
+  (mapcar #'cdr (form-fields 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))))
hunk ./ucw-forms.asd 17
-				     (:file "form"))
+				     (:file "form")
+				     (:file "simple-form"))