initial commit

1 files changed, 71 insertions, 0 deletions

diff --git a/terrafirma.lisp b/terrafirma.lisp
new file mode 100644
index 0000000..16938ee
--- /dev/null
+++ b/terrafirma.lisp
@@ -0,0 +1,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))))
+