Changeset 39580 in project


Ignore:
Timestamp:
02/06/21 17:30:14 (4 weeks ago)
Author:
juergen
Message:

simple-tests 3.0 with define-tester and test-all

Location:
release/5/simple-tests/tags/3.0
Files:
3 edited
1 copied

Legend:

Unmodified
Added
Removed

  • release/5/simple-tests/tags/3.0/simple-tests.egg

    r39512 r39580  
    44 (category testing)
    55 (license "BSD")
    6  (version "2.3.2")
     6 (version "3.0")
    77 (author "Juergen Lorenz")
    8  (components (extension simple-tests
    9                         (csc-options "-O3" "-d0"))))
     8 (component-options (csc-options "-O3" "-d1"))
     9 (components (extension simple-tests)))
     10

  • release/5/simple-tests/tags/3.0/simple-tests.scm

    r39512 r39580  
    1 
    2 ; Author: Juergen Lorenz
    3 ; ju (at) jugilo (dot) de
    4 ;
    5 ; Copyright (c) 2011-2021, Juergen Lorenz
     1; Copyright (c) 2013-2021 , Juergen Lorenz, ju (at) jugilo (dot) de
    62; All rights reserved.
    73;
    … …  
    1612; notice, this list of conditions and the following disclaimer in the
    1713; documentation and/or other materials provided with the distribution.
    18 ;
    1914; Neither the name of the author nor the names of its contributors may be
    2015; used to endorse or promote products derived from this software without
    2116; specific prior written permission.
    22 ;
     17;  
    2318; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
    2419; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
    … …  
    3227; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    3328; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    34 ;
     29
     30
    3531
    3632#|[
    3733This is a simple Unit Test Framework inspired by Peter Seibel's
    3834"Practical Common Lisp" together with some routines which might be
    39 useful for debugging.
    40 A second test interface is added with version 2.0
    41 ]|#
    42 
     35useful for debugging.  It underwent several changes in the maintenance
     36process, most of them are now marked deprecated but are still there in
     37favor of backwards compatibility.
     38
     39For the future, it's sufficient to use only the following six routines,
     40the parameter verbose? and the macros pe, ppp, check, make-tester and
     41test-all.
     42
     43pe, ppp and check are mostly used in the development phase, make-tester
     44and test-all are the actual test routines to go into tests/run.scm.
     45
     46A tester is a nullary predicate which produces a lot of information as
     47side-effects provided the parameter verbose? is true. These testers are
     48invoked in test-all.
     49
     50pe is a combination of pretty-print and expand enhanced with additional
     51text; ppp pretty-prints a list of expressions and its values, while
     52check does the same but accompanies these computed values with expected
     53ones, allowing for local variables in the checks.
     54]|#
    4355
    4456(module simple-tests (
    45   ; common
    46   simple-tests
     57  verbose?
     58  writeln
    4759  and?
    48   writeln
    4960  pe
     61  xpr:val
    5062  ppp
    5163  ppp*
     64  xpr:val*
    5265  ppp**
    53   xpr:val
    54   xpr:val*
     66  (define-test *failures* *locations*)
     67  (compound-test *failures* group-on-cdrs)
    5568  ==
    56   ; old interface
    57   define-test
    58   (compound-test group-on-cdrs)
    59   *locations*
    60   *failures*
    61   ; new interface
    6269  check
    6370  define-checks
    6471  do-checks
    65   (check-all check-all-proc)
     72  define-tester
     73  (test-all test-all-proc)
     74  (check-all test-all-proc)
     75  simple-tests
    6676  )
    6777
    68 (import scheme (chicken base) (chicken syntax) (chicken pretty-print))
     78(import scheme
     79        (only (chicken base)
     80              print case-lambda cut chop exit receive make-parameter)
     81        (only (chicken syntax) expand)
     82        (only (chicken module) import-for-syntax)
     83        (only (chicken pretty-print) pp)
     84        )
    6985
    7086(import-for-syntax (only (chicken base) chop))
    … …  
    7288;;;;;; Common interface ;;;;;;
    7389
    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 
     90#|[
     91(verbose? ..)
     92--- parameter ---
     93gets or sets the value of the parameter verbose?
     94]|#
     95(define verbose?
     96  (make-parameter #t
     97                  (lambda (x)
     98                    (if (not x)
     99                      x
     100                      #t))))
     101
     102#|[
     103(writeln xpr ...)
     104--- procedure ---
     105write analog of print, expressions separated by whitespace
     106]|#
    169107(define (writeln . args)
    170108  (for-each (lambda (a)
    … …  
    174112  (newline))
    175113
    176 ;;; (and? . xprs)
    177 ;;; -------------
    178 ;;; non-short-circuited and which executes all side-effects
     114#|[
     115(and? . xprs)
     116--- procedure ---
     117non-short-circuited and which executes all side-effects
     118]|#
    179119(define (and? . xprs)
    180120  (let ((result #t))
    … …  
    183123    result))
    184124
    185 ;;; (pe macro-code)
    186 ;;; ---------------
    187 ;;; composes pretty-print and expand
     125#|[
     126(pe macro-code)
     127--- macro ---
     128composes pretty-print and expand,
     129does nothing in compiled code.
     130]|#
    188131(define (pe macro-code)
    189   (pp (expand macro-code)))
    190 
    191 #|[
    192 The following macro, xpr:val, pretty-prints the literal representation
    193 of each of its arguments as well as their respective values.  The call
    194 to eval-when guarantees, that the whole expression does nothing in
    195 compiled code.
    196 ]|#
    197 
    198 ;;; (xpr:val xpr ...)
    199 ;;; -----------------
    200 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    201 ;;; value.
     132  (cond-expand
     133    ((not compiling)
     134     (newline)
     135     (print "Macro expansion:")
     136     (print "----------------")
     137     (pp macro-code)
     138     (print "->")
     139     (pp (expand macro-code))
     140     (print "----------------")
     141     (newline))
     142    (else)))
     143
     144;;; The following macro, xpr:val, pretty-prints the literal representation
     145;;; of each of its arguments as well as their respective values.  The call
     146;;; to eval-when guarantees, that the whole expression does nothing in
     147;;; compiled code.
     148
     149#|[
     150(xpr:val xpr ...)
     151--- macro ---
     152Deprecated!
     153Print each xpr quoted in a headline and pretty-print xpr's computed
     154value.
     155]|#
    202156(define-syntax xpr:val
    203157  (syntax-rules ()
    … …  
    212166       (else)))))
    213167
    214 ;;; (ppp xpr ...)
    215 ;;; -------------
    216 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    217 ;;; value. Alias to xpr:val.
     168#|[
     169(ppp xpr ...)
     170--- macro ---
     171print each xpr quoted in a headline and pretty-print xpr's computed
     172value. Alias to xpr:val.
     173]|#
    218174(define-syntax ppp
    219175  (syntax-rules ()
    220176    ((_ xpr ...)
    221      (xpr:val xpr ...))))
     177     (cond-expand
     178       ((not compiling)
     179        (begin (print "Computing " 'xpr " ...")
     180               (pp xpr)
     181               )
     182        ...
     183        )
     184       (else)))))
    222185
    223186(define-syntax help-ppp* ; internal
    … …  
    235198    ))
    236199;
    237 ;;;; (ppp* {xpr ypr} ...)
    238 ;;; --------------------
    239 ;;; print each xpr quoted in a headline and pretty-print xpr's computed
    240 ;;; and expected value, ypr.
     200#|[
     201(ppp* {xpr ypr} ...)
     202--- macro ---
     203Deprecated!
     204Print each xpr quoted in a headline and pretty-print xpr's computed
     205and expected value, ypr.
     206]|#
    241207(define-syntax ppp*
    242208  (syntax-rules ()
    … …  
    247213       (else)))))
    248214
    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*
     215#|[
     216(xpr:val* {xpr ypr} ...)
     217--- macro ---
     218Deprecated!
     219Print each xpr quoted in a headline and pretty-print xpr's computed
     220and expected value, ypr.
     221Alias to ppp*
     222]|#
     223(define-syntax xpr:val* ; deprecated
    255224  (syntax-rules ()
    256225    ((_ . pairs)
    257226     (ppp* . pairs))))
    258227
    259 ;;; (ppp** ((var val) ...) xpr ypr . other xpr-ypr-pairs)
    260 ;;; -----------------------------------------------------
    261 ;;; ppp* wrapped into a let
     228#|[
     229(ppp** ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
     230--- macro ---
     231Deprecated!
     232ppp* wrapped into a let
     233]|#
    262234(define-syntax ppp**
    263235  (syntax-rules ()
    … …  
    268240;;;;;;;; old interface ;;;;;;;;;
    269241
    270 ;; helper macro because I don't want to export it
    271 (define-syntax disp
     242(define-syntax disp ; internal
    272243  (syntax-rules ()
    273244    ((_)
    … …  
    277248;;; ------------------------
    278249;;; reports succuss or failure of form and updates failures if necessary
    279 (define-syntax report-result
     250(define-syntax report-result ; internal
    280251  (syntax-rules ()
    281252    ((_ loc form)
    … …  
    299270         #f)))))
    300271
    301 ;;; (check-em . forms) ;; internal
     272;;; (check-em . forms)
    302273;;; ------------------
    303274;;; report result of all forms
    304 (define-syntax check-em
     275(define-syntax check-em ; internal
    305276  (syntax-rules ()
    306277    ((_ form ...)
    … …  
    309280             ...)))))
    310281
    311 ;; internal helper
    312 (define-syntax show-args
     282(define-syntax show-args ; internal
    313283 (syntax-rules ()
    314284   ((_ (name arg ...))
    … …  
    316286   ((_ arg) arg)))
    317287
    318 ;;; (define-test (name . parameters) form . forms)
    319 ;;; ----------------------------------------------
    320 ;;; creates a test function
     288#|[
     289(define-test (name . parameters) form . forms)
     290--- macro *locations* *failures* ---
     291Deprecated!
     292Creates a test function
     293]|#
    321294(define-syntax define-test
    322295  (syntax-rules ()
    … …  
    329302         ((check-em form . forms) *locations*))))))
    330303
    331 ;;; (compound-test (name) test . tests)
    332 ;;; -----------------------------------
    333 ;;; invokes all tests and reports a summary
     304#|[
     305(compound-test (name) test . tests)
     306--- macro group-on-cdrs *failures* ---
     307Deprecated!
     308Invokes all tests and reports a summary
     309]|#
    334310(define-syntax compound-test
    335311  (syntax-rules ()
    336312    ((_ (name) test0 test1 ...)
    337313     (begin
     314  (writeln "XXX" 'test0 test0 test1 ...) ;;;;;
     315  (writeln "YYY" (and? test0 test1 ...)) ;;;;;
    338316       (print "\nTesting " 'name " ...")
    339317       (print "----------------------------")
    … …  
    362340             (exit 1))))))))
    363341
    364 ;;; internal helper from bindings
     342;;; internal helper
    365343(define (filter ok? lst)
    366344  (let loop ((lst lst) (yes '()) (no '()))
    … …  
    383361        (loop no (cons yes result))))))
    384362
     363;;;*failures*
     364;;; ----------
     365;;; Deprecated!
     366;;; global variable
     367(define *failures* '())
     368
    385369;;; *locations*
    386370;;; -----------
    387 ;;; dynamic variable
     371;;; Deprecated!
     372;;; global variable
    388373(define *locations* '())
    389 
    390 ;;; *failures*
    391 ;;; ----------
    392 ;;; global variable collecting failure information
    393 (define *failures* '())
    394374
    395375;;;;;;; new interface ;;;;;;;;;;;
    … …  
    401381;  (string=? (symbol->string x) (symbol->string y)))
    402382
    403 ;;; (==)
    404 ;;; (== x)
    405 ;;; (== type? type-equal?)
    406 ;;; ----------------------
    407 ;;; generic type equality as curried procedure
     383#|[
     384(==)
     385(== x)
     386(== type? type-equal?)
     387--- procedure ---
     388Deprecated!
     389Generic type equality as curried procedure
     390]|#
    408391(define ==
    409392  (let* ((pairs (list (cons pair? (curry equal?))
    … …  
    438421;;; (check* ((var val) ...) xpr ypr . xpr-yprs) ;; internal
    439422;;; --------------------------------------------------------------
     423(define-syntax check* ; internal
     424  (ir-macro-transformer
     425    (lambda (form inject compare?)
     426      (let ((var-vals (cadr form))
     427            (xpr-yprs (cddr form))
     428            (select-failures
     429              (lambda (pairs)
     430                (let loop ((pairs pairs))
     431                  (cond
     432                    ((null? pairs) '())
     433                    ((caar pairs) (loop (cdr pairs)))
     434                    (else
     435                     (cons (car pairs) (loop (cdr pairs))))))))
     436            )
     437`(lambda (verbose?)
     438   (letrec ,var-vals
     439          (let ((tests '()))
     440            ,@(map (lambda (p)
     441                     `(begin
     442                        (let ((x ,(car p)))
     443                           ; protect against functions changing state
     444                          (when verbose?
     445                            (print "testing " ',(car p) " ...")
     446                            (print* "computed: ") (writeln x)
     447                            (print* "expected: ") (writeln ,(cadr p))
     448                            )
     449                          (set! tests
     450                                (cons (cons ((cut equal? <> x) ,(cadr p))
     451                                            ',(car p))
     452                                      tests)))
     453                                ;(cons (cons ((== x) ,(cadr p)) ',(car p))
     454                                ;            tests)))
     455                          ))
     456                   (chop xpr-yprs 2))
     457            (let ((fails (,select-failures (reverse tests))))
     458              (when verbose?
     459                (print "Failed test expressions:")
     460                (print "------------------------")
     461                (if (null? fails)
     462                  (print "none")
     463                  (for-each print (map cdr fails))))
     464              (if (null? fails) #t #f)))))
     465 ))))
    440466;(define-syntax check*
    441467;  (er-macro-transformer
    … …  
    495521;              (,%if (,%null? ,%fails) #t #f)))))
    496522; ))))
    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    (letrec ,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 "Failed test expressions:")
    531                 (print "------------------------")
    532                 (if (null? fails)
    533                   (print "none")
    534                   (for-each print (map cdr fails))))
    535               (if (null? fails) #t #f)))))
    536  ))))
    537 ;;; (check ((var val) ...) xpr ypr . xpr-yprs)
    538 ;;; ------------------------------------------
    539 ;;; compare xpr and ypr .... in sequence with ==
    540 ;;; in the environment defined by var val ...
     523#|[
     524(check ((var val) ...) xpr ypr . xpr-yprs)
     525--- macro ---
     526Compare xpr and ypr .... in sequence with equal?
     527in the environment defined by var val ...
     528]|#
    541529(define-syntax check
    542530  (syntax-rules ()
    … …  
    544532     ((check* ((var val) ...) xpr ypr . xpr-yprs) #t))))
    545533
    546 ;;; (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
    547 ;;; --------------------------------------------------------------
    548 ;;; returns a unary predicate, name?, comparing xpr with ypr ....
    549 ;;; and using var val ... within this checks,
    550 ;;; verbose? controls the reported summary.
     534#|[
     535(define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
     536--- macro ---
     537Deprecated!
     538Returns a unary predicate, name?, comparing xpr with ypr ....
     539and using var val ... within this checks,
     540verbose? controls the reported summary.
     541]|#
    551542(define-syntax define-checks
    552543  (ir-macro-transformer
    … …  
    572563               ,@xpr-yprs) ,verbose?)))))))))
    573564
    574 ;;; (do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
    575 ;;; ---------------------------------------------------------------
    576 ;;; returns a unary predicate, name?, comparing xpr with ypr ....
    577 ;;; and using var val ... within this checks,
    578 ;;; alias to define-checks
     565#|[
     566(do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
     567--- macro ---
     568Deprecated!
     569Returns a unary predicate, name?, comparing xpr with ypr ....
     570and using var val ... within this checks,
     571alias to define-checks
     572]|#
    579573(define-syntax do-checks
    580574  (syntax-rules ()
    … …  
    583577       xpr ypr .  xpr-ypr-pairs))))
    584578
    585 (define (check-all-proc name . test-name-pairs) ; internal to check-all
    586   ; used internally in check-all, must be exported within check-all
     579#|[
     580(define-tester (name? . var-vals) xpr ypr . xpr-yprs)
     581--- macro ---
     582Returns a thunk predicate, name?, comparing xpr with ypr ....
     583and using var val ... within this tests.
     584The parameter verbose? controls the reported summary, i. e.
     585the side effects.
     586]|#
     587(define-syntax define-tester
     588  (ir-macro-transformer
     589    (lambda (form inject compare?)
     590      (let ((header (cadr form))
     591            (xpr-yprs (cddr form)))
     592        (let ((name (car header))
     593              (var-vals (cdr header)))
     594    `(define (,name)
     595       (when (verbose?)
     596         (print "\nIn " ',name ":")
     597         (print* "==="
     598                 (make-string (string-length
     599                                (symbol->string ',name)) #\=)
     600                 "=\n")
     601         )
     602         ((check* ,(chop var-vals 2) ,@xpr-yprs) (verbose?))))))))
     603
     604(define (test-all-proc name . test-name-pairs)
     605  ; used internally in test-all, must be exported within test-all
    587606  (let loop ((pairs (chop test-name-pairs 2)) (failures '()))
    588607    (cond
    … …  
    604623        (loop (cdr pairs) (cons (cadar pairs) failures))))))
    605624
    606 ;;; (check-all Name check-xpr ....)
    607 ;;; -------------------------------
    608 ;;; checks all check-expressions defined with define-checks
    609 ;;; producing a list of failures and exiting with 0 or 1
     625#|[
     626(test-all Name tester ....)
     627--- macro test-all-proc ---
     628invokes all testers defined with define-tester
     629producing a list of failures and exiting with 0 or 1
     630]|#
     631(define-syntax test-all
     632  (er-macro-transformer
     633    (lambda (form rename compare?)
     634      (let ((name (cadr form))
     635            (tests (cddr form))
     636            (%test-all-proc (rename 'test-all-proc))
     637            (%list (rename 'list))
     638            )
     639        `(,%test-all-proc ',name
     640                          ,@(apply append
     641                                   (map (lambda (t) `((,t) '(,t)))
     642                                        tests)))))))
     643
     644#|[
     645(check-all Name check-xpr ....)
     646--- macro test-all-proc ---
     647Deprecated!
     648checks all check-expressions defined with define-checks
     649producing a list of failures and exiting with 0 or 1
     650]|#
    610651(define-syntax check-all
    611652  (er-macro-transformer
    … …  
    613654      (let ((name (cadr form))
    614655            (checks (cddr form))
    615             (%check-all-proc (rename 'check-all-proc))
     656            (%test-all-proc (rename 'test-all-proc))
    616657            )
    617         `(,%check-all-proc ',name
     658        `(,%test-all-proc ',name
    618659                          ,@(apply append
    619660                                   (map (lambda (t) `(,t ',t))
    620661                                        checks)))))))
    621  ) ; simple-tests
    622 
    623 ;(import simple-tests)
    624 ;
    625 ;(pe '(check ((lst '(0 1 2)))
    626 ;        (car lst)
    627 ;        0
    628 ;        (cdr lst)
    629 ;        '(1 2)))
    630 ;
    631 ;(check ((lst '(0 1 2)))
    632 ;        (car lst)
    633 ;        0
    634 ;        (cdr lst)
    635 ;        '(0 1 2))
    636 ;
    637 ;(pe '(define-checks (foo verbose? lst '(0 1 2))
    638 ;        (car lst)
    639 ;        0
    640 ;        (cdr lst)
    641 ;        '(1 2)))
    642 ;(define-checks (foo verbose? lst '(0 1 2))
    643 ;        (car lst)
    644 ;        0
    645 ;        (cdr lst)
    646 ;        '(1 2 3))
    647 ;(foo #t)
    648 ;(ppp (foo #f))
     662
     663#|[
     664(simple-tests)
     665(simple-tests sym)
     666--- procedure ---
     667documentation procedure
     668]|#
     669(define simple-tests
     670  (let (
     671    (alist '(
     672      (verbose?
     673        parameter:
     674        (verbose? ..)
     675        "gets or sets the value of the parameter verbose?"
     676        )
     677      (writeln
     678        procedure:
     679        (writeln xpr ...)
     680        "write analog of print, expressions separated by whitespace"
     681        )
     682      (and?
     683        procedure:
     684        (and? . xprs)
     685        "non-short-circuited and which executes all side-effects"
     686        )
     687      (pe
     688        macro:
     689        (pe macro-code)
     690        "composes pretty-print and expand,"
     691        "does nothing in compiled code."
     692        )
     693      (xpr:val
     694        macro:
     695        (xpr:val xpr ...)
     696        "Deprecated!"
     697        "Print each xpr quoted in a headline and pretty-print xpr's computed"
     698        "value."
     699        )
     700      (ppp
     701        macro:
     702        (ppp xpr ...)
     703        "print each xpr quoted in a headline and pretty-print xpr's computed"
     704        "value. Alias to xpr:val."
     705        )
     706      (ppp*
     707        macro:
     708        (ppp* {xpr ypr} ...)
     709        "Deprecated!"
     710        "Print each xpr quoted in a headline and pretty-print xpr's computed"
     711        "and expected value, ypr."
     712        )
     713      (xpr:val*
     714        macro:
     715        (xpr:val* {xpr ypr} ...)
     716        "Deprecated!"
     717        "Print each xpr quoted in a headline and pretty-print xpr's computed"
     718        "and expected value, ypr."
     719        "Alias to ppp*"
     720        )
     721      (ppp**
     722        macro:
     723        (ppp** ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
     724        "Deprecated!"
     725        "ppp* wrapped into a let"
     726        )
     727      (define-test
     728        macro:
     729        (define-test (name . parameters) form . forms)
     730        "Deprecated!"
     731        "Creates a test function"
     732        )
     733      (compound-test
     734        macro:
     735        (compound-test (name) test . tests)
     736        "Deprecated!"
     737        "Invokes all tests and reports a summary"
     738        )
     739      (==
     740        procedure:
     741        (==)
     742        (== x)
     743        (== type? type-equal?)
     744        "Deprecated!"
     745        "Generic type equality as curried procedure"
     746        )
     747      (check
     748        macro:
     749        (check ((var val) ...) xpr ypr . xpr-yprs)
     750        "Compare xpr and ypr .... in sequence with equal?"
     751        "in the environment defined by var val ..."
     752        )
     753      (define-checks
     754        macro:
     755        (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
     756        "Deprecated!"
     757        "Returns a unary predicate, name?, comparing xpr with ypr ...."
     758        "and using var val ... within this checks,"
     759        "verbose? controls the reported summary."
     760        )
     761      (do-checks
     762        macro:
     763        (do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
     764        "Deprecated!"
     765        "Returns a unary predicate, name?, comparing xpr with ypr ...."
     766        "and using var val ... within this checks,"
     767        "alias to define-checks"
     768        )
     769      (define-tester
     770        macro:
     771        (define-tester (name? . var-vals) xpr ypr . xpr-yprs)
     772        "Returns a thunk predicate, name?, comparing xpr with ypr ...."
     773        "and using var val ... within this tests."
     774        "The parameter verbose? controls the reported summary, i. e."
     775        "the side effects."
     776        )
     777      (test-all
     778        macro:
     779        (test-all Name tester ....)
     780        "invokes all testers defined with define-tester"
     781        "producing a list of failures and exiting with 0 or 1"
     782        )
     783      (check-all
     784        macro:
     785        (check-all Name check-xpr ....)
     786        "Deprecated!"
     787        "checks all check-expressions defined with define-checks"
     788        "producing a list of failures and exiting with 0 or 1"
     789        )
     790      (simple-tests
     791        procedure:
     792        (simple-tests)
     793        (simple-tests sym)
     794        "with sym: documentation of exported symbol"
     795        "without sym: list of exported symbols"
     796        )
     797        ))
     798      )
     799      (case-lambda
     800        (() (map car alist))
     801        ((sym)
     802         (let ((pair (assq sym alist)))
     803           (if pair
     804             (for-each print (cdr pair))
     805             (print "Choose one of " (map car alist))))))))
     806)

  • release/5/simple-tests/tags/3.0/tests/run.scm

    r39187 r39580  
    11(import simple-tests)
    22
    3 ;;; old interface
    4 
    5 (define-test (bar n)
    6   (positive? n)
    7   (even? n))
    8 
    9 (define-test (foo x y)
    10   (< x y)
    11   "COMMENT"
    12   (bar 4)
    13   (odd? 3)
    14   (positive? 3))
    15 
    16 (define-test (++)
    17   (= (+ 1 2) 3)
    18   (= (+ 1 2 3) 6))
    19 
    20 (define-test (**)
    21   (= (* 1 2) 2)
    22   (= (* 1 2 3) 6))
    23 
    24 (define-test (arithmetic)
    25   (++)
    26   (**))
    27 
    28 (define-test (baz)
    29   (and? #t #t #t)
    30   (and?)
    31   (not (and? #t #f #t)))
    32 
    33 
    34 ;(compound-test (simple-tests)
    35 ;  (baz)
    36 ;  (arithmetic?)
    37 ;  (foo 1 2)
    38 ;  )
    39 
    40 ;;; new interface
     3(import (only (chicken base) parameterize print case-lambda))
    414
    425(newline)
    43 (print "check")
    44 (print "=====")
    45 (check ((lst '(0 1 2 3)))
    46   lst
    47   '(0 1 2 3)
    48   (car lst)
    49   0
    50   (cadr lst)
    51   1
    52   (cddr lst)
    53   '(2 3)
    54   )
    556
    56 ;;; define-checks is an alias to do-checks
    57 (do-checks (bar? verbose? n 5)
    58   (positive? n) #t
    59   (even? n) #f)
     7(define-test (bar n) (positive? n) (even? n))
    608
    61 (define-checks (+? verbose?)
    62   (+ 1 2) 3
    63   (+ 1 2 3) 6)
     9(bar 5)
    6410
    65 (define-checks (*? verbose?)
    66   (* 1 2) 2
    67   (* 1 2 3) 6)
     11(define-test (foo x y) (< x y) "COMMENT" (bar 4) (odd? 3) (positive? 3))
    6812
    69 (define-checks (arithmetic? verbose?)
    70   (+? #f) #t
    71   (*? #f) #t)
     13(foo 1 2)
    7214
    73 (do-checks (baz? verbose?)
    74   (and? #t #t #t) #t
    75   (and?) #t
    76   (and? #t #f #t) #f)
     15(define-test (++) (= (+ 1 2) 3) (= (+ 1 2 3) 6))
    7716
    78 (define-checks (qux? verbose?)
    79   ((== "x") "y") #f
    80   ((== "x") "x") #t
    81   ((== baz?) baz?) #t
    82   ((== baz?) bar) #f
    83   ((== '()) '()) #t
    84   ((== 'x) 'y) #f
    85   ((== 'x) 'x) #t
    86   ((== #(0 1 2)) #(0 1 2)) #t
    87   ((== #(0 1 2)) '(0 1 2)) #f
    88   )
     17(++)
     18
     19(define-test (**) (= (* 1 2) 2) (= (* 1 2 3) 6))
     20
     21(**)
     22
     23(define-test (arithmetic) (++) (**))
     24
     25(arithmetic)
     26
     27(define-test (baz) (and? #t #t #t) (and?) (not (and? #t #f #t)))
     28
     29(baz)
     30
     31'(compound-test (OLD) (bar 5) (foo 1 2) (++) (**) (arithmetic) (baz))
     32
     33(newline)
     34
     35(do-checks (bar? verbose? n 5) (positive? n) #t (even? n) #f)
     36
     37(bar?)
     38
     39(define-checks (+? verbose?) (+ 1 2) 3 (+ 1 2 3) 6)
     40
     41(+?)
     42
     43(define-checks (*? verbose?) (* 1 2) 2 (* 1 2 3) 6)
     44
     45(*?)
     46
     47(define-checks (arithmetic? verbose?) (+? #f) #t (*? #f) #t)
     48
     49(arithmetic?)
     50
     51(do-checks (baz? verbose?) (and? #t #t #t) #t (and?) #t (and? #t #f #t) #f)
     52
     53(baz?)
     54
     55(define-checks
     56  (qux? verbose?)
     57  ((== "x") "y")
     58  #f
     59  ((== "x") "x")
     60  #t
     61  ((== baz?) baz?)
     62  #t
     63  ((== baz?) bar?)
     64  #f
     65  ((== '()) '())
     66  #t
     67  ((== 'x) 'y)
     68  #f
     69  ((== 'x) 'x)
     70  #t
     71  ((== #(0 1 2)) #(0 1 2))
     72  #t
     73  ((== #(0 1 2)) '(0 1 2))
     74  #f)
     75
     76(qux?)
    8977
    9078(define counter
    91   (let ((n 0))
    92     (lambda ()
    93       (set! n (add1 n))
    94       n)))
     79  (let ((n 0)) (case-lambda (() (set! n (add1 n)) n) ((k) (set! n k) n))))
    9580
    96 (define-checks (counter? verbose?)
    97   (counter) 1
    98   (counter) 2
    99   (counter) 3
    100   (counter) 4
     81(define-checks
     82  (counter? verbose?)
     83  (counter 0)
     84  0
     85  (counter)
     86  1
     87  (counter)
     88  2
     89  (counter)
     90  3
     91  (counter)
     92  4)
     93
     94(counter?)
     95
     96'(check-all NEW (bar?) (*?) (+?) (arithmetic?) (baz?) (qux?) (counter?))
     97
     98(define-tester (Bar? n 5) (positive? n) #t (even? n) #f)
     99
     100(define-tester (Plus?) (+ 1 2) 3 (+ 1 2 3) 6)
     101
     102(define-tester (Times?) (* 1 2) 2 (* 1 2 3) 6)
     103
     104(define-tester
     105  (Arithmetic?)
     106  (parameterize ((verbose? #f)) (Plus?))
     107  #t
     108  (parameterize ((verbose? #f)) (Times?))
     109  #t)
     110
     111(define Counter
     112  (let ((n 0)) (case-lambda (() (set! n (add1 n)) n) ((k) (set! n k) n))))
     113
     114(define-tester
     115  (Counter?)
     116  (Counter 0)
     117  0
     118  (Counter)
     119  1
     120  (Counter)
     121  2
     122  (Counter)
     123  3
     124  (Counter)
     125  4
     126  (Counter 0)
     127  0)
     128
     129'(test-all SIMPLE-TESTS Bar? Times? Plus? Arithmetic? Counter?)
     130
     131(test-all SIMPLE-TESTS
     132  Bar?
     133  Plus?
     134  Times?
     135  Arithmetic?
     136  Counter?
    101137  )
    102 
    103 
    104 (check-all SIMPLE (bar?) (*?) (+?) (arithmetic?) (baz?) (qux?)
    105            (counter?))
Note: See TracChangeset for help on using the changeset viewer.