blob: b998d59cae19a859829d5a1bcd40e319cc590795 (
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
|
(define-module (hnh util type)
:use-module ((srfi srfi-1) :select (every))
:export (build-validator-body
list-of pair-of alist-of alist-of
list-of-length
of-type?
typecheck
current-procedure-name))
;; 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 not)
((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...))
((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...))
((_ variable (not clause)) (not (build-validator-body variable clause)))
((_ 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 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)))
(define-syntax-rule (alist-of variable key-type value-type)
(build-validator-body variable (list-of (pair-of key-type value-type))))
(define (list-of-length lst n)
(and (list? lst)
(= n (length lst))))
(define-syntax of-type?
(syntax-rules ()
((_ variable type-spec)
(build-validator-body variable type-spec))
((_ type-spec)
(lambda (x) (build-validator-body x type-spec)))))
(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)))))
|