Drop usage of defaction
[clinton/lisp-on-lines.git] / src / validation / standard-validation.lisp
1 (in-package :lisp-on-lines)
2
3 (defstruct invalid-attribute-value
4 (initial-value nil :read-only t)
5 (invalid-value nil :read-only t)
6 (conditions nil :read-only t))
7
8 (deflayer validate (editor))
9
10 (defcomponent validation-mixin ()
11 ((validation-conditions
12 :accessor validation-conditions
13 :initform nil
14 :backtrack t)
15 (inhibit-call-if-invalid-p
16 :accessor inhibit-call-if-invalid-p
17 :initform t
18 :initarg :inhibit-call-if-invalid-p)
19 (inhibit-answer-if-invalid-p
20 :accessor inhibit-answer-if-invalid-p
21 :initform t
22 :initarg :inhibit-answer-if-invalid-p)))
23
24 (defmethod render :wrap-around ((self validation-mixin))
25 (call-next-method)
26 (setf (validation-conditions self) nil))
27
28 (defun component-valid-p (component)
29 (not (validation-conditions component)))
30
31 (defmethod/cc call-component :around ((from validation-mixin) to)
32 (if (inhibit-call-if-invalid-p from)
33 (when (component-valid-p from)
34 (call-next-method from to))
35 (call-next-method from to)))
36
37 (defmethod answer-component :around ((target validation-mixin) value)
38 (if (inhibit-answer-if-invalid-p target)
39 (when (component-valid-p target)
40 (call-next-method))
41 (call-next-method)))
42
43 (defparameter *invalid-attribute-renderer*
44 #'(lambda (invalid-attribute-value next-method)
45 (<:div
46 :class "lol-invalid-attribute"
47 (<:ul
48 :class "lol-invalid-attribute-message"
49 (dolist (c (invalid-attribute-value-conditions invalid-attribute-value))
50 (<:li (<:as-html (message c)))))
51 (funcall next-method))))
52
53 (defattribute base-attribute ()
54 ()
55 (:in-layer validate)
56 (:default-properties
57 :validate-using nil
58 :requiredp nil
59 :required-test 'validate-string-exists))
60
61 (defdisplay :in-layer validate
62 :around ((attribute base-attribute) object)
63 "Set the callback to perform validation
64 and create invalid-attribute-values when things don't validate. duh "
65 (let ((callback (or
66 (callback attribute)
67 (ucw::make-new-callback
68 #'(lambda (val)
69 (setf (attribute-value object attribute) val)))))
70 ;;;; We need to lexically bind some slots here
71 ;;;; As by the time the validator runs we'll be in
72 ;;;; a totally different dynamic scope.
73 (validators (validate-using attribute))
74 (label (label attribute)))
75
76 ;;;; We have a convenience property for :requiredp
77 (when (requiredp attribute)
78 (push (required-test attribute) validators))
79
80 ;;;; Now we create the validation callback
81 (dletf (((callback attribute)
82 (ucw::make-new-callback
83 #'(lambda (val)
84 (flet ((setter (value)
85 (ucw::call-callback
86 (ucw::context.current-frame *context*)
87 callback
88 value)))
89
90 ;; We have to do DLETF ,as we will no longer be
91 ;; in the validation layer at callback-application time.
92 (dletf (((validate-using attribute) validators)
93 ((slot-value attribute 'label) label))
94 (multiple-value-bind (validp conditions)
95 (validate-attribute object attribute val)
96 (if validp
97 (setter val)
98 (progn
99 (setter
100 (make-invalid-attribute-value
101 :initial-value (attribute-value object attribute)
102 :invalid-value val
103 :conditions conditions))
104 (when (subtypep (type-of self) 'validation-mixin)
105 (setf (validation-conditions self)
106 (append conditions (validation-conditions self)))))))))))))
107
108
109 ;;;; Ok, so if the attribute-value holds an
110 ;;;; invalid-attribute-value struct, we take the appropriate action
111 (let ((value (attribute-value object attribute)))
112 (if (invalid-attribute-value-p value)
113 (progn
114 ;;;; set the value back the the previous
115 ;;;; TODO: does not handle unbound slots
116 (ucw::call-callback
117 (ucw::context.current-frame *context*)
118 callback
119 (invalid-attribute-value-initial-value value))
120 (funcall *invalid-attribute-renderer*
121 value
122 #'(lambda ()
123 (call-next-method))))
124 (call-next-method))))))