Changeset 38279 in project


Ignore:
Timestamp:
03/16/20 16:11:32 (2 weeks ago)
Author:
juergen
Message:

simple-tests 2.0 with a second interface

Location:
release/5/simple-tests
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/5/simple-tests/tags/2.0/simple-tests.egg

    r37984 r38279  
    11;;;; simple-tests.egg -*- Scheme -*-
    22
    3 ((synopsis "Some simple testing routines")
     3((synopsis "Some simple test routines")
    44 (category testing)
    55 (license "BSD")
    6  (version "1.1")
     6 (version "2.0")
    77 (author "Juergen Lorenz")
    88 (components (extension simple-tests)))
  • release/5/simple-tests/tags/2.0/simple-tests.scm

    r37984 r38279  
    33; ju (at) jugilo (dot) de
    44;
    5 ; Last update: Aug 18, 2018 (port to chicken-5)
    6 ;
    7 ; Copyright (c) 2011-2018, Juergen Lorenz
     5; Copyright (c) 2011-2020, Juergen Lorenz
    86; All rights reserved.
    97;
     
    3937This is a simple Unit Test Framework inspired by Peter Seibel's
    4038"Practical Common Lisp" together with some routines which might be
    41 useful for debugging
     39useful for debugging.
     40A second test interface is added with version 2.0
    4241]|#
    4342
    4443
    4544(module simple-tests (
    46    simple-tests
    47    define-test
    48    (compound-test group-on-cdrs)
    49    xpr:val
    50    ppp
    51    ppp*
    52    and?
    53    pe
    54    *locations*
    55    *failures*
    56    )
     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  )
    5764
    5865(import scheme (chicken base) (chicken syntax) (chicken pretty-print))
     66
     67(import-for-syntax (only (chicken base) chop))
     68
     69;;;;;; Common interface ;;;;;;
    5970
    6071;;; (simple-tests [sym])
     
    6374(define simple-tests
    6475  (let (
    65     (signatures '((define-test (name . parameters) form . forms)
     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)
    6686                  (check form . forms)
    6787                  (compound-test (name) test . tests)
    68                   (xpr:val xpr ...)
    69                   (ppp xpr ...)
    70                   (ppp* {xpr val} ...)
    71                   (and? xpr ...)
    72                   (pe macro-code)))
     88
     89                  (==)
     90                  (== x)
     91                  (== type? type-equal?)
     92                  (define-checks (name? verbose? {arg val} ...) {xpr expected} ....)
     93                  (check-all name check-xpr ....)))
    7394    )
    7495    (case-lambda
     
    7697      ((sym) (assq sym signatures)))))
    7798
    78 #|[
    79 The following macro, xpr:val, pretty-prints the literal representation
    80 of each of its arguments as well as their respective values.  The call
    81 to eval-when guarantees, that the whole expression does nothing in
    82 compiled code.
    83 ]|#
    84 
    85 ;;; (xpr:val xpr ...)
    86 ;;; -----------------
    87 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    88 ;;; value.
    89 (define-syntax xpr:val
    90   (syntax-rules ()
    91     ((_ xpr ...)
    92      (cond-expand
    93        ((not compiling)
    94         (begin (print "=== " 'xpr " ===")
    95                (pp xpr)
    96                (newline))
    97         ...
    98         )
    99        (else)))))
    100 
    101 (define-syntax help-ppp*
    102   (syntax-rules ()
    103     ((_)
    104      (print))
    105     ((_ xpr val)
    106      (begin (print "=== " 'xpr " ===")
    107             (pp xpr)
    108             (pp val)
    109             (newline)))
    110     ((_ xpr val . pairs)
    111      (begin (help-ppp* xpr val)
    112             (help-ppp* . pairs)))
    113     ))
    114 
    115 ;;; (ppp* {xpr val} ...)
    116 ;;; --------------------
    117 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    118 ;;; and expected value.
    119 (define-syntax ppp*
    120   (syntax-rules ()
    121     ((_ . pairs)
    122      (cond-expand
    123        ((not compiling)
    124         (help-ppp* . pairs))
    125        (else)))))
    126 
    127 
    128 ;;; (ppp xpr ...)
    129 ;;; -------------
    130 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    131 ;;; value. Alias to xpr:val.
    132 (define-syntax ppp
    133   (syntax-rules ()
    134     ((_ xpr ...)
    135      (xpr:val xpr ...))))
     99(define (writeln . args)
     100  (for-each (lambda (a)
     101              (write a)
     102              (display " "))
     103            args)
     104  (newline))
    136105
    137106;;; (and? . xprs)
     
    143112              xprs)
    144113    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 ;;;;;;;;;
    145190
    146191;; helper macro because I don't want to export it
     
    238283             (exit 1))))))))
    239284
    240 ;;; (pe macro-code)
    241 ;;; ---------------
    242 ;;; composes pretty-print and expand
    243 (define (pe macro-code)
    244   (pp (expand macro-code)))
    245 
    246285;;; internal helper from bindings
    247286(define (filter ok? lst)
     
    275314(define *failures* '())
    276315
    277 ) ; module simple-tests
    278 
    279 ;(import simple-tests (chicken pretty-print))
    280 ;(pp (expand '(define-test (foo x) (= 5 3) (null? '()))))
    281 ;(ppp* (+ 3 5) 8 (* 3 5) 15 (- 2 1 1) 0)
    282 ;(ppp*)
     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            (%tests (rename 'tests))
     371            (%writeln (rename 'writeln))
     372            (%set! (rename 'set!))
     373            (%print (rename 'print))
     374            (%print* (rename 'print*))
     375            (%begin (rename 'begin))
     376            (%let (rename 'let))
     377            (%equal? (rename 'equal?)) ;;;
     378            (%== (rename '==))
     379            (%cons (rename 'cons))
     380            (%and (rename 'and))
     381            (%reverse (rename 'reverse))
     382            (%if (rename 'if))
     383            (%null? (rename 'null?))
     384            (%fails (rename 'fails))
     385            (%map (rename 'map))
     386            (%cdr (rename 'cdr))
     387            (%car (rename 'car))
     388            (%apply (rename 'apply))
     389            (%append (rename 'append))
     390            (%define (rename 'define))
     391            (%make-string (rename 'make-string))
     392            (%string-length (rename 'string-length))
     393            (%symbol->string (rename 'symbol->string))
     394            (%when (rename 'when))
     395            (select-failures
     396              (lambda (pairs)
     397                (let loop ((pairs pairs))
     398                  (cond
     399                    ((null? pairs) '())
     400                    ((caar pairs) (loop (cdr pairs)))
     401                    (else
     402                     (cons (car pairs) (loop (cdr pairs))))))))
     403            )
     404`(,%define (,name ,verbose?)
     405   (,%let ,(chop args* 2)
     406     (,%when ,verbose?
     407       (,%print "In " ',name ":")
     408       (,%print* "---"
     409                 (,%make-string (,%string-length
     410                                  (,%symbol->string ',name)) #\-)
     411                 "-")
     412       )
     413     (,%let ((,%tests '()))
     414       ,@(map (lambda (p)
     415                `(,%begin
     416                   (,%when ,verbose?
     417                     (,%print "\ntesting " ',(car p) " ...")
     418                     ;;(,%writeln 'computed ,(car p))
     419                     (,%print* "computed: ") (,%writeln ,(car p))
     420                     ;;(,%writeln 'expected ,(cadr p))
     421                     (,%print* "expected: ") (,%writeln ,(cadr p))
     422                     )
     423                   (,%set! ,%tests
     424                           ;(,%cons (,%cons ,(cons %equal? p) ',(car p)) ; ok
     425                           (,%cons (,%cons ((,%== ,(car p)) ,(cadr p)) ',(car p))
     426                                   ,%tests))
     427                   ))
     428              (chop pairs* 2))
     429       (,%let ((,%fails (,select-failures (,%reverse ,%tests))))
     430         (,%when ,verbose?
     431           (,%print "\nList of failed test expressions: "
     432                    (,%map ,%cdr ,%fails) "\n")
     433                    ;(,%apply ,%append (,%map ,%cdr ,%fails)))
     434                    )
     435         (,%if (,%null? ,%fails) #t #f)))))
     436 ))))
     437
     438(define (check-all-proc name . test-name-pairs) ; internal to check-all
     439  ; used internally in check-all, must be exported within check-all
     440  (let loop ((pairs (chop test-name-pairs 2)) (failures '()))
     441    (cond
     442      ((null? pairs)
     443       (print "In " name ":")
     444       (print "==="
     445              (make-string (string-length (symbol->string name)) #\=)
     446              "=")
     447       (print* "List of failed tests: "
     448              (map car (reverse failures)))
     449       (if (null? failures)
     450         (exit 0)
     451         (exit 1)))
     452      ((caar pairs)
     453       (loop (cdr pairs) failures))
     454      (else
     455        (loop (cdr pairs) (cons (cadar pairs) failures))))))
     456
     457;;; (check-all Name check-xpr ....)
     458;;; -------------------------------
     459;;; checks all check-expressions defined with define-checks
     460;;; producing a list of failures and exiting with 0 or 1
     461(define-syntax check-all
     462  (er-macro-transformer
     463    (lambda (form rename compare?)
     464      (let ((name (cadr form))
     465            (checks (cddr form))
     466            (%check-all-proc (rename 'check-all-proc))
     467            )
     468        `(,%check-all-proc ',name
     469                          ,@(apply append
     470                                   (map (lambda (t) `(,t ',t))
     471                                        checks)))))))
     472 ) ; simple-tests
     473
     474;(import simple-tests)
  • release/5/simple-tests/tags/2.0/tests/run.scm

    r36308 r38279  
    1 (require-library simple-tests)
    21(import simple-tests)
     2
     3;;; old interface
    34
    45(define-test (bar n)
     
    1314  (positive? 3))
    1415
    15 (define-test (+?)
     16(define-test (++)
    1617  (= (+ 1 2) 3)
    1718  (= (+ 1 2 3) 6))
    1819
    19 (define-test (*?)
     20(define-test (**)
    2021  (= (* 1 2) 2)
    2122  (= (* 1 2 3) 6))
    2223
    23 (define-test (arithmetic?)
    24   (+?)
    25   (*?))
     24(define-test (arithmetic)
     25  (++)
     26  (**))
    2627
    2728(define-test (baz)
     
    3132
    3233
    33 (compound-test (simple-tests)
    34   (baz)
    35   (arithmetic?)
    36   (foo 1 2)
     34;(compound-test (simple-tests)
     35;  (baz)
     36;  (arithmetic?)
     37;  (foo 1 2)
     38;  )
     39
     40;;; new interface
     41
     42(define-checks (bar? verbose? n 5)
     43  (positive? n) #t
     44  (even? n) #f)
     45
     46(define-checks (+? verbose?)
     47  (+ 1 2) 3
     48  (+ 1 2 3) 6)
     49
     50(define-checks (*? verbose?)
     51  (* 1 2) 2
     52  (* 1 2 3) 6)
     53
     54(define-checks (arithmetic? verbose?)
     55  (+? #f) #t
     56  (*? #f) #t)
     57
     58(define-checks (baz? verbose?)
     59  (and? #t #t #t) #t
     60  (and?) #t
     61  (and? #t #f #t) #f)
     62
     63(define-checks (qux? verbose?)
     64  ((== "x") "y") #f
     65  ((== "x") "x") #t
     66  ((== baz?) baz?) #t
     67  ((== baz?) bar) #f
     68  ((== '()) '()) #t
     69  ((== 'x) 'y) #f
     70  ((== 'x) 'x) #t
     71  ((== #(0 1 2)) #(0 1 2)) #t
     72  ((== #(0 1 2)) '(0 1 2)) #f
    3773  )
     74
     75(check-all SIMPLE (bar? #t) (*? #t) (+? #t) (arithmetic? #t) (baz? #t)
     76           (qux? #t))
  • release/5/simple-tests/trunk/simple-tests.egg

    r37984 r38279  
    11;;;; simple-tests.egg -*- Scheme -*-
    22
    3 ((synopsis "Some simple testing routines")
     3((synopsis "Some simple test routines")
    44 (category testing)
    55 (license "BSD")
    6  (version "1.1")
     6 (version "2.0")
    77 (author "Juergen Lorenz")
    88 (components (extension simple-tests)))
  • release/5/simple-tests/trunk/simple-tests.scm

    r37984 r38279  
    33; ju (at) jugilo (dot) de
    44;
    5 ; Last update: Aug 18, 2018 (port to chicken-5)
    6 ;
    7 ; Copyright (c) 2011-2018, Juergen Lorenz
     5; Copyright (c) 2011-2020, Juergen Lorenz
    86; All rights reserved.
    97;
     
    3937This is a simple Unit Test Framework inspired by Peter Seibel's
    4038"Practical Common Lisp" together with some routines which might be
    41 useful for debugging
     39useful for debugging.
     40A second test interface is added with version 2.0
    4241]|#
    4342
    4443
    4544(module simple-tests (
    46    simple-tests
    47    define-test
    48    (compound-test group-on-cdrs)
    49    xpr:val
    50    ppp
    51    ppp*
    52    and?
    53    pe
    54    *locations*
    55    *failures*
    56    )
     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  )
    5764
    5865(import scheme (chicken base) (chicken syntax) (chicken pretty-print))
     66
     67(import-for-syntax (only (chicken base) chop))
     68
     69;;;;;; Common interface ;;;;;;
    5970
    6071;;; (simple-tests [sym])
     
    6374(define simple-tests
    6475  (let (
    65     (signatures '((define-test (name . parameters) form . forms)
     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)
    6686                  (check form . forms)
    6787                  (compound-test (name) test . tests)
    68                   (xpr:val xpr ...)
    69                   (ppp xpr ...)
    70                   (ppp* {xpr val} ...)
    71                   (and? xpr ...)
    72                   (pe macro-code)))
     88
     89                  (==)
     90                  (== x)
     91                  (== type? type-equal?)
     92                  (define-checks (name? verbose? {arg val} ...) {xpr expected} ....)
     93                  (check-all name check-xpr ....)))
    7394    )
    7495    (case-lambda
     
    7697      ((sym) (assq sym signatures)))))
    7798
    78 #|[
    79 The following macro, xpr:val, pretty-prints the literal representation
    80 of each of its arguments as well as their respective values.  The call
    81 to eval-when guarantees, that the whole expression does nothing in
    82 compiled code.
    83 ]|#
    84 
    85 ;;; (xpr:val xpr ...)
    86 ;;; -----------------
    87 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    88 ;;; value.
    89 (define-syntax xpr:val
    90   (syntax-rules ()
    91     ((_ xpr ...)
    92      (cond-expand
    93        ((not compiling)
    94         (begin (print "=== " 'xpr " ===")
    95                (pp xpr)
    96                (newline))
    97         ...
    98         )
    99        (else)))))
    100 
    101 (define-syntax help-ppp*
    102   (syntax-rules ()
    103     ((_)
    104      (print))
    105     ((_ xpr val)
    106      (begin (print "=== " 'xpr " ===")
    107             (pp xpr)
    108             (pp val)
    109             (newline)))
    110     ((_ xpr val . pairs)
    111      (begin (help-ppp* xpr val)
    112             (help-ppp* . pairs)))
    113     ))
    114 
    115 ;;; (ppp* {xpr val} ...)
    116 ;;; --------------------
    117 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    118 ;;; and expected value.
    119 (define-syntax ppp*
    120   (syntax-rules ()
    121     ((_ . pairs)
    122      (cond-expand
    123        ((not compiling)
    124         (help-ppp* . pairs))
    125        (else)))))
    126 
    127 
    128 ;;; (ppp xpr ...)
    129 ;;; -------------
    130 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    131 ;;; value. Alias to xpr:val.
    132 (define-syntax ppp
    133   (syntax-rules ()
    134     ((_ xpr ...)
    135      (xpr:val xpr ...))))
     99(define (writeln . args)
     100  (for-each (lambda (a)
     101              (write a)
     102              (display " "))
     103            args)
     104  (newline))
    136105
    137106;;; (and? . xprs)
     
    143112              xprs)
    144113    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 ;;;;;;;;;
    145190
    146191;; helper macro because I don't want to export it
     
    238283             (exit 1))))))))
    239284
    240 ;;; (pe macro-code)
    241 ;;; ---------------
    242 ;;; composes pretty-print and expand
    243 (define (pe macro-code)
    244   (pp (expand macro-code)))
    245 
    246285;;; internal helper from bindings
    247286(define (filter ok? lst)
     
    275314(define *failures* '())
    276315
    277 ) ; module simple-tests
    278 
    279 ;(import simple-tests (chicken pretty-print))
    280 ;(pp (expand '(define-test (foo x) (= 5 3) (null? '()))))
    281 ;(ppp* (+ 3 5) 8 (* 3 5) 15 (- 2 1 1) 0)
    282 ;(ppp*)
     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            (%tests (rename 'tests))
     371            (%writeln (rename 'writeln))
     372            (%set! (rename 'set!))
     373            (%print (rename 'print))
     374            (%print* (rename 'print*))
     375            (%begin (rename 'begin))
     376            (%let (rename 'let))
     377            (%equal? (rename 'equal?)) ;;;
     378            (%== (rename '==))
     379            (%cons (rename 'cons))
     380            (%and (rename 'and))
     381            (%reverse (rename 'reverse))
     382            (%if (rename 'if))
     383            (%null? (rename 'null?))
     384            (%fails (rename 'fails))
     385            (%map (rename 'map))
     386            (%cdr (rename 'cdr))
     387            (%car (rename 'car))
     388            (%apply (rename 'apply))
     389            (%append (rename 'append))
     390            (%define (rename 'define))
     391            (%make-string (rename 'make-string))
     392            (%string-length (rename 'string-length))
     393            (%symbol->string (rename 'symbol->string))
     394            (%when (rename 'when))
     395            (select-failures
     396              (lambda (pairs)
     397                (let loop ((pairs pairs))
     398                  (cond
     399                    ((null? pairs) '())
     400                    ((caar pairs) (loop (cdr pairs)))
     401                    (else
     402                     (cons (car pairs) (loop (cdr pairs))))))))
     403            )
     404`(,%define (,name ,verbose?)
     405   (,%let ,(chop args* 2)
     406     (,%when ,verbose?
     407       (,%print "In " ',name ":")
     408       (,%print* "---"
     409                 (,%make-string (,%string-length
     410                                  (,%symbol->string ',name)) #\-)
     411                 "-")
     412       )
     413     (,%let ((,%tests '()))
     414       ,@(map (lambda (p)
     415                `(,%begin
     416                   (,%when ,verbose?
     417                     (,%print "\ntesting " ',(car p) " ...")
     418                     ;;(,%writeln 'computed ,(car p))
     419                     (,%print* "computed: ") (,%writeln ,(car p))
     420                     ;;(,%writeln 'expected ,(cadr p))
     421                     (,%print* "expected: ") (,%writeln ,(cadr p))
     422                     )
     423                   (,%set! ,%tests
     424                           ;(,%cons (,%cons ,(cons %equal? p) ',(car p)) ; ok
     425                           (,%cons (,%cons ((,%== ,(car p)) ,(cadr p)) ',(car p))
     426                                   ,%tests))
     427                   ))
     428              (chop pairs* 2))
     429       (,%let ((,%fails (,select-failures (,%reverse ,%tests))))
     430         (,%when ,verbose?
     431           (,%print "\nList of failed test expressions: "
     432                    (,%map ,%cdr ,%fails) "\n")
     433                    ;(,%apply ,%append (,%map ,%cdr ,%fails)))
     434                    )
     435         (,%if (,%null? ,%fails) #t #f)))))
     436 ))))
     437
     438(define (check-all-proc name . test-name-pairs) ; internal to check-all
     439  ; used internally in check-all, must be exported within check-all
     440  (let loop ((pairs (chop test-name-pairs 2)) (failures '()))
     441    (cond
     442      ((null? pairs)
     443       (print "In " name ":")
     444       (print "==="
     445              (make-string (string-length (symbol->string name)) #\=)
     446              "=")
     447       (print* "List of failed tests: "
     448              (map car (reverse failures)))
     449       (if (null? failures)
     450         (exit 0)
     451         (exit 1)))
     452      ((caar pairs)
     453       (loop (cdr pairs) failures))
     454      (else
     455        (loop (cdr pairs) (cons (cadar pairs) failures))))))
     456
     457;;; (check-all Name check-xpr ....)
     458;;; -------------------------------
     459;;; checks all check-expressions defined with define-checks
     460;;; producing a list of failures and exiting with 0 or 1
     461(define-syntax check-all
     462  (er-macro-transformer
     463    (lambda (form rename compare?)
     464      (let ((name (cadr form))
     465            (checks (cddr form))
     466            (%check-all-proc (rename 'check-all-proc))
     467            )
     468        `(,%check-all-proc ',name
     469                          ,@(apply append
     470                                   (map (lambda (t) `(,t ',t))
     471                                        checks)))))))
     472 ) ; simple-tests
     473
     474;(import simple-tests)
  • release/5/simple-tests/trunk/tests/run.scm

    r36308 r38279  
    1 (require-library simple-tests)
    21(import simple-tests)
     2
     3;;; old interface
    34
    45(define-test (bar n)
     
    1314  (positive? 3))
    1415
    15 (define-test (+?)
     16(define-test (++)
    1617  (= (+ 1 2) 3)
    1718  (= (+ 1 2 3) 6))
    1819
    19 (define-test (*?)
     20(define-test (**)
    2021  (= (* 1 2) 2)
    2122  (= (* 1 2 3) 6))
    2223
    23 (define-test (arithmetic?)
    24   (+?)
    25   (*?))
     24(define-test (arithmetic)
     25  (++)
     26  (**))
    2627
    2728(define-test (baz)
     
    3132
    3233
    33 (compound-test (simple-tests)
    34   (baz)
    35   (arithmetic?)
    36   (foo 1 2)
     34;(compound-test (simple-tests)
     35;  (baz)
     36;  (arithmetic?)
     37;  (foo 1 2)
     38;  )
     39
     40;;; new interface
     41
     42(define-checks (bar? verbose? n 5)
     43  (positive? n) #t
     44  (even? n) #f)
     45
     46(define-checks (+? verbose?)
     47  (+ 1 2) 3
     48  (+ 1 2 3) 6)
     49
     50(define-checks (*? verbose?)
     51  (* 1 2) 2
     52  (* 1 2 3) 6)
     53
     54(define-checks (arithmetic? verbose?)
     55  (+? #f) #t
     56  (*? #f) #t)
     57
     58(define-checks (baz? verbose?)
     59  (and? #t #t #t) #t
     60  (and?) #t
     61  (and? #t #f #t) #f)
     62
     63(define-checks (qux? verbose?)
     64  ((== "x") "y") #f
     65  ((== "x") "x") #t
     66  ((== baz?) baz?) #t
     67  ((== baz?) bar) #f
     68  ((== '()) '()) #t
     69  ((== 'x) 'y) #f
     70  ((== 'x) 'x) #t
     71  ((== #(0 1 2)) #(0 1 2)) #t
     72  ((== #(0 1 2)) '(0 1 2)) #f
    3773  )
     74
     75(check-all SIMPLE (bar? #t) (*? #t) (+? #t) (arithmetic? #t) (baz? #t)
     76           (qux? #t))
Note: See TracChangeset for help on using the changeset viewer.