rev: tip wisp/examples/doctests.scm -rwxr-xr-x 7.0 KiB View raw Log this file
04a36078156fArne Babenhauserheide merge stable into default after release 2 months 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
#!/usr/bin/env sh
# -*- scheme -*-
exec guile -L $(dirname $(dirname $(realpath "$0"))) -e '(@@ (examples doctests) main)' -s "$0" "$@"
; !#

;;; 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)

;; To run the tests when (main args) is called:

;; (import (examples doctests))
;; (define %this-module (current-module))
;; (define (main args)
;;          (doctests-testmod %this-module))


;; With wisp, you need to use the literal
;; ##
;;    tests
;;        test-equal ...


(define-module (examples doctests)
              #:export (doctests-testmod))

(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 (symbol->string name) (symbol->string id))
                                                     "--"))
                                      ((tests ...)
                                        (string-join (list filename (symbol->string name))
                                                     "--"))))
                                 (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 %this-module (current-module))
(define (main args)
         (doctests-testmod %this-module))