source: project/release/5/simple-tests/tags/2.0.3/simple-tests.scm @ 38612

Last change on this file since 38612 was 38612, checked in by juergen, 6 months ago

simple-tests-2.0.3 state-changing functions now accepted

File size: 14.9 KB
Line 
1
2; Author: Juergen Lorenz
3; ju (at) jugilo (dot) de
4;
5; Copyright (c) 2011-2020, Juergen Lorenz
6; All rights reserved.
7;
8; Redistribution and use in source and binary forms, with or without
9; modification, are permitted provided that the following conditions are
10; met:
11;
12; Redistributions of source code must retain the above copyright
13; notice, this list of conditions and the following disclaimer.
14;
15; Redistributions in binary form must reproduce the above copyright
16; notice, this list of conditions and the following disclaimer in the
17; documentation and/or other materials provided with the distribution.
18;
19; Neither the name of the author nor the names of its contributors may be
20; used to endorse or promote products derived from this software without
21; specific prior written permission.
22;
23; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
26; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
27; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
29; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34;
35
36#|[
37This is a simple Unit Test Framework inspired by Peter Seibel's
38"Practical Common Lisp" together with some routines which might be
39useful for debugging.
40A second test interface is added with version 2.0
41]|#
42
43
44(module simple-tests (
45  ; common
46  simple-tests 
47  and?
48  writeln
49  pe
50  xpr:val
51  ppp
52  xpr:val*
53  ppp*
54  ; old interface
55  define-test
56  (compound-test group-on-cdrs)
57  *locations*
58  *failures*
59  ; new interface
60  ==
61  define-checks
62  (check-all check-all-proc)
63  )
64
65(import scheme (chicken base) (chicken syntax) (chicken pretty-print))
66
67(import-for-syntax (only (chicken base) chop))
68
69;;;;;; Common interface ;;;;;;
70
71;;; (simple-tests [sym])
72;;; ---------------------
73;;; documentation procedure
74(define simple-tests
75  (let (
76    (signatures '((simple-tests sym ..)
77                  (and? xpr ...)
78                  (writeln xpr ....)
79                  (pe macro-code)
80                  (xpr:val xpr ...)
81                  (ppp xpr ...)
82                  (xpr:val* {xpr val} ...)
83                  (ppp* {xpr val} ...)
84
85                  (define-test (name . parameters) form . forms)
86                  (check form . forms)
87                  (compound-test (name) test . tests)
88
89                  (==)
90                  (== x)
91                  (== type? type-equal?)
92                  (define-checks (name? verbose? {arg val} ...) {xpr expected} ....)
93                  (check-all name check-xpr ....)))
94    )
95    (case-lambda
96      (() (map car signatures))
97      ((sym) (assq sym signatures)))))
98
99(define (writeln . args)
100  (for-each (lambda (a)
101              (write a)
102              (display " "))
103            args)
104  (newline))
105
106;;; (and? . xprs)
107;;; -------------
108;;; non-short-circuited and which executes all side-effects
109(define (and? . xprs)
110  (let ((result #t))
111    (for-each (lambda (x) (if (not x) (set! result #f)))
112              xprs)
113    result))
114
115;;; (pe macro-code)
116;;; ---------------
117;;; composes pretty-print and expand
118(define (pe macro-code)
119  (pp (expand macro-code)))
120
121#|[
122The following macro, xpr:val, pretty-prints the literal representation
123of each of its arguments as well as their respective values.  The call
124to eval-when guarantees, that the whole expression does nothing in
125compiled code.
126]|#
127
128;;; (xpr:val xpr ...)
129;;; -----------------
130;;; print each xpr quoted in a headline and pretty-print xpr's computed
131;;; value.
132(define-syntax xpr:val
133  (syntax-rules ()
134    ((_ xpr ...)
135     (cond-expand
136       ((not compiling)
137        (begin (print "Computing " 'xpr " ...")
138               (pp xpr)
139               )
140        ...
141        )
142       (else)))))
143
144;;; (ppp xpr ...)
145;;; -------------
146;;; print each xpr quoted in a headline and pretty-print xpr's computed
147;;; value. Alias to xpr:val.
148(define-syntax ppp
149  (syntax-rules ()
150    ((_ xpr ...)
151     (xpr:val xpr ...))))
152
153(define-syntax help-ppp* ; internal
154  (syntax-rules ()
155    ((_)
156     (print))
157    ((_ xpr val)
158     (begin (print "Testing " 'xpr " ...")
159            (print* "computed: ") (pp xpr)
160            (print* "expected: ") (pp val)
161            ))
162    ((_ xpr val . pairs)
163     (begin (help-ppp* xpr val)
164            (help-ppp* . pairs)))
165    ))
166;
167;;;; (ppp* {xpr val} ...)
168;;; --------------------
169;;; print each xpr quoted in a headline and pretty-print xpr's computed
170;;; and expected value.
171(define-syntax ppp*
172  (syntax-rules ()
173    ((_ . pairs)
174     (cond-expand
175       ((not compiling)
176        (help-ppp* . pairs))
177       (else)))))
178
179;;; (xpr:val* {xpr val} ...)
180;;; ------------------------
181;;; print each xpr quoted in a headline and pretty-print xpr's computed
182;;; and expected value.
183;;; Alias to ppp*
184(define-syntax xpr:val*
185  (syntax-rules ()
186    ((_ . pairs)
187     (ppp* . pairs))))
188
189;;;;;;;; old interface ;;;;;;;;;
190
191;; helper macro because I don't want to export it
192(define-syntax disp
193  (syntax-rules ()
194    ((_)
195     (lambda (x) (display " ") (display x)))))
196
197;;; (report-result loc form)
198;;; ------------------------
199;;; reports succuss or failure of form and updates failures if necessary
200(define-syntax report-result
201  (syntax-rules ()
202    ((_ loc form)
203     (if form
204       (begin
205         (cond-expand
206           (compiling (print 'form))
207           (else (pp 'form)))
208         (display "... passed in")
209         (for-each (disp) loc)
210         (newline)
211         #t)
212       (begin
213         (cond-expand
214           (compiling (print 'form))
215           (else (pp 'form)))
216         (display "!!! FAILED IN")
217         (for-each (disp) loc)
218         (newline)
219         (set! *failures* (cons (cons 'form loc) *failures*))
220         #f)))))
221
222;;; (check . forms)
223;;; --------------------
224;;; report result of all forms
225(define-syntax check
226  (syntax-rules ()
227    ((_ form ...)
228     (lambda (loc)
229       (and? (report-result loc form)
230             ...)))))
231
232;; internal helper
233(define-syntax show-args
234 (syntax-rules ()
235   ((_ (name arg ...))
236    `(name (arg ,arg) ...))
237   ((_ arg) arg)))
238
239;;; (define-test (name . parameters) form . forms)
240;;; ----------------------------------------------
241;;; creates a test function
242(define-syntax define-test
243  (syntax-rules ()
244    ((_ (name . parameters) form . forms)
245     (define (name . parameters)
246       (fluid-let (
247         (*locations*
248           (cons (show-args (name . parameters)) *locations*))
249         )
250         ((check form . forms) *locations*))))))
251
252;;; (compound-test (name) test . tests)
253;;; -----------------------------------
254;;; invokes all tests and reports a summary
255(define-syntax compound-test
256  (syntax-rules ()
257    ((_ (name) test0 test1 ...)
258     (begin
259       (print "\nTesting " 'name " ...")
260       (print "----------------------------")
261       (let ((result (and? test0 test1 ...)))
262         (print "\nResults of " 'name)
263         (print "----------------------------")
264         (if result
265           (begin
266             (print "All tests passed")
267             (exit 0))
268           (let ((groups (group-on-cdrs (reverse *failures*))))
269             (print "SOME TESTS FAILED IN ...")
270             (for-each (lambda (x)
271                         (display "...")
272                         (for-each (disp) (cdar x))
273                         (newline)
274                         (cond-expand
275                           (compiling
276                             (for-each print (map car x)))
277                           (else
278                             (for-each pp (map car x))))
279                         ;(for-each print (map car x))
280                         ;(for-each pp (map car x))
281                         )
282                       groups)
283             (exit 1))))))))
284
285;;; internal helper from bindings
286(define (filter ok? lst)
287  (let loop ((lst lst) (yes '()) (no '()))
288    (if (null? lst)
289      (values (reverse yes) (reverse no))
290      (let ((first (car lst)) (rest (cdr lst)))
291        (if (ok? first)
292          (loop rest (cons first yes) no)
293          (loop rest yes (cons first no)))))))
294
295;;; (group-on-cdrs alist)
296;;; ---------------------
297;;; group into sublists with equal cdrs.
298(define (group-on-cdrs alst)
299  (let loop ((alst alst) (result '()))
300    (if (null? alst)
301      (reverse result)
302      (receive (yes no)
303        (filter (lambda (x) (equal? (cdr x) (cdar alst))) alst)
304        (loop no (cons yes result))))))
305
306;;; *locations*
307;;; -----------
308;;; dynamic variable
309(define *locations* '())
310
311;;; *failures*
312;;; ----------
313;;; global variable collecting failure information
314(define *failures* '())
315
316;;;;;;; new interface ;;;;;;;;;;;
317
318(define (curry proc) ; internal
319  (lambda (x) (lambda (y) (proc x y))))
320
321;(define (symbol=? x y)
322;  (string=? (symbol->string x) (symbol->string y)))
323
324;;; (==)
325;;; (== x)
326;;; (== type? type-equal?)
327;;; ----------------------
328;;; generic type equality as curried procedure
329(define ==
330  (let* ((pairs (list (cons pair? (curry equal?))
331                  (cons null? (curry eq?))
332                  (cons symbol? (curry eq?))
333                  (cons vector? (curry equal?))
334                  (cons string? (curry string=?))
335                  (cons boolean? (curry eq?))
336                  (cons char? (curry char=?))
337                  (cons number? (curry =))
338                  (cons procedure? (curry eqv?))
339                  (cons (lambda (x) #t) (curry equal?))))
340         (db pairs))
341    (case-lambda
342      (()
343       (set! db pairs); reset
344       (pp db))
345      ((x) ; return generic curried equality operator
346       (let loop ((db db))
347         (if ((caar db) x)
348           ;; check if second arg has rigth type as well
349           ;; without check ((cdar db) x) would work
350           ;; but produce an error for wrong type of second arg
351           (lambda (y) (and ((caar db) y) (((cdar db) x) y)))
352           ;; try next pair
353           (loop (cdr db)))))
354      ((type? type=?) ; add new eqaulity operator to db
355       (set! db (cons (cons type? (curry type=?)) db))
356       (pp db))
357      )))
358
359;;; (define-checks (name? verbose? {arg val} ...) {xpr expect} ....)
360;;; ----------------------------------------------------------------
361;;; returns a unary predicate, name?, comparing xpr with expect ....
362;;; and using arg val ... within this checks
363(define-syntax define-checks
364  (er-macro-transformer
365    (lambda (form rename compare?)
366      (let ((name (caadr form))
367            (verbose? (cadadr form))
368            (args* (cddadr form))
369            (pairs* (cddr form))
370            (%x (rename 'x))
371            (%tests (rename 'tests))
372            (%writeln (rename 'writeln))
373            (%set! (rename 'set!))
374            (%print (rename 'print))
375            (%print* (rename 'print*))
376            (%begin (rename 'begin))
377            (%let (rename 'let))
378            (%equal? (rename 'equal?)) ;;;
379            (%== (rename '==))
380            (%cons (rename 'cons))
381            (%and (rename 'and))
382            (%reverse (rename 'reverse))
383            (%if (rename 'if))
384            (%null? (rename 'null?))
385            (%fails (rename 'fails))
386            (%map (rename 'map))
387            (%cdr (rename 'cdr))
388            (%car (rename 'car))
389            (%apply (rename 'apply))
390            (%append (rename 'append))
391            (%define (rename 'define))
392            (%make-string (rename 'make-string))
393            (%string-length (rename 'string-length))
394            (%symbol->string (rename 'symbol->string))
395            (%when (rename 'when))
396            (%case-lambda (rename 'case-lambda))
397            (select-failures
398              (lambda (pairs)
399                (let loop ((pairs pairs))
400                  (cond
401                    ((null? pairs) '())
402                    ((caar pairs) (loop (cdr pairs)))
403                    (else
404                     (cons (car pairs) (loop (cdr pairs))))))))
405            )
406;`(,%define (,name ,verbose?)
407`(,%define ,name
408   (,%case-lambda
409     (()
410      (,name #t))
411     ((,verbose?)
412      (,%let ,(chop args* 2)
413        (,%when ,verbose?
414          (,%print "\nIn " ',name ":")
415          (,%print* "---"
416                    (,%make-string (,%string-length
417                                     (,%symbol->string ',name)) #\-)
418                    "-\n")
419          )
420        (,%let ((,%tests '()))
421          ,@(map (lambda (p)
422                   `(,%begin
423                      (,%let ((,%x ,(car p)))
424                         ; protect against functions changing state
425                        (,%when ,verbose?
426                          (,%print "testing " ',(car p) " ...")
427                          ;(,%print* "computed: ") (,%writeln ,(car p))
428                          (,%print* "computed: ") (,%writeln ,%x)
429                          (,%print* "expected: ") (,%writeln ,(cadr p))
430                          )
431                        (,%set! ,%tests
432                                ;(,%cons (,%cons ,(cons %equal? p) ',(car p)) ; ok
433                                ;(,%cons (,%cons ((,%== ,(car p)) ,(cadr p)) ',(car p))
434                                (,%cons (,%cons ((,%== ,%x) ,(cadr p)) ',(car p))
435                                        ,%tests)))
436                        ))
437                 (chop pairs* 2))
438          (,%let ((,%fails (,select-failures (,%reverse ,%tests))))
439            (,%when ,verbose?
440              (,%print "List of failed test expressions: "
441                       (,%map ,%cdr ,%fails))
442                       ;(,%apply ,%append (,%map ,%cdr ,%fails)))
443                       )
444            (,%if (,%null? ,%fails) #t #f)))))))
445 ))))
446
447(define (check-all-proc name . test-name-pairs) ; internal to check-all
448  ; used internally in check-all, must be exported within check-all
449  (let loop ((pairs (chop test-name-pairs 2)) (failures '()))
450    (cond
451      ((null? pairs)
452       (print "\nIn " name ":")
453       (print "==="
454              (make-string (string-length (symbol->string name)) #\=)
455              "=")
456       (print* "List of failed tests: "
457              (map car (reverse failures)))
458       (if (null? failures)
459         (begin (newline) (exit 0))
460         (begin (newline) (exit 1))))
461      ((caar pairs)
462       (loop (cdr pairs) failures))
463      (else
464        (loop (cdr pairs) (cons (cadar pairs) failures))))))
465
466;;; (check-all Name check-xpr ....)
467;;; -------------------------------
468;;; checks all check-expressions defined with define-checks
469;;; producing a list of failures and exiting with 0 or 1
470(define-syntax check-all
471  (er-macro-transformer
472    (lambda (form rename compare?)
473      (let ((name (cadr form))
474            (checks (cddr form))
475            (%check-all-proc (rename 'check-all-proc))
476            )
477        `(,%check-all-proc ',name
478                          ,@(apply append
479                                   (map (lambda (t) `(,t ',t))
480                                        checks)))))))
481 ) ; simple-tests
482
Note: See TracBrowser for help on using the repository browser.