source: project/release/5/simple-tests/trunk/simple-tests.scm @ 38693

Last change on this file since 38693 was 38693, checked in by juergen, 5 months ago

simple-tests 2.3 with checks

File size: 20.6 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  ppp
51  ppp*
52  ppp**
53  xpr:val
54  xpr:val*
55  ==
56  ; old interface
57  define-test
58  (compound-test group-on-cdrs)
59  *locations*
60  *failures*
61  ; new interface
62  check
63  define-checks
64  do-checks
65  (check-all check-all-proc)
66  )
67
68(import scheme (chicken base) (chicken syntax) (chicken pretty-print))
69
70(import-for-syntax (only (chicken base) chop))
71
72;;;;;; Common interface ;;;;;;
73
74;;; (simple-tests [sym])
75;;; ---------------------
76;;; documentation procedure
77(define simple-tests
78  (let (
79    (signatures '((simple-tests
80                    procedure:
81                    (simple-tests sym ..)
82                    "documentation procedure")
83                  (and?
84                    procedure:
85                    (and? xpr ...)
86                    "Pascal like and procedure")
87                  (writeln
88                    procedure:
89                    (writeln xpr ....)
90                    "write analog of print")
91                  (pe
92                    procedure:
93                    (pe macro-code)
94                    " composes pretty-print and expand")
95                  (ppp
96                    macro:
97                    (ppp xpr ...)
98                    " print each xpr quoted in a headline"
99                    "and pretty-print xpr's computed value")
100                  (ppp*
101                    macro:
102                    (ppp* xpr ypr . xpr-yprs)
103                    "print each xpr quoted in a headline"
104                    "and pretty-print xpr's computed and"
105                    "expected value, ypr")
106                  (ppp**
107                    macro:
108                    (ppp** ((var val) ...) xpr ypr . xpr-yprs)
109                    "wraps ppp* into a let")
110                  (xpr:val
111                    macro:
112                    (xpr:val xpr ...)
113                    "alias to ppp")
114                  (xpr:val*
115                    macro:
116                    (xpr:val* xpr ypr . xpr-yprs)
117                    "alias to ppp*")
118                  (==
119                    procedure:
120                    (==)
121                    (== x)
122                    (== type? type-equal?)
123                    "generic type equality as curried procedure:"
124                    "the first resets the local database,"
125                    "the second is the curried equality check"
126                    "and the third adds a new equality procedure"
127                    "to the local database")
128
129                  (define-test
130                    macro:
131                    (define-test (name . parameters) form . forms)
132                    "creates a test function")
133                  (compound-test
134                    macro:
135                    (compound-test (name) test . tests)
136                    "checks all tests created with define-test"
137                    "and reports a summary of results")
138
139                  (check
140                    macro:
141                    (check ((var val) ...) xpr ypr . xpr-yprs)
142                    "compares xpr and ypr .... with == in the"
143                    "environment defined by (var val) ...")
144                  (define-checks
145                    macro:
146                    (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
147                    "returns a unary predicate, name?,"
148                    "comparing xpr with ypr ...."
149                    "and using var val ... within this checks."
150                    "verbose? controls the reported results")
151                  (do-checks
152                    macro:
153                    (do-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
154                    "alias to define-checks")
155                  (check-all
156                    macro:
157                    (check-all name check-xpr ....)
158                    "checks all check-expressions created by do-check"
159                    "and reports the results")))
160    )
161    (case-lambda
162      (() (map car signatures))
163      ((sym)
164       (let ((pair (assq sym signatures)))
165         (if pair
166           (for-each print (cdr pair))
167           (print "Choose one of " (map car signatures))))))))
168
169(define (writeln . args)
170  (for-each (lambda (a)
171              (write a)
172              (display " "))
173            args)
174  (newline))
175
176;;; (and? . xprs)
177;;; -------------
178;;; non-short-circuited and which executes all side-effects
179(define (and? . xprs)
180  (let ((result #t))
181    (for-each (lambda (x) (if (not x) (set! result #f)))
182              xprs)
183    result))
184
185;;; (pe macro-code)
186;;; ---------------
187;;; composes pretty-print and expand
188(define (pe macro-code)
189  (pp (expand macro-code)))
190
191#|[
192The following macro, xpr:val, pretty-prints the literal representation
193of each of its arguments as well as their respective values.  The call
194to eval-when guarantees, that the whole expression does nothing in
195compiled code.
196]|#
197
198;;; (xpr:val xpr ...)
199;;; -----------------
200;;; print each xpr quoted in a headline and pretty-print xpr's computed
201;;; value.
202(define-syntax xpr:val
203  (syntax-rules ()
204    ((_ xpr ...)
205     (cond-expand
206       ((not compiling)
207        (begin (print "Computing " 'xpr " ...")
208               (pp xpr)
209               )
210        ...
211        )
212       (else)))))
213
214;;; (ppp xpr ...)
215;;; -------------
216;;; print each xpr quoted in a headline and pretty-print xpr's computed
217;;; value. Alias to xpr:val.
218(define-syntax ppp
219  (syntax-rules ()
220    ((_ xpr ...)
221     (xpr:val xpr ...))))
222
223(define-syntax help-ppp* ; internal
224  (syntax-rules ()
225    ((_)
226     (print))
227    ((_ xpr ypr)
228     (begin (print "Testing " 'xpr " ...")
229            (print* "computed: ") (pp xpr)
230            (print* "expected: ") (pp ypr)
231            ))
232    ((_ xpr ypr . pairs)
233     (begin (help-ppp* xpr ypr)
234            (help-ppp* . pairs)))
235    ))
236;
237;;;; (ppp* {xpr ypr} ...)
238;;; --------------------
239;;; print each xpr quoted in a headline and pretty-print xpr's computed
240;;; and expected value, ypr.
241(define-syntax ppp*
242  (syntax-rules ()
243    ((_ . pairs)
244     (cond-expand
245       ((not compiling)
246        (help-ppp* . pairs))
247       (else)))))
248
249;;; (xpr:val* {xpr ypr} ...)
250;;; ------------------------
251;;; print each xpr quoted in a headline and pretty-print xpr's computed
252;;; and expected value, ypr.
253;;; Alias to ppp*
254(define-syntax xpr:val*
255  (syntax-rules ()
256    ((_ . pairs)
257     (ppp* . pairs))))
258
259;;; (ppp** ((var val) ...) xpr ypr . other xpr-ypr-pairs)
260;;; -----------------------------------------------------
261;;; ppp* wrapped into a let
262(define-syntax ppp**
263  (syntax-rules ()
264    ((_ ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
265     (let ((var val) ...)
266       (ppp* xpr ypr . other-xpr-ypr-pairs)))))
267
268;;;;;;;; old interface ;;;;;;;;;
269
270;; helper macro because I don't want to export it
271(define-syntax disp
272  (syntax-rules ()
273    ((_)
274     (lambda (x) (display " ") (display x)))))
275
276;;; (report-result loc form)
277;;; ------------------------
278;;; reports succuss or failure of form and updates failures if necessary
279(define-syntax report-result
280  (syntax-rules ()
281    ((_ loc form)
282     (if form
283       (begin
284         (cond-expand
285           (compiling (print 'form))
286           (else (pp 'form)))
287         (display "... passed in")
288         (for-each (disp) loc)
289         (newline)
290         #t)
291       (begin
292         (cond-expand
293           (compiling (print 'form))
294           (else (pp 'form)))
295         (display "!!! FAILED IN")
296         (for-each (disp) loc)
297         (newline)
298         (set! *failures* (cons (cons 'form loc) *failures*))
299         #f)))))
300
301;;; (check-em . forms) ;; internal
302;;; ------------------
303;;; report result of all forms
304(define-syntax check-em
305  (syntax-rules ()
306    ((_ form ...)
307     (lambda (loc)
308       (and? (report-result loc form)
309             ...)))))
310
311;; internal helper
312(define-syntax show-args
313 (syntax-rules ()
314   ((_ (name arg ...))
315    `(name (arg ,arg) ...))
316   ((_ arg) arg)))
317
318;;; (define-test (name . parameters) form . forms)
319;;; ----------------------------------------------
320;;; creates a test function
321(define-syntax define-test
322  (syntax-rules ()
323    ((_ (name . parameters) form . forms)
324     (define (name . parameters)
325       (fluid-let (
326         (*locations*
327           (cons (show-args (name . parameters)) *locations*))
328         )
329         ((check-em form . forms) *locations*))))))
330
331;;; (compound-test (name) test . tests)
332;;; -----------------------------------
333;;; invokes all tests and reports a summary
334(define-syntax compound-test
335  (syntax-rules ()
336    ((_ (name) test0 test1 ...)
337     (begin
338       (print "\nTesting " 'name " ...")
339       (print "----------------------------")
340       (let ((result (and? test0 test1 ...)))
341         (print "\nResults of " 'name)
342         (print "----------------------------")
343         (if result
344           (begin
345             (print "All tests passed")
346             (exit 0))
347           (let ((groups (group-on-cdrs (reverse *failures*))))
348             (print "SOME TESTS FAILED IN ...")
349             (for-each (lambda (x)
350                         (display "...")
351                         (for-each (disp) (cdar x))
352                         (newline)
353                         (cond-expand
354                           (compiling
355                             (for-each print (map car x)))
356                           (else
357                             (for-each pp (map car x))))
358                         ;(for-each print (map car x))
359                         ;(for-each pp (map car x))
360                         )
361                       groups)
362             (exit 1))))))))
363
364;;; internal helper from bindings
365(define (filter ok? lst)
366  (let loop ((lst lst) (yes '()) (no '()))
367    (if (null? lst)
368      (values (reverse yes) (reverse no))
369      (let ((first (car lst)) (rest (cdr lst)))
370        (if (ok? first)
371          (loop rest (cons first yes) no)
372          (loop rest yes (cons first no)))))))
373
374;;; (group-on-cdrs alist)
375;;; ---------------------
376;;; group into sublists with equal cdrs.
377(define (group-on-cdrs alst)
378  (let loop ((alst alst) (result '()))
379    (if (null? alst)
380      (reverse result)
381      (receive (yes no)
382        (filter (lambda (x) (equal? (cdr x) (cdar alst))) alst)
383        (loop no (cons yes result))))))
384
385;;; *locations*
386;;; -----------
387;;; dynamic variable
388(define *locations* '())
389
390;;; *failures*
391;;; ----------
392;;; global variable collecting failure information
393(define *failures* '())
394
395;;;;;;; new interface ;;;;;;;;;;;
396
397(define (curry proc) ; internal
398  (lambda (x) (lambda (y) (proc x y))))
399
400;(define (symbol=? x y)
401;  (string=? (symbol->string x) (symbol->string y)))
402
403;;; (==)
404;;; (== x)
405;;; (== type? type-equal?)
406;;; ----------------------
407;;; generic type equality as curried procedure
408(define ==
409  (let* ((pairs (list (cons pair? (curry equal?))
410                  (cons null? (curry eq?))
411                  (cons symbol? (curry eq?))
412                  (cons vector? (curry equal?))
413                  (cons string? (curry string=?))
414                  (cons boolean? (curry eq?))
415                  (cons char? (curry char=?))
416                  (cons number? (curry =))
417                  (cons procedure? (curry eqv?))
418                  (cons (lambda (x) #t) (curry equal?))))
419         (db pairs))
420    (case-lambda
421      (()
422       (set! db pairs); reset
423       (pp db))
424      ((x) ; return generic curried equality operator
425       (let loop ((db db))
426         (if ((caar db) x)
427           ;; check if second arg has rigth type as well
428           ;; without check ((cdar db) x) would work
429           ;; but produce an error for wrong type of second arg
430           (lambda (y) (and ((caar db) y) (((cdar db) x) y)))
431           ;; try next pair
432           (loop (cdr db)))))
433      ((type? type=?) ; add new eqaulity operator to db
434       (set! db (cons (cons type? (curry type=?)) db))
435       (pp db))
436      )))
437
438;;; (check* ((var val) ...) xpr ypr . xpr-yprs) ;; internal
439;;; --------------------------------------------------------------
440;(define-syntax check*
441;  (er-macro-transformer
442;    (lambda (form rename compare?)
443;      (let ((var-vals (cadr form))
444;            (xpr-yprs (cddr form))
445;            (%verbose? (rename 'verbose?))
446;            (%lambda (rename 'lambda))
447;            (%x (rename 'x))
448;            (%tests (rename 'tests))
449;            (%writeln (rename 'writeln))
450;            (%set! (rename 'set!))
451;            (%print (rename 'print))
452;            (%print* (rename 'print*))
453;            (%begin (rename 'begin))
454;            (%let (rename 'let))
455;            (%== (rename '==))
456;            (%cons (rename 'cons))
457;            (%reverse (rename 'reverse))
458;            (%if (rename 'if))
459;            (%null? (rename 'null?))
460;            (%fails (rename 'fails))
461;            (%map (rename 'map))
462;            (%cdr (rename 'cdr))
463;            (%when (rename 'when))
464;            (select-failures
465;              (lambda (pairs)
466;                (let loop ((pairs pairs))
467;                  (cond
468;                    ((null? pairs) '())
469;                    ((caar pairs) (loop (cdr pairs)))
470;                    (else
471;                     (cons (car pairs) (loop (cdr pairs))))))))
472;            )
473;`(,%lambda (,%verbose?)
474;   (,%let ,var-vals
475;          (,%let ((,%tests '()))
476;            ,@(map (lambda (p)
477;                     `(,%begin
478;                        (,%let ((,%x ,(car p)))
479;                           ; protect against functions changing state
480;                          (,%when ,%verbose?
481;                            (,%print "testing " ',(car p) " ...")
482;                            (,%print* "computed: ") (,%writeln ,%x)
483;                            (,%print* "expected: ") (,%writeln ,(cadr p))
484;                            )
485;                          (,%set! ,%tests
486;                                  (,%cons (,%cons ((,%== ,%x) ,(cadr p)) ',(car p))
487;                                          ,%tests)))
488;                          ))
489;                   (chop xpr-yprs 2))
490;            (,%let ((,%fails (,select-failures (,%reverse ,%tests))))
491;              (,%when ,%verbose?
492;                (,%print "List of failed test expressions: "
493;                         (,%map ,%cdr ,%fails))
494;                         )
495;              (,%if (,%null? ,%fails) #t #f)))))
496; ))))
497(define-syntax check*
498  (ir-macro-transformer
499    (lambda (form inject compare?)
500      (let ((var-vals (cadr form))
501            (xpr-yprs (cddr form))
502            (select-failures
503              (lambda (pairs)
504                (let loop ((pairs pairs))
505                  (cond
506                    ((null? pairs) '())
507                    ((caar pairs) (loop (cdr pairs)))
508                    (else
509                     (cons (car pairs) (loop (cdr pairs))))))))
510            )
511`(lambda (verbose?)
512   (let ,var-vals
513          (let ((tests '()))
514            ,@(map (lambda (p)
515                     `(begin
516                        (let ((x ,(car p)))
517                           ; protect against functions changing state
518                          (when verbose?
519                            (print "testing " ',(car p) " ...")
520                            (print* "computed: ") (writeln x)
521                            (print* "expected: ") (writeln ,(cadr p))
522                            )
523                          (set! tests
524                                  (cons (cons ((== x) ,(cadr p)) ',(car p))
525                                          tests)))
526                          ))
527                   (chop xpr-yprs 2))
528            (let ((fails (,select-failures (reverse tests))))
529              (when verbose?
530                (print "List of failed test expressions: "
531                         (map cdr fails))
532                         )
533              (if (null? fails) #t #f)))))
534 ))))
535;;; (check ((var val) ...) xpr ypr . xpr-yprs)
536;;; ------------------------------------------
537;;; compare xpr and ypr .... in sequence with ==
538;;; in the environment defined by var val ...
539(define-syntax check
540  (syntax-rules ()
541    ((_ ((var val) ...) xpr ypr . xpr-yprs)
542     ((check* ((var val) ...) xpr ypr . xpr-yprs) #t))))
543
544;;; (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
545;;; --------------------------------------------------------------
546;;; returns a unary predicate, name?, comparing xpr with ypr ....
547;;; and using var val ... within this checks,
548;;; verbose? controls the reported summary.
549(define-syntax define-checks
550  (ir-macro-transformer
551    (lambda (form inject compare?)
552      (let ((header (cadr form))
553            (xpr-yprs (cddr form)))
554        (let ((name (car header))
555              (verbose? (cadr header))
556              (var-vals (cddr header)))
557    `(define ,name
558       (case-lambda
559         (()
560          (,name #t))
561         ((,verbose?)
562          (when ,verbose?
563            (print "\nIn " ',name ":")
564            (print* "---"
565                    (make-string (string-length
566                                   (symbol->string ',name)) #\-)
567                    "-\n")
568            )
569            ((check* ,(chop var-vals 2)
570               ,@xpr-yprs) ,verbose?)))))))))
571
572;;; (do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
573;;; ---------------------------------------------------------------
574;;; returns a unary predicate, name?, comparing xpr with ypr ....
575;;; and using var val ... within this checks,
576;;; alias to define-checks
577(define-syntax do-checks
578  (syntax-rules ()
579    ((_(name? verbose? . var-val-pairs) xpr ypr . xpr-ypr-pairs)
580     (define-checks (name? verbose? . var-val-pairs)
581       xpr ypr .  xpr-ypr-pairs))))
582
583(define (check-all-proc name . test-name-pairs) ; internal to check-all
584  ; used internally in check-all, must be exported within check-all
585  (let loop ((pairs (chop test-name-pairs 2)) (failures '()))
586    (cond
587      ((null? pairs)
588       (print "\nIn " name ":")
589       (print "==="
590              (make-string (string-length (symbol->string name)) #\=)
591              "=")
592       (print* "List of failed tests: "
593              (map car (reverse failures)))
594       (if (null? failures)
595         (begin (newline) (exit 0))
596         (begin (newline) (exit 1))))
597      ((caar pairs)
598       (loop (cdr pairs) failures))
599      (else
600        (loop (cdr pairs) (cons (cadar pairs) failures))))))
601
602;;; (check-all Name check-xpr ....)
603;;; -------------------------------
604;;; checks all check-expressions defined with define-checks
605;;; producing a list of failures and exiting with 0 or 1
606(define-syntax check-all
607  (er-macro-transformer
608    (lambda (form rename compare?)
609      (let ((name (cadr form))
610            (checks (cddr form))
611            (%check-all-proc (rename 'check-all-proc))
612            )
613        `(,%check-all-proc ',name
614                          ,@(apply append
615                                   (map (lambda (t) `(,t ',t))
616                                        checks)))))))
617 ) ; simple-tests
618
619;(import simple-tests)
620;
621;(pe '(check ((lst '(0 1 2)))
622;        (car lst)
623;        0
624;        (cdr lst)
625;        '(1 2)))
626;
627;(check ((lst '(0 1 2)))
628;        (car lst)
629;        0
630;        (cdr lst)
631;        '(0 1 2))
632;
633;(pe '(define-checks (foo verbose? lst '(0 1 2))
634;        (car lst)
635;        0
636;        (cdr lst)
637;        '(1 2)))
638;(define-checks (foo verbose? lst '(0 1 2))
639;        (car lst)
640;        0
641;        (cdr lst)
642;        '(1 2 3))
643;(foo #t)
644;(ppp (foo #f))
Note: See TracBrowser for help on using the repository browser.