0cafb6ab |
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 | |
8e9897fa |
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))) |
0cafb6ab |
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 | |
e9c16372 |
53 | (defattribute base-attribute () |
8e9897fa |
54 | () |
55 | (:in-layer validate) |
56 | (:default-properties |
57 | :validate-using nil |
58 | :requiredp nil |
59 | :required-test 'validate-string-exists)) |
60 | |
0cafb6ab |
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))) |
8e9897fa |
75 | |
76 | ;;;; We have a convenience property for :requiredp |
0cafb6ab |
77 | (when (requiredp attribute) |
78 | (push (required-test attribute) validators)) |
8e9897fa |
79 | |
80 | ;;;; Now we create the validation callback |
81 | (dletf (((callback attribute) |
0cafb6ab |
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) |
8e9897fa |
93 | ((slot-value attribute 'label) label)) |
0cafb6ab |
94 | (multiple-value-bind (validp conditions) |
95 | (validate-attribute object attribute val) |
96 | (if validp |
97 | (setter val) |
8e9897fa |
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))))))))))))) |
0cafb6ab |
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)))))) |