Add validation code.
[clinton/lisp-on-lines.git] / src / standard-descriptions / validate.lisp
1 (in-package :lisp-on-lines)
2
3 (defclass #.(defining-description 'validate) ()
4 ((invalid-object-condition-map :layered t :special t ))
5 (:metaclass standard-description-class))
6
7 (define-layered-class standard-attribute
8 :in-layer #.(defining-description 'validate)
9 ()
10 ((validators
11 :initform nil
12 :layered-accessor attribute-validators
13 :initarg :validate
14 :layered t
15 :special t)))
16
17 (define-condition validation-condition ()
18 ((format-string :accessor validation-condition-format-string
19 :initarg :format-string)
20 (format-args :accessor validation-condition-format-args
21 :initarg :format-args)
22 (object :accessor validation-condition-object
23 :initarg :object)
24 (attribute :accessor validation-condition-attribute
25 :initarg :attribute)))
26
27 (define-layered-method (setf attribute-value)
28 :in-layer #.(defining-description 'validate)
29 :around (value attribute)
30 (prog1 value (when (validate-attribute-value attribute value)
31 (call-next-method))))
32
33 (defun validate-attribute-value (attribute value)
34 (every #'identity (mapcar (lambda (validator-name)
35 (let ((validator (find-validator validator-name)))
36
37 (if validator
38 (funcall validator attribute value)
39 (prog1 t (warn "Unkown Validator ~A" validator-name)))))
40 (attribute-validators attribute))))
41
42
43 (defstruct validation-info (invalid-objects))
44
45 (defvar *invalid-objects*)
46
47 (defvar *validators* (make-hash-table))
48
49 (defun register-validator (name fn)
50 (setf (gethash name *validators*) fn))
51
52 (defun find-validator (name)
53 (gethash name *validators*))
54
55 (register-validator 'boundp
56 (lambda (a v)
57 (if (unbound-slot-value-p v)
58 (prog1 nil
59 (signal (make-condition 'validation-condition
60 :format-string "You must provide a value for ~A"
61 :format-args (list (attribute-label a))
62 :attribute a
63 :object (attribute-object a))))
64 t)))
65
66 (defun validp (object)
67
68 (with-described-object (object nil)
69 (every #'identity (mapcar (lambda (attribute)
70 (validate-attribute-value attribute (attribute-value attribute)))
71 (attributes (description-of object))))))
72
73 (define-layered-method lol::display-attribute-editor
74 :in-layer #.(defining-description 'validate)
75 :after (attribute)
76 (let ((conditions (remove-if-not (lambda (a)
77 (eq a attribute))
78 (gethash
79 (attribute-object attribute)
80 lol::*invalid-objects*)
81 :key #'car)))
82 (dolist (c conditions)
83 (<:div :style "color:red"
84 (<:as-html
85 (apply #'format nil (validation-condition-format-string (cdr c))
86 (validation-condition-format-args (cdr c))))))))
87
88
89
90 (defmethod validate-object ((description standard-description-object) object)
91 (let (invalid-object?)
92 (handler-bind ((validation-condition
93 (setf invalid-object? t))))))
94
95
96