src/standard-descriptions/validate.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-description validate ()
   4   ((invalid-object-condition-map :layered t :special t )))
   5
   6 (define-layered-class standard-attribute
   7   :in-layer #.(defining-description 'validate)
   8   ()
   9   ((validators
  10     :initform nil
  11     :layered-accessor attribute-validators
  12     :initarg :validate
  13     :layered t
  14     :special t)))
  15
  16 (define-condition validation-condition ()
  17   ((format-string :accessor validation-condition-format-string
  18                   :initarg :format-string)
  19    (format-args :accessor validation-condition-format-args
  20                   :initarg :format-args)
  21    (object :accessor validation-condition-object
  22            :initarg :object)
  23    (attribute :accessor validation-condition-attribute
  24            :initarg :attribute)))
  25
  26 (define-layered-method (setf attribute-value)
  27   :in-layer #.(defining-description 'validate)
  28   :around (value attribute)
  29   (prog1 value (when (validate-attribute-value attribute value)
  30                  (call-next-method))))
  31
  32 (defun validate-attribute-value (attribute value)
  33   (every #'identity (mapcar (lambda (validator-name)
  34                               (let ((validator (find-validator validator-name)))
  35
  36                                 (if validator
  37                                     (funcall validator attribute value)
  38                                     (prog1 t (warn "Unkown Validator ~A" validator-name)))))
  39                             (attribute-validators attribute))))
  40
  41
  42 (defstruct validation-info (invalid-objects))
  43
  44 (defvar *invalid-objects*)
  45
  46 (defvar *validators* (make-hash-table))
  47
  48 (defun register-validator (name fn)
  49   (setf (gethash name *validators*) fn))
  50
  51 (defun find-validator (name)
  52    (gethash name *validators*))
  53
  54 (register-validator 'boundp
  55  (lambda (a v)
  56    (if (unbound-slot-value-p v)
  57        (prog1 nil
  58          (signal (make-condition 'validation-condition
  59                                  :format-string "You must provide a value for ~A"
  60                                  :format-args (list  (attribute-label a))
  61                                  :attribute a
  62                                  :object (attribute-object a))))
  63        t)))
  64
  65
  66 (defun validp (object)
  67   (with-described-object (object nil)
  68     (every #'identity (mapcar (lambda (attribute)
  69                                 (validate-attribute-value attribute (attribute-value attribute)))
  70                               (attributes (description-of object))))))
  71
  72 (define-layered-method lol::display-attribute-editor
  73   :in-layer #.(defining-description 'validate)
  74   :after (attribute)
  75   (let ((conditions (remove-if-not
  76                      (lambda (a)
  77                        (eq a attribute))
  78                         (gethash
  79                          (attribute-object attribute)
  80                          lol::*invalid-objects*)
  81                         :key #'car)))
  82     (dolist (c conditions)
  83       (<:div :style "color:red"
  84               (<:as-html
  85                (apply #'format nil (validation-condition-format-string (cdr  c))
  86                       (validation-condition-format-args (cdr  c))))))))
  87
  88
  89
  90 (defmethod validate-object ((description standard-description-object) object)
  91   (let (invalid-object?)
  92     (handler-bind ((validation-condition
  93                     (setf invalid-object? t))))))
  94
  95
  96