(Arne Babenhauserheide)
2017-10-10: update examples for doctests and sexped ones update examples for doctests and sexped ones
diff --git a/examples/doctests-test.w b/examples/doctests-test.w
--- a/examples/doctests-test.w
+++ b/examples/doctests-test.w
@@ -9,17 +9,16 @@ define-module : examples doctests-test
import : examples doctests
define : foo
- . "(test 'foo
- (test-equal \"bar\" (foo)))
- "
+ . #((tests
+ ('foo
+ (test-equal "bar" (foo)))))
. "bar"
define %this-module : current-module
define : main args
- . " Testing doctests
- (test 'mytest
- (test-assert #t)
- (test-assert #f))
-"
+ . " Testing doctests"
+ . #((tests ('mytest
+ (test-assert #t)
+ (test-assert #f))))
doctests-testmod %this-module
diff --git a/examples/doctests-testone.scm b/examples/doctests-testone.scm
--- a/examples/doctests-testone.scm
+++ b/examples/doctests-testone.scm
@@ -5,9 +5,9 @@ exec guile -L $(dirname $(dirname $(real
(import (examples doctests))
(define (foo)
- "(test 'foo
- (test-equal \"bar\" (foo)))
- "
+ #((tests
+ ('foo
+ (test-equal "bar" (foo)))))
"bar")
(doctests-testmod (current-module))
diff --git a/examples/doctests.scm b/examples/doctests.scm
--- a/examples/doctests.scm
+++ b/examples/doctests.scm
@@ -1,13 +1,56 @@
#!/usr/bin/env sh
-exec guile -L $(dirname $(dirname $(realpath "$0"))) -e '(@@ (examples doctests) main)' -s "$0" "$@"
+(# -*- wisp -*-)
+(guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (language wisp spec))')
+(exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -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)
+
+;; 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 (examples doctests)
#:export (doctests-testmod))
(import (ice-9 optargs)
(ice-9 rdelim)
(ice-9 match)
+ (ice-9 pretty-print)
(oop goops)
(texinfo reflection))
@@ -35,19 +78,7 @@ exec guile -L $(dirname $(dirname $(real
(loop (string-drop s 1) (+ i 1))))))
(define (doctests-extract-from-string s)
- "Extract all test calls from a given string.
-
- This is an example test:
-
- (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))
-"
+ "Extract all test calls from a given string."
(let lp
((str s)
(tests (list)))
@@ -65,50 +96,85 @@ exec guile -L $(dirname $(dirname $(real
(λ () (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"
+ "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) #\/) "-")
+ (if (module-filename mod) (string-join (string-split (module-filename mod) #\/ ) "-")
(string-join (cons "._" (map symbol->string (module-name mod))) "-")))
- (docstrings
- (map (λ (x) (if (procedure? x) (procedure-documentation x)))
+ (doctests
+ (map (λ (x) (if (procedure? x) (procedure-property x 'tests)))
(map (λ (x) (module-ref mod x)) names))))
(let loop
((names names)
- (docstrings docstrings))
- (when (not (null? docstrings))
- (when (string? (car docstrings))
- (let*
- ((name (car names))
- (docstring (car docstrings)))
- (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) (symbol->string (primitive-eval (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))))))
+ (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)