-
Notifications
You must be signed in to change notification settings - Fork 0
/
doctests.w
executable file
·196 lines (177 loc) · 7.31 KB
/
doctests.w
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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
#!/usr/bin/env bash
# -*- wisp -*-
guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))'
exec -a "$0" guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -x .w -e '(doctests)' -c '' "$@"
; !#
;;; doctests --- simple testing by adding procedure-properties with tests.
;;; Usage
;; Add a tests property to a procedure to have simple unit tests.
;; Simple tests:
;;
;; (define (A)
;; #((tests (test-eqv 'A (A))
;; (test-assert #t)))
;; 'A)
;;
;; Named tests:
;;
;; (define (A)
;; #((tests ('test1 (test-eqv 'A (A))
;; (test-assert #t))
;; ('test2 (test-assert #t))))
;; 'A)
;;
;; Allows for docstrings:
;;
;; (define (A)
;; "returns 'A"
;; #((tests (test-eqv 'A (A))
;; (test-assert #t)))
;; 'A)
;; For writing the test before the implementation, start with the test and #f:
;; (define (A)
;; #((tests (test-eqv 'A (A))))
;; #f)
;; With wisp, you currently need to use the literal #((tests (...)))
;; TODO: add array parsing to wisp following quoting with ':
;; # a b → #(a b) and # : a b c → #((a b))
define-module : doctests
. #:export : doctests-testmod main
import : ice-9 optargs
ice-9 rdelim
ice-9 match
ice-9 pretty-print
oop goops
texinfo reflection
; define basic dir
define* (dir #:key (all? #f))
if all?
map (λ (x) (cons (module-name x)
(module-map (λ (sym var) sym) (resolve-interface (module-name x)))))
cons (current-module) : module-uses (current-module)
module-map (λ (sym var) sym) (current-module)
; add support for giving the module as argument
define-generic dir
define-method (dir (all? <boolean>)) (dir #:all? all?)
define-method (dir (m <list>)) (module-map (λ (sym var) sym) (resolve-interface m))
; add support for using modules directly (interfaces are also modules, so this catches both)
define-method (dir (m <module>)) (module-map (λ (sym var) sym) m)
define : string-index s fragment
. "return the index of the first character of the FRAGMENT in string S."
let loop : (s s) (i 0)
if : = 0 : string-length s
. #f
if : string-prefix? fragment s
. i
loop (string-drop s 1) (+ i 1)
define : doctests-extract-from-string s
. "Extract all test calls from a given string."
let lp
: str s
tests : list
if : string-null? str
reverse tests
let : : idx : string-index str "(test"
if : not idx
reverse tests
let : : sub : substring str idx
lp ; recurse with the rest of the string
with-input-from-string sub
λ () (read) (read-string)
cons
with-input-from-string sub
λ () : read
. tests
define : subtract a b
. "Subtract B from A."
##
tests : test-eqv 3 (subtract 5 2)
- a b
define : doctests-testmod mod
. "Execute all doctests in the current module
This procedure provides an example test:"
##
tests
'mytest
define v (make-vector 5 99)
test-assert (vector? v)
test-eqv 99 (vector-ref v 2)
vector-set! v 2 7
test-eqv 7 (vector-ref v 2)
'mytest2
test-assert #t
;; thanks to Vítor De Araújo: https://lists.gnu.org/archive/html/guile-user/2017-08/msg00003.html
let*
: names : module-map (λ (sym var) sym) mod
filename
if (module-filename mod) (string-join (string-split (module-filename mod) #\/ ) "-")
string-join (cons "._" (map symbol->string (module-name mod))) "-"
doctests
map (λ (x) (if (procedure? x) (procedure-property x 'tests)))
map (λ (x) (module-ref mod x)) names
let loop
: names names
doctests doctests
;; pretty-print doctests
;; newline
when : pair? doctests
let*
: name : car names
doctest : car doctests
let loop-tests
: doctest doctest
when : and (pair? doctest) (car doctest) : pair? : car doctest
;; pretty-print : car doctest
;; newline
let*
:
testid
match doctest
: (('quote id) tests ...) moretests ...
string-join
list filename
string-join (string-split (symbol->string name) #\/) "--" ;; escape / in paths
symbol->string id
. "--"
: tests ...
string-join : list filename : string-join (string-split (symbol->string name) #\/) "--" ;; escape / in paths
. "--"
body
match doctest
: (('quote id) test tests ...) moretests ...
cons test tests
: tests ...
. tests
cleaned
cons 'begin
cons '(import (srfi srfi-64))
cons
list 'test-begin : or testid ""
append
. body
list : list 'test-end : or testid ""
;; pretty-print testid
;; pretty-print body
;; pretty-print cleaned
;; newline
when cleaned
let :
eval cleaned mod
newline
match doctest
: (('quote id) tests ...) moretests ...
loop-tests moretests
: tests ...
. #t
loop (cdr names) (cdr doctests)
define : hello who
. "Say hello to WHO"
##
tests
test-equal "Hello World!\n"
hello "World"
format #f "Hello ~a!\n"
. who
define %this-module : current-module
define : main args
doctests-testmod %this-module