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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Mike Sperber
; Combinators for predicates, useful for test suites.
(define-record-type matcher :matcher
(make-matcher predicate
sexpr)
matcher?
(predicate matcher-predicate)
(sexpr matcher-sexpr))
(define-record-discloser :matcher
(lambda (m)
(list 'matcher (matcher-sexpr m))))
(define (matches? matcher val)
((matcher-predicate matcher) val))
(define (is p? . rest)
(cond ((pair? rest)
(let ((val (car rest)))
(make-matcher (lambda (x)
(p? x val))
`(is ,p? ,val))))
((procedure? p?)
(make-matcher p? `(is ,p?)))
(else (make-matcher (lambda (x)
(equal? x p?))
`(is ,p?)))))
(define (anything)
(make-matcher (lambda (x) #t)
`anything))
(define (opposite matcher)
(make-matcher (lambda (x)
(not (matches? matcher x)))
`(not ,(matcher-sexpr matcher))))
(define (is-true)
(make-matcher (lambda (x) x)
'is-true))
(define (is-false)
(make-matcher (lambda (x) (not x))
'is-false))
(define (is-null)
(make-matcher (lambda (x) (null? x))
'is-false))
(define (is-within val epsilon)
(make-matcher (lambda (x)
(and (number? x)
(< (magnitude (- val x )) epsilon)))
`(is-within ,val ,epsilon)))
(define (member-of list)
(make-matcher (lambda (x) (member x list))
`(is-member ,list)))
(define (all-of . matchers)
(make-matcher (lambda (x)
(every? (lambda (matcher)
(matches? matcher x))
matchers))
`(all-of ,@(map matcher-sexpr matchers))))
(define (any-of . matchers)
(make-matcher (lambda (x)
(any? (lambda (matcher)
(matches? matcher x))
matchers))
`(any-of ,@(map matcher-sexpr matchers))))
(define (list-where-all matcher)
(make-matcher (lambda (l)
(and (list? l)
(every? (lambda (x)
(matches? matcher x))
l)))
`(list-where-each ,matcher)))
(define (list-where-any matcher)
(make-matcher (lambda (l)
(and (list? l)
(any? (lambda (x)
(matches? matcher x))
l)))
`(list-where-any ,matcher)))
(define (list-of . matchers)
(let ((count (length matchers)))
(make-matcher (lambda (x)
(and (list? x)
(let loop ((matchers matchers)
(els x))
(cond
((null? matchers) (null? els))
((null? els) #f)
(else
(and (matches? (car matchers) (car els))
(loop (cdr matchers) (cdr els))))))))
`(list-of ,@matchers))))
(define (vector-of . matchers)
(let* ((matchers (list->vector matchers))
(count (vector-length matchers)))
(make-matcher (lambda (x)
(and (vector? x)
(= count (vector-length x))
(let loop ((i 0))
(if (= i count)
#t
(and (matches? (vector-ref matchers i))
(loop (+ 1 i)))))))
`(vector-of ,matchers))))
(define (pair-of car-matcher cdr-matcher)
(make-matcher (lambda (x)
(and (pair? x)
(matches? car-matcher (car x))
(matches? cdr-matcher (cdr x))))
`(pair-of ,car-matcher ,cdr-matcher)))
|
