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