1 (in-package :lisp-on-lines
)
3 (define-description validate
()
4 ((invalid-object-condition-map :layered t
:special t
)))
6 (define-layered-class standard-attribute
7 :in-layer
#.
(defining-description 'validate
)
11 :layered-accessor attribute-validators
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
23 (attribute :accessor validation-condition-attribute
24 :initarg
:attribute
)))
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
)
32 (defun validate-attribute-value (attribute value
)
33 (every #'identity
(mapcar (lambda (validator-name)
34 (let ((validator (find-validator validator-name
)))
37 (funcall validator attribute value
)
38 (prog1 t
(warn "Unkown Validator ~A" validator-name
)))))
39 (attribute-validators attribute
))))
42 (defstruct validation-info
(invalid-objects))
44 (defvar *invalid-objects
*)
46 (defvar *validators
* (make-hash-table))
48 (defun register-validator (name fn
)
49 (setf (gethash name
*validators
*) fn
))
51 (defun find-validator (name)
52 (gethash name
*validators
*))
54 (register-validator 'boundp
56 (if (unbound-slot-value-p v
)
58 (signal (make-condition 'validation-condition
59 :format-string
"You must provide a value for ~A"
60 :format-args
(list (attribute-label a
))
62 :object
(attribute-object a
))))
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
))))))
72 (define-layered-method lol
::display-attribute-editor
73 :in-layer
#.
(defining-description 'validate
)
75 (let ((conditions (remove-if-not
79 (attribute-object attribute
)
80 lol
::*invalid-objects
*)
82 (dolist (c conditions
)
83 (<:div
:style
"color:red"
85 (apply #'format nil
(validation-condition-format-string (cdr c
))
86 (validation-condition-format-args (cdr c
))))))))
90 (defmethod validate-object ((description standard-description-object
) object
)
91 (let (invalid-object?
)
92 (handler-bind ((validation-condition
93 (setf invalid-object? t
))))))