1 files changed, 46 insertions, 0 deletions
diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm
new file mode 100644
index 00000000..800834e5
--- /dev/null
+++ b/module/hnh/util/type.scm
@@ -0,0 +1,46 @@
+(define-module (hnh util type)
+  :use-module ((srfi srfi-1) :select (every))
+  :export (build-validator-body
+           list-of pair-of
+           typecheck
+           current-procedure-name))
+
+(define-syntax list-of
+  (syntax-rules ()
+    ((_ variable (rule ...))
+     (and (list? variable)
+          (every (lambda (x) (build-validator-body x (rule ...))) variable)))
+    ((_ variable rule)
+     (and (list? variable)
+          (every rule variable)))))
+
+(define-syntax-rule (pair-of variable a b)
+  (and (pair? variable)
+       (build-validator-body (car variable) a)
+       (build-validator-body (cdr variable) b)))
+
+;; DSL for specifying type predicates
+;; Basically a procedure body, but the variable to test is implicit.
+(define-syntax build-validator-body
+  (syntax-rules (and or list-of)
+    ((_ variable (and clauses ...))  (and (build-validator-body variable clauses) ...))
+    ((_ variable (or clauses ...))   (or (build-validator-body variable clauses) ...))
+    ((_ variable (proc args ...))    (proc variable args ...))
+    ((_ variable proc)               (proc variable))))
+
+(define-syntax-rule (current-procedure-name)
+  ;; 1 since make-stack is at top of stack
+  (frame-procedure-name (stack-ref (make-stack #t) 1)))
+
+(define-syntax typecheck
+  (syntax-rules ()
+    ((_ variable type-clause)
+     (let ((procedure-name (current-procedure-name)))
+       (typecheck variable type-clause procedure-name)))
+    ((_ variable type-clause procedure-name)
+     (unless (build-validator-body variable type-clause)
+       (scm-error 'wrong-type-arg procedure-name
+                  "Invalid value for ~s. Expected ~s, got ~s"
+                  (list (quote variable) (quote type-clause) variable)
+                  #f)))))
+