(Arne Babenhauserheide)
2017-07-27: working doctests working doctests
diff --git a/examples/doctests.w b/examples/doctests.w
--- a/examples/doctests.w
+++ b/examples/doctests.w
@@ -9,6 +9,7 @@ define-module : examples doctests
import : ice-9 optargs
ice-9 rdelim
+ ice-9 match
oop goops
texinfo reflection
@@ -40,38 +41,75 @@ define : doctests-extract-from-string s
This is an example test:
- (test #:name mytest
+ (test \"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)))
+ (test \"mytest2\"
+ (test-assert #t))
"
- let : : idx : string-index s "(test"
- when idx
- let : : sub : substring s idx
- with-input-from-string sub
- λ () : read
+ 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 : doctests-testmod mod
. "Execute all doctests in the current module"
let*
: names : module-map (λ (sym var) sym) mod
+ filename
+ if (module-filename mod) (module-filename mod)
+ string-join (cons "-" (map symbol->string (module-name mod))) "-"
docstrings
map (λ (x) (if (procedure? x) (procedure-documentation x)))
map (λ (x) (module-ref mod x)) names
- let loop : (names names) (docstrings docstrings)
+ let loop
+ : names names
+ docstrings docstrings
when : not : null? docstrings
when : string? : car docstrings
let*
: name : car names
docstring : car docstrings
- doctest : doctests-extract-from-string : car docstrings
- write : list name doctest
- newline
- let :
- primitive-eval doctest
- newline
+ let loop-tests
+ : doctests : doctests-extract-from-string : car docstrings
+ when : and (list? doctests) : not : null? doctests
+ let*
+ : doctest : car doctests
+ testid
+ if : not : list? doctest
+ . #f
+ string-join : list filename (symbol->string name) : car : cdr doctest
+ . "--"
+ cleaned
+ if : not : list? doctest
+ . '#f
+ append
+ cons 'begin
+ cons '(import (srfi srfi-64))
+ cons
+ list 'test-begin testid
+ cdr : cdr doctest
+ list : list 'test-end testid
+ when cleaned
+ let :
+ eval cleaned mod
+ newline
+ loop-tests : cdr doctests
loop (cdr names) (cdr docstrings)
define %this-module : current-module