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 | |
10 | (defattribute base-attribute () |
11 | () |
12 | (:in-layer validate) |
13 | (:default-properties |
14 | :validate-using nil |
15 | :requiredp nil |
16 | :required-test 'validate-true)) |
17 | |
18 | (defparameter *invalid-attribute-renderer* |
19 | #'(lambda (invalid-attribute-value next-method) |
20 | (<:div |
21 | :class "lol-invalid-attribute" |
22 | (<:ul |
23 | :class "lol-invalid-attribute-message" |
24 | (dolist (c (invalid-attribute-value-conditions invalid-attribute-value)) |
25 | (<:li (<:as-html (message c))))) |
26 | (funcall next-method)))) |
27 | |
28 | (defdisplay :in-layer validate |
29 | :around ((attribute base-attribute) object) |
30 | "Set the callback to perform validation |
31 | and create invalid-attribute-values when things don't validate. duh " |
32 | (let ((callback (or |
33 | (callback attribute) |
34 | (ucw::make-new-callback |
35 | #'(lambda (val) |
36 | (setf (attribute-value object attribute) val))))) |
37 | ;;;; We need to lexically bind some slots here |
38 | ;;;; As by the time the validator runs we'll be in |
39 | ;;;; a totally different dynamic scope. |
40 | (validators (validate-using attribute)) |
41 | (label (label attribute))) |
42 | (when (requiredp attribute) |
43 | (push (required-test attribute) validators)) |
44 | (dletf (((callback attribute) |
45 | (ucw::make-new-callback |
46 | #'(lambda (val) |
47 | (flet ((setter (value) |
48 | (ucw::call-callback |
49 | (ucw::context.current-frame *context*) |
50 | callback |
51 | value))) |
52 | |
53 | ;; We have to do DLETF ,as we will no longer be |
54 | ;; in the validation layer at callback-application time. |
55 | (dletf (((validate-using attribute) validators) |
56 | ((slot-value attribute 'label) label) |
57 | ) |
58 | (multiple-value-bind (validp conditions) |
59 | (validate-attribute object attribute val) |
60 | (if validp |
61 | (setter val) |
62 | (setter |
63 | (make-invalid-attribute-value |
64 | :initial-value (attribute-value object attribute) |
65 | :invalid-value val |
66 | :conditions conditions)))))))))) |
67 | |
68 | |
69 | ;;;; Ok, so if the attribute-value holds an |
70 | ;;;; invalid-attribute-value struct, we take the appropriate action |
71 | (let ((value (attribute-value object attribute))) |
72 | (if (invalid-attribute-value-p value) |
73 | (progn |
74 | ;;;; set the value back the the previous |
75 | ;;;; TODO: does not handle unbound slots |
76 | (ucw::call-callback |
77 | (ucw::context.current-frame *context*) |
78 | callback |
79 | (invalid-attribute-value-initial-value value)) |
80 | (funcall *invalid-attribute-renderer* |
81 | value |
82 | #'(lambda () |
83 | (call-next-method)))) |
84 | (call-next-method)))))) |