blob: 16938ee7263e2a990ff1d7c8d58806a85005fe17 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
;;;; terrafirma.lisp
(defpackage #:terrafirma
(:use #:cl)
(:export
#:validate
#:defvalidator))
(in-package #:terrafirma)
(defvar *indentation* 0)
(defun report-validation-error (err stream)
(with-slots (type reason suberror) err
(loop :repeat *indentation* :do (princ #\space stream))
(format stream "Error validating ~a: ~a~%" type reason)
(when suberror
(loop :repeat *indentation* :do (princ #\space stream))
(format stream "More specifically:~%")
(let ((*indentation* (+ 2 *indentation*)))
(report-validation-error suberror stream)))))
(define-condition validation-error (error)
((type
:initarg :type
:initform (error "TYPE Required")
:type symbol
:documentation "The type of the invalid object.")
(instance
:initarg :instance
:initform (error "INSTANCE Required")
:documentation "The invalid object.")
(reason
:initarg :reason
:initform (error "INSTANCE Required")
:type string
:documentation "A description of why the instance is invalid.")
(suberror
:initarg :suberror
:initform nil
:documentation
"A validation error that may have been signalled while validating a part of the structure of INSTANCE."))
(:report report-validation-error))
(defvar *type*)
(defvar *instance*)
(defmacro validate (check msg &rest args)
(let ((suberr (gensym)))
`(prog1 t
(let (,suberr)
(assert (handler-case ,check (validation-error (sub) (setf ,suberr sub) nil))
() 'terrafirma::validation-error
:type terrafirma::*type*
:instance terrafirma::*instance*
:reason (format nil ,msg ,@args)
:suberror ,suberr)))))
(defmacro defvalidator ((var type &key name) &body body)
(assert (and var (symbolp var)) (var) "VAR must be a symbol.")
(let ((validator-name
(cond ((and name (symbolp name)) name)
((symbolp type) (intern (format nil "VALIDATE-~a" type)))
(t (error "Validator Name: Either TYPE must be a symbol or a NAME must be provided.")))))
`(defun ,validator-name (,var)
(let ((terrafirma::*type* ',type)
(terrafirma::*instance* ',var))
,@body))))
|
