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