Form types
[clinton/lisp-on-lines.git] / src / validation / validation.lisp
CommitLineData
937d96b5
DC
1(in-package :lisp-on-lines)
2
3;;;; Validation Conditions
4
5(define-condition validation-condition ()
6 ((message :accessor message :initarg :message :initform "Invalid value")
7 (value :accessor value :initarg :value :initform (warn "condition was not given a value"))))
8
937d96b5
DC
9;;;; ** Attributes
10(define-condition attribute-validation-condition (validation-condition)
11 ((attribute :accessor attribute :initarg :attribute :initform nil)))
12
0cafb6ab 13(defgeneric validate-attribute (instance attribute &optional value)
937d96b5
DC
14 (:documentation "
15Returns T if the ATTRIBUTE-VALUE in INSTANCE passes all the validation functions. Otherwise, returns (values nil conditions) where CONDITIONS is a list of conditions representing the validation errors the slot.")
0cafb6ab 16 (:method (instance attribute &optional (value nil value-provided-p))
17 (let ((val (if value-provided-p
18 value
19 (attribute-value instance attribute)))
20 (conditions))
21 (handler-bind ((attribute-validation-condition
22 #'(lambda (c)
23 (setf conditions (cons c conditions))
24 (signal c))))
25
26 (dolist (f (find-validation-functions instance attribute))
27 (funcall f instance attribute val)))
28 (if conditions
29 (values nil conditions)
30 t))))
937d96b5
DC
31
32
33(defmethod find-validation-functions (instance (attribute standard-attribute))
0cafb6ab 34 (let ((foo (validate-using attribute)))
35 (warn "validation?~A " foo)
36 foo))
937d96b5
DC
37
38
39;;;; ** Instances
40(define-condition instance-validation-condition (validation-condition)
41 ((instance :accessor instance :initarg instance :initform nil)
42 (conditions :accessor conditions :initarg :conditions :initform nil)))
43
44(defmethod invalid-instance-p (instance attributes)
45 (let (condition)
46 (handler-bind ((instance-validation-condition
47 #'(lambda (c)
48 (setf condition c))))
49 (validate-instance instance attributes))
50 condition))
51
52(defmethod validate-instance (instance attributes)
53 (let (all-conditions)
54 (dolist (att attributes)
55 (multiple-value-bind (is-valid-p conditions)
56 (validate-attribute instance att)
57 (unless is-valid-p
58 (setf all-conditions (nconc conditions all-conditions)))))
59 (if all-conditions
60 (progn (signal 'instance-validation-condition
61 :message "Invalid Instance"
62 :instance instance
63 :conditions all-conditions)
64 (values nil all-conditions))
65
66 t)))
67
0cafb6ab 68
937d96b5
DC
69;;;; Attribute Validation Functions
70;;;; I have not quite figured all this out yet.
71;;;; A generic validation system needs more thought than i've given it, but this is a start.
72
0cafb6ab 73(defun validate-string-exists (instance attribute value)
937d96b5
DC
74 (if (or
75 (not (stringp value))
76 (not (< 0 (length value))))
77 (signal 'attribute-validation-condition
78 :message (format nil "You must enter a value for ~A."
0cafb6ab 79 (label attribute))
80 :attribute attribute)))
937d96b5
DC
81
82
0cafb6ab 83(defun validate-true (instance attribute value)
1e5d6797 84 (unless value
1e5d6797 85 (signal 'attribute-validation-condition
0cafb6ab 86 :message (format nil "~A is required."
87 (label attribute))
8e9897fa 88 :attribute attribute)))