diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-08 13:15:25 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-08 13:15:25 +0200 |
commit | b1a83d7239a5cdf838fafaf9fe1fe91b7c9e63ee (patch) | |
tree | 591ed6f55ed031802d1b48281a368a6f8026fd96 | |
parent | Add pair-of to object system. (diff) | |
download | calp-b1a83d7239a5cdf838fafaf9fe1fe91b7c9e63ee.tar.gz calp-b1a83d7239a5cdf838fafaf9fe1fe91b7c9e63ee.tar.xz |
Change list-of and pair-of validator to separate macros.
The functionallity is still the same, but this demonstrates that the
system is easily extensible.
-rw-r--r-- | module/hnh/util/object.scm | 27 |
1 files changed, 17 insertions, 10 deletions
diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm index 4dbb45a8..d6fa6273 100644 --- a/module/hnh/util/object.scm +++ b/module/hnh/util/object.scm @@ -3,7 +3,9 @@ :use-module (srfi srfi-9 gnu) :use-module (ice-9 curried-definitions) :use-module (hnh util) - :export (define-type)) + :export (define-type + build-validator-body + list-of pair-of)) @@ -35,21 +37,26 @@ +(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 (list-of (proc args ...))) - (and (list? variable) - (every (lambda (x) (build-validator-body x (proc args ...))) - variable))) - ((_ variable (list-of proc)) (and (list? variable) - (every proc variable))) - ((_ variable (pair-of a b)) (and (pair? variable) - (build-validator-body (car variable) a) - (build-validator-body (cdr variable) b))) ((_ variable (proc args ...)) (proc variable args ...)) ((_ variable proc) (proc variable)))) |