New implementation (load "new-description.lisp") of LoL protocol based on Plists...

[clinton/lisp-on-lines.git] / src / standard-descriptions / validate.lisp

(in-package :lisp-on-lines)

(defclass #.(defining-description 'validate) () 
  ((invalid-object-condition-map :layered t :special t ))
  (:metaclass standard-description-class))

(define-layered-class standard-attribute
  :in-layer #.(defining-description 'validate)
  ()
  ((validators 
    :initform nil 
    :layered-accessor attribute-validators
    :initarg :validate
    :layered t
    :special t)))

(define-condition validation-condition ()
  ((format-string :accessor validation-condition-format-string
		  :initarg :format-string)
   (format-args :accessor validation-condition-format-args
		  :initarg :format-args)
   (object :accessor validation-condition-object
	   :initarg :object)
   (attribute :accessor validation-condition-attribute
	   :initarg :attribute)))

(define-layered-method (setf attribute-value) 
  :in-layer #.(defining-description 'validate) 
  :around (value attribute)
  (prog1 value (when (validate-attribute-value attribute value)
		 (call-next-method))))

(defun validate-attribute-value (attribute value)
  (every #'identity (mapcar (lambda (validator-name)
			      (let ((validator (find-validator validator-name)))

				(if validator 
				    (funcall validator attribute value) 
				    (prog1 t (warn "Unkown Validator ~A" validator-name)))))
			    (attribute-validators attribute))))


(defstruct validation-info (invalid-objects))

(defvar *invalid-objects*)

(defvar *validators* (make-hash-table))

(defun register-validator (name fn)
  (setf (gethash name *validators*) fn))

(defun find-validator (name)
   (gethash name *validators*))

(register-validator 'boundp 
 (lambda (a v)
   (if (unbound-slot-value-p v)
       (prog1 nil
	 (signal (make-condition 'validation-condition 
				 :format-string "You must provide a value for ~A"
				 :format-args (list  (attribute-label a))
				 :attribute a
				 :object (attribute-object a))))
       t)))


(defun validp (object)
  (with-described-object (object nil)
    (every #'identity (mapcar (lambda (attribute)
				(validate-attribute-value attribute (attribute-value attribute)))
			      (attributes (description-of object))))))

(define-layered-method lol::display-attribute-editor 
  :in-layer #.(defining-description 'validate)
  :after (attribute)
  (let ((conditions (remove-if-not 
		     (lambda (a)
		       (eq a attribute)) 
			(gethash 
			 (attribute-object attribute) 
			 lol::*invalid-objects*)
			:key #'car)))
    (dolist (c conditions)
      (<:div :style "color:red"
	      (<:as-html 
	       (apply #'format nil (validation-condition-format-string (cdr  c))
		      (validation-condition-format-args (cdr  c))))))))



(defmethod validate-object ((description standard-description-object) object)
  (let (invalid-object?)
    (handler-bind ((validation-condition 
		    (setf invalid-object? t))))))