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

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

simple-tests 2.2 with ppp

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