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