| 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)))))) |