Fix missing `without-special-symbol-access' in `funcall-with-attribute-context'
[clinton/lisp-on-lines.git] / src / standard-descriptions / validate.lisp
... / ...
CommitLineData
1(in-package :lisp-on-lines)
2
3(define-description validate ()
4 ((invalid-object-condition-map :layered t :special t )))
5
6(define-layered-class standard-attribute
7 :in-layer #.(defining-description 'validate)
8 ()
9 ((validators
10 :initform nil
11 :layered-accessor attribute-validators
12 :initarg :validate
13 :layered t
14 :special t)))
15
16(define-condition validation-condition ()
17 ((format-string :accessor validation-condition-format-string
18 :initarg :format-string)
19 (format-args :accessor validation-condition-format-args
20 :initarg :format-args)
21 (object :accessor validation-condition-object
22 :initarg :object)
23 (attribute :accessor validation-condition-attribute
24 :initarg :attribute)))
25
26(define-layered-method (setf attribute-value)
27 :in-layer #.(defining-description 'validate)
28 :around (value attribute)
29 (prog1 value (when (validate-attribute-value attribute value)
30 (call-next-method))))
31
32(defun validate-attribute-value (attribute value)
33 (every #'identity (mapcar (lambda (validator-name)
34 (let ((validator (find-validator validator-name)))
35
36 (if validator
37 (funcall validator attribute value)
38 (prog1 t (warn "Unkown Validator ~A" validator-name)))))
39 (attribute-validators attribute))))
40
41
42(defstruct validation-info (invalid-objects))
43
44(defvar *invalid-objects*)
45
46(defvar *validators* (make-hash-table))
47
48(defun register-validator (name fn)
49 (setf (gethash name *validators*) fn))
50
51(defun find-validator (name)
52 (gethash name *validators*))
53
54(register-validator 'boundp
55 (lambda (a v)
56 (if (unbound-slot-value-p v)
57 (prog1 nil
58 (signal (make-condition 'validation-condition
59 :format-string "You must provide a value for ~A"
60 :format-args (list (attribute-label a))
61 :attribute a
62 :object (attribute-object a))))
63 t)))
64
65
66(defun validp (object)
67 (with-described-object (object nil)
68 (every #'identity (mapcar (lambda (attribute)
69 (validate-attribute-value attribute (attribute-value attribute)))
70 (attributes (description-of object))))))
71
72(define-layered-method lol::display-attribute-editor
73 :in-layer #.(defining-description 'validate)
74 :after (attribute)
75 (let ((conditions (remove-if-not
76 (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