rev: ba80bf370de0 wisp/examples/doctests.w -rwxr-xr-x 7.2 KiB View raw Log this file
ba80bf370de0Arne Babenhauserheide merge wisp 1.0.3 a month ago
                                                                                
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
196
197
198
#!/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 '(examples 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
;;        test-equal ...


define-module : examples 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