commited new validation system.
[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 (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))))))