src/standard-descriptions/validate.lisp

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