;; 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)
       (<:progn
	 (<:h1 :class "error" "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 :class "error" (<:as-html m)))
		 failed-messages))))
   (<:fieldset
    (<:legend (<:as-html (symbol->string (class-name (class-of form)))))
    (mapc
     (lambda (c)
       (<:div
	:class "field-box"		; composite field-box (car c)?
	(<:label :for (html-element.dom-id (cdr c))
		 (<: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)
			   (<:span :class "error"
				(<:format "Invalid ~@[(~{~A~^, ~})~]"
					  (mapcan (lambda (v)
						    (if-bind msg (message v)
						      (list msg)
						      msg))
						  failed)))))))
	(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))))