Changeset 39594 in project


Ignore:
Timestamp:
02/13/21 17:38:41 (3 weeks ago)
Author:
juergen
Message:

checks 1.4 with checkers

Location:
release/5/checks
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/5/checks/tags/1.4/checks.egg

    r38301 r39594  
    66 (dependencies simple-exceptions)
    77 (author "Juergen Lorenz")
    8  (version "1.3.1")
     8 (version "1.4")
    99 (components (extension checks (csc-options "-d0" "-O3"))))
    1010
  • release/5/checks/tags/1.4/checks.scm

    r37483 r39594  
    1 #|[
    2 Author: Juergen Lorenz
    3 ju (at) jugilo (dot) de
    4 
    5 Copyright (c) 2014-2019, 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 
    37 (module checks (checks assert*
    38                 <<% << >>% >> <<<% <<< >>>% >>>
    39                  true? false? named-lambda)
    40 
    41   (import scheme (only (chicken base) assert print case-lambda error)
     1; Copyright (c) 2014-2021, Juergen Lorenz
     2; All rights reserved.
     3;
     4; Redistribution and use in source and binary forms, with or without
     5; modification, are permitted provided that the following conditions are
     6; met:
     7;
     8; Redistributions of source code must retain the above copyright
     9; notice, this list of conditions and the following disclaimer.
     10;
     11; Redistributions in binary form must reproduce the above copyright
     12; notice, this list of conditions and the following disclaimer in the
     13; documentation and/or other materials provided with the distribution.
     14;
     15; Neither the name of the author nor the names of its contributors may be
     16; used to endorse or promote products derived from this software without
     17; specific prior written permission.
     18;
     19; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
     20; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
     21; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
     22; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
     23; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
     24; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
     25; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
     26; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
     27; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
     28; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
     29; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     30;
     31
     32
     33#|[
     34Pre- and postconditions made easy
     35---------------------------------
     36This egg implements some routines, which are outsourced from
     37simple-exceptions. In particular macros << and >>, which accept an
     38argument or result, checks it against zero or more predicates and
     39returns it in case of success unchanged. Otherwise it prints a
     40meaningful error message, showing i.a. the offending predicate and the
     41argument's or result's name. Some are implemented as macros instead of
     42procedures, because I didn't want an extra parameter with the argument's
     43or result's name.
     44Procedure versions of those macros are given as well.
     45In reimplementing those routines, I changed the syntax a bit, so be
     46careful, if you used the equally named routines from simple-expressions.
     47
     48The precondition and postcondition checks are denoted with some
     49consecutive symbols < and > respectively. There are macro and procedure
     50versions, the latter denoted with a trailing % and needing an additional
     51parameter, the name of the value to be checked. All those routines work
     52the same, they differ only in the error message, they produce in case
     53some predicate returns #f. The routines named with three symbols < or >
     54differ from those with two only by an additional parameter naming the
     55location of the checks.
     56]|#
     57
     58(module checks (
     59  checker
     60  checker?
     61  assert*
     62  named-lambda
     63  <<<
     64  <<
     65  >>>
     66  >>
     67  <<<%
     68  <<%
     69  >>>%
     70  >>%
     71  true?
     72  false?
     73  checks
     74  )
     75
     76  (import scheme
     77          (only (chicken base) assert gensym print case-lambda error)
     78          (only (chicken condition) condition-case)
    4279          (only simple-exceptions raise assert-exception
    4380                argument-exception result-exception))
    4481
    45 ;;; (assert* loc xpr . xprs)
    46 ;;; ------------------------
    47 ;;; checks, if its arguments xpr . xprs are not #f.
     82
     83#|[
     84(checker sym .. ok? ....)
     85--- procedure ---
     86creates a checker routine, i.e. a unuary procedure, which returns its
     87argument unchanged, provided it passes all ok? tests. If not, an error
     88is generated with location sym, whose default is 'checker.
     89]|#
     90(define checker 'checker)
     91
     92#|[
     93(checker? xpr)
     94--- procedure ---
     95type predicate.
     96]|#
     97(define checker? 'checker?)
     98
     99(let ((in (gensym 'in)) (out (gensym 'out)))
     100
     101  (set! checker
     102    (lambda args
     103      (cond
     104        ((null? args)
     105         (error 'checker "correct args are" '(sym .. ok? ....)))
     106        ((and (null? (cdr args)) (symbol? (car args)))
     107         (error 'checker "correct args are" '(sym .. ok? ....)))
     108        (else
     109          (let ((location (if (symbol? (car args))
     110                            (car args)
     111                            'checker))
     112                (predicates (if (symbol? (car args))
     113                              (cdr args)
     114                              args)))
     115            (lambda (arg)
     116              (if (and (symbol? arg) (eq? arg in))
     117                out
     118                (let loop ((preds predicates))
     119                  (cond
     120                    ((null? preds) arg)
     121                    (((car preds) arg)
     122                     (loop (cdr preds)))
     123                    (else
     124                      (error location
     125                             "predicate failed"
     126                             (car preds) arg)))))))))))
     127
     128  (set! checker?
     129    (lambda (xpr)
     130      (and (procedure? xpr)
     131           (condition-case (eq? (xpr in) out)
     132             ((exn) #f)))))
     133  )
     134
     135#|[
     136(assert* loc xpr . xprs)
     137--- macro ---
     138checks, if its arguments xpr . xprs are not #f.
     139]|#
    48140(define-syntax assert*
    49141  (syntax-rules ()
     
    55147    ))
    56148
     149#|[
     150(named-lambda (name . args) xpr . xprs)
     151--- macro ---
     152can be used in place of lambda,
     153possibly improving error messages
     154]|#
    57155(define-syntax named-lambda
    58156  (syntax-rules ()
     
    63161;;;;;;;;;;; the macro versions below avoid the naming of arg or result
    64162
    65 ;;; (<<< loc arg arg? ...)
    66 ;;; ----------------------
    67 ;;; check a procedure argument, arg, against each predicate arg? ...
    68 ;;; in sequence and pass it to the procedure in case of success.
    69 ;;; loc names the location in the error message.
     163#|[
     164(<<< loc arg arg? ...)
     165--- macro ---
     166Precondition test.
     167Check a procedure argument, arg, against each predicate arg? ...
     168in sequence and pass it to the procedure in case of success.
     169loc names the location in the error message.
     170]|#
    70171(define-syntax <<<
    71172  (syntax-rules ()
     
    84185    ))
    85186
    86 ;;; (<< arg arg? ...)
    87 ;;; -----------------
    88 ;;; check a procedure argument, arg, against each predicate arg? ...
    89 ;;; in sequence and pass it to the procedure in case of success.
     187#|[
     188(<< arg arg? ...)
     189--- macro ---
     190Precondition test.
     191Check a procedure argument, arg, against each predicate arg? ...
     192in sequence and pass it to the procedure in case of success.
     193]|#
    90194(define-syntax <<
    91195  (syntax-rules ()
     
    93197     (<<< '<< arg ok? ...))))
    94198
    95 ;;; (>>> loc result result? ...)
    96 ;;; ----------------------------
    97 ;;; check a return value of a function, result, against each predicate
    98 ;;; result? ...in sequence and return it in case of success.
    99 ;;; loc names the location in case of error.
     199#|[
     200(>>> loc result result? ...)
     201--- macro ---
     202Postcondition test.
     203Check a return value of a function, result, against each predicate
     204result? ...in sequence and return it in case of success.
     205loc names the location in case of error.
     206]|#
    100207(define-syntax >>>
    101208  (syntax-rules ()
     
    114221    ))
    115222
    116 ;;; (>> result result? ...)
    117 ;;; -----------------------
    118 ;;; check a return value of a function, result, against each predicate
    119 ;;; result? ...in sequence and return it in case of success.
     223#|[
     224(>> result result? ...)
     225--- macro ---
     226Postcondition test.
     227Check a return value of a function, result, against each predicate
     228result? ...in sequence and return it in case of success.
     229]|#
    120230(define-syntax >>
    121231  (syntax-rules ()
     
    125235;;;;;; procedure versions need to name arg and result respectively
    126236
     237#|[
     238(<<<% loc arg-name arg . tests)
     239--- procedure ---
     240Precondition test.
     241Procedure version of <<<, arg needs to be named.
     242]|#
    127243(define (<<<% loc arg-name arg . tests)
    128244  (let loop ((tests tests))
     
    140256
    141257
     258#|[
     259(<<% arg-name arg . tests)
     260--- procedure ---
     261Precondition test.
     262Procedure version of <<, arg needs to be named.
     263]|#
    142264(define (<<% arg-name arg . tests)
    143265  (apply <<<% '<< arg-name arg tests))
    144266
     267#|[
     268(>>>% loc result-name result . tests)
     269--- procedure ---
     270Postcondition test.
     271Procedure version of >>>, result needs to be named.
     272]|#
    145273(define (>>>% loc result-name result . tests)
    146274  (let loop ((tests tests))
     
    157285
    158286
     287#|[
     288(>>% result-name result . tests)
     289--- procedure ---
     290Postcondition test.
     291Procedure version of <<, result needs to be named.
     292]|#
    159293(define (>>% result-name result . tests)
    160294  (apply >>>% '>> result-name result tests))
    161295
     296#|[
     297(true? xpr)
     298--- procedure ---
     299always true
     300]|#
    162301(define (true? xpr) #t)
     302
     303#|[
     304(false? xpr)
     305--- procedure ---
     306always false
     307]|#
    163308(define (false? xpr) #f)
    164309
    165 ;;; (named-lambda (name . args) xpr . xprs)
    166 ;;; -----------------------------------
    167 ;;; can replace anonymous procedures in << and >>
    168 ;;; to improve error messages
    169 ;;; (checks [sym])
    170 ;;; -------------------------
    171 ;;; documentation procedure
     310
     311#|[
     312(checks)
     313(checks sym)
     314--- procedure ---
     315documentation procedure
     316]|#
    172317(define checks
    173   (let ((als '(
    174     (checks
    175       procedure:
    176       (checks sym ..)
    177       "documentation procedure")
    178     (assert*
    179       macro:
    180       (assert* loc xpr ....)
    181       "checks, if its arguments xpr .... are  not #f")
    182     (named-lambda
    183       macro:
    184       (named-lambda (name . args) xpr . xprs)
    185       "can be used in place of lambda,"
    186       "possibly improving error messages")
    187     (<<<
    188       macro:
    189       (<<< loc arg arg? ...)
    190       "precondition test:"
    191       "check arg against each predicate arg? in sequence"
    192       "and return it in case of success."
    193       "Otherwise print an error message with the"
    194       "offending predicate at location loc.")
    195     (<<
    196       macro:
    197       (<<< arg arg? ...)
    198       "precondition test:"
    199       "check arg against each predicate arg? in sequence"
    200       "and return it in case of success."
    201       "Otherwise print an error message with the"
    202       "offending predicate")
    203     (>>>
    204       macro:
    205       (<<< loc result result? ...)
    206       "postcondition test:"
    207       "check result against each predicate result? in sequence"
    208       "and return it in case of success."
    209       "Otherwise print an error message with the"
    210       "offending predicate at location loc.")
    211     (>>
    212       macro:
    213       (<<< result result? ...)
    214       "postcondition test:"
    215       "check result against each predicate result? in sequence"
    216       "and return it in case of success."
    217       "Otherwise print an error message with the"
    218       "offending predicate.")
    219     (<<<%
    220       procedure:
    221       (<<<% loc name arg arg? ...)
    222       "precondition test:"
    223       "check arg against each predicate arg? in sequence"
    224       "and return it in case of success."
    225       "Otherwise print an error message with the"
    226       "offending predicate at location loc with arg-name name.")
    227     (<<%
    228       procedure:
    229       (<<% name arg arg? ...)
    230       "precondition test:"
    231       "check arg against each predicate arg? in sequence"
    232       "and return it in case of success."
    233       "Otherwise print an error message with the"
    234       "offending predicate and arg-name name")
    235     (>>>%
    236       procedure:
    237       (>>>% loc name result result? ...)
    238       "postcondition test:"
    239       "check result against each predicate result? in sequence"
    240       "and return it in case of success."
    241       "Otherwise print an error message with the"
    242       "offending predicate at location loc with result-name name.")
    243     (>>%
    244       procedure:
    245       (<<% name result result? ...)
    246       "postcondition test:"
    247       "check result against each predicate result? in sequence"
    248       "and return it in case of success."
    249       "Otherwise print an error message with the"
    250       "offending predicate and result-name name.")
    251     (true?
    252       procedure?
    253       (true? xpr)
    254       "returns always #t")
    255     (false?
    256       procedure?
    257       (false? xpr)
    258       "returns always #f")
    259     )))
    260     (case-lambda
    261       (()
    262        (map car als))
    263       ((sym)
    264        (let ((pair (assq sym als)))
    265          (if pair
    266            (for-each print (cdr pair))
    267            (error "Not in list"
    268                   sym
    269                   (map car als))))))))
    270 
    271   ) ; module checks
    272 
     318  (let (
     319    (alist '(
     320      (checker
     321        procedure:
     322        (checker sym .. ok? ....)
     323        "creates a checker routine, i.e. a unuary procedure, which returns its"
     324        "argument unchanged, provided it passes all ok? tests. If not, an error"
     325        "is generated with location sym, whose default is 'checker."
     326        )
     327      (checker?
     328        procedure:
     329        (checker? xpr)
     330        "type predicate."
     331        )
     332      (assert*
     333        macro:
     334        (assert* loc xpr . xprs)
     335        "checks, if its arguments xpr . xprs are not #f."
     336        )
     337      (named-lambda
     338        macro:
     339        (named-lambda (name . args) xpr . xprs)
     340        "can be used in place of lambda,"
     341        "possibly improving error messages"
     342        )
     343      (<<<
     344        macro:
     345        (<<< loc arg arg? ...)
     346        "Precondition test."
     347        "Check a procedure argument, arg, against each predicate arg? ..."
     348        "in sequence and pass it to the procedure in case of success."
     349        "loc names the location in the error message."
     350        )
     351      (<<
     352        macro:
     353        (<< arg arg? ...)
     354        "Precondition test."
     355        "Check a procedure argument, arg, against each predicate arg? ..."
     356        "in sequence and pass it to the procedure in case of success."
     357        )
     358      (>>>
     359        macro:
     360        (>>> loc result result? ...)
     361        "Postcondition test."
     362        "Check a return value of a function, result, against each predicate"
     363        "result? ...in sequence and return it in case of success."
     364        "loc names the location in case of error."
     365        )
     366      (>>
     367        macro:
     368        (>> result result? ...)
     369        "Postcondition test."
     370        "Check a return value of a function, result, against each predicate"
     371        "result? ...in sequence and return it in case of success."
     372        )
     373      (<<<%
     374        procedure:
     375        (<<<% loc arg-name arg . tests)
     376        "Precondition test."
     377        "Procedure version of <<<, arg needs to be named."
     378        )
     379      (<<%
     380        procedure:
     381        (<<% arg-name arg . tests)
     382        "Precondition test."
     383        "Procedure version of <<, arg needs to be named."
     384        )
     385      (>>>%
     386        procedure:
     387        (>>>% loc result-name result . tests)
     388        "Postcondition test."
     389        "Procedure version of >>>, result needs to be named."
     390        )
     391      (>>%
     392        procedure:
     393        (>>% result-name result . tests)
     394        "Postcondition test."
     395        "Procedure version of <<, result needs to be named."
     396        )
     397      (true?
     398        procedure:
     399        (true? xpr)
     400        "always true"
     401        )
     402      (false?
     403        procedure:
     404        (false? xpr)
     405        "always false"
     406        )
     407      (checks
     408        procedure:
     409        (checks)
     410        (checks sym)
     411        "with sym: documentation of exported symbol"
     412        "without sym: list of exported symbols"
     413        )
     414        ))
     415      )
     416      (case-lambda
     417        (() (map car alist))
     418        ((sym)
     419         (let ((pair (assq sym alist)))
     420           (if pair
     421             (for-each print (cdr pair))
     422             (print "Choose one of " (map car alist))))))))
     423)
  • release/5/checks/tags/1.4/tests/run.scm

    r37483 r39594  
    1 (import scheme (chicken base) checks simple-tests)
     1(import checks)
    22
    3 (define x 5)
     3(import scheme (chicken base) (chicken condition) simple-tests)
    44
    5 (define-test (checks?)
     5(define-tester
     6  (checkers?
     7    checkit
     8    (checker 'foo integer? positive?)
     9    checkme
     10    (checker integer? positive?))
     11  (checker? checkit)
     12  #t
     13  (checker? checkme)
     14  #t
     15  (checker? string?)
     16  #f
     17  (checkit 5)
     18  5
     19  (checkme 5)
     20  5
     21  (condition-case (checkme -1) ((exn) #f))
     22  #f
     23  (condition-case ((checker 'bar string?) 5) ((exn) #f))
     24  #f)
    625
     26(define-tester
     27  (checks? x 5)
    728  (assert* 'x (integer? x))
     29  #t
    830  (assert* 'x (integer? x) (odd? x))
    9   (not
    10     (condition-case
    11       (assert* 'x (integer? x) (even? x))
    12       ((exn assert) #f)))
     31  #t
     32  (condition-case (assert* 'x (integer? x) (even? x)) ((exn assert) #f))
     33  #f
     34  x
     35  5
     36  (>> x)
     37  5
     38  (<< x)
     39  5
     40  (>> x integer? odd?)
     41  5
     42  (>>% 'x x integer? odd?)
     43  5
     44  (<< x integer? odd?)
     45  5
     46  (<<% 'x x integer? odd?)
     47  5
     48  (<<< 'loc x integer? odd?)
     49  5
     50  (>>> 'loc x integer? odd?)
     51  5
     52  (<<<% 'loc 'x x integer? odd?)
     53  5
     54  (>>>% 'loc 'x x integer? odd?)
     55  5
     56  (condition-case (<<% 'x x integer? even?) ((exn argument) #f))
     57  #f
     58  (condition-case (<<<% 'loc 'x x integer? even?) ((exn argument) #f))
     59  #f
     60  (condition-case (>> x integer? even?) ((exn result) #f))
     61  #f
     62  (<< ((lambda () #f)) boolean?)
     63  #f
     64  ((named-lambda (! n) (if (zero? n) 1 (* n (! (- n 1))))) 5)
     65  120)
    1366
    14   (= (>> x) 5)
    15   (= (<< x) 5)
    16   (= (>> x integer? odd?) 5)
    17   (= (>>% 'x x integer? odd?) 5)
    18   (= (<< x integer? odd?) 5)
    19   (= (<<% 'x x integer? odd?) 5)
    20   (= (<<< 'loc x integer? odd?) 5)
    21   (= (>>> 'loc x integer? odd?) 5)
    22   (= (<<<% 'loc 'x x integer? odd?) 5)
    23   (= (>>>% 'loc 'x x integer? odd?) 5)
    24   (not (condition-case
    25          (<<% 'x x integer? even?)
    26          ((exn argument) #f)))
    27   (not (condition-case
    28          (<<<% 'loc 'x x integer? even?)
    29          ((exn argument) #f)))
    30   (not (condition-case
    31          (>> x integer? even?)
    32          ((exn result) #f)))
    33   (not (<< ((lambda () #f)) boolean?))
    34   (= ((named-lambda (! n)
    35         (if (zero? n)
    36           1
    37           (* n (! (- n 1)))))
    38       5)
    39      120)
     67(test-all CHECKS
     68  checkers?
     69  checks?
    4070  )
    41 
    42 (compound-test (CHECKS)
    43   (checks?)
    44   )
    45 
  • release/5/checks/trunk/checks.egg

    r38301 r39594  
    66 (dependencies simple-exceptions)
    77 (author "Juergen Lorenz")
    8  (version "1.3.1")
     8 (version "1.4")
    99 (components (extension checks (csc-options "-d0" "-O3"))))
    1010
  • release/5/checks/trunk/checks.scm

    r37483 r39594  
    1 #|[
    2 Author: Juergen Lorenz
    3 ju (at) jugilo (dot) de
    4 
    5 Copyright (c) 2014-2019, 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 
    37 (module checks (checks assert*
    38                 <<% << >>% >> <<<% <<< >>>% >>>
    39                  true? false? named-lambda)
    40 
    41   (import scheme (only (chicken base) assert print case-lambda error)
     1; Copyright (c) 2014-2021, Juergen Lorenz
     2; All rights reserved.
     3;
     4; Redistribution and use in source and binary forms, with or without
     5; modification, are permitted provided that the following conditions are
     6; met:
     7;
     8; Redistributions of source code must retain the above copyright
     9; notice, this list of conditions and the following disclaimer.
     10;
     11; Redistributions in binary form must reproduce the above copyright
     12; notice, this list of conditions and the following disclaimer in the
     13; documentation and/or other materials provided with the distribution.
     14;
     15; Neither the name of the author nor the names of its contributors may be
     16; used to endorse or promote products derived from this software without
     17; specific prior written permission.
     18;
     19; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
     20; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
     21; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
     22; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
     23; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
     24; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
     25; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
     26; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
     27; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
     28; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
     29; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     30;
     31
     32
     33#|[
     34Pre- and postconditions made easy
     35---------------------------------
     36This egg implements some routines, which are outsourced from
     37simple-exceptions. In particular macros << and >>, which accept an
     38argument or result, checks it against zero or more predicates and
     39returns it in case of success unchanged. Otherwise it prints a
     40meaningful error message, showing i.a. the offending predicate and the
     41argument's or result's name. Some are implemented as macros instead of
     42procedures, because I didn't want an extra parameter with the argument's
     43or result's name.
     44Procedure versions of those macros are given as well.
     45In reimplementing those routines, I changed the syntax a bit, so be
     46careful, if you used the equally named routines from simple-expressions.
     47
     48The precondition and postcondition checks are denoted with some
     49consecutive symbols < and > respectively. There are macro and procedure
     50versions, the latter denoted with a trailing % and needing an additional
     51parameter, the name of the value to be checked. All those routines work
     52the same, they differ only in the error message, they produce in case
     53some predicate returns #f. The routines named with three symbols < or >
     54differ from those with two only by an additional parameter naming the
     55location of the checks.
     56]|#
     57
     58(module checks (
     59  checker
     60  checker?
     61  assert*
     62  named-lambda
     63  <<<
     64  <<
     65  >>>
     66  >>
     67  <<<%
     68  <<%
     69  >>>%
     70  >>%
     71  true?
     72  false?
     73  checks
     74  )
     75
     76  (import scheme
     77          (only (chicken base) assert gensym print case-lambda error)
     78          (only (chicken condition) condition-case)
    4279          (only simple-exceptions raise assert-exception
    4380                argument-exception result-exception))
    4481
    45 ;;; (assert* loc xpr . xprs)
    46 ;;; ------------------------
    47 ;;; checks, if its arguments xpr . xprs are not #f.
     82
     83#|[
     84(checker sym .. ok? ....)
     85--- procedure ---
     86creates a checker routine, i.e. a unuary procedure, which returns its
     87argument unchanged, provided it passes all ok? tests. If not, an error
     88is generated with location sym, whose default is 'checker.
     89]|#
     90(define checker 'checker)
     91
     92#|[
     93(checker? xpr)
     94--- procedure ---
     95type predicate.
     96]|#
     97(define checker? 'checker?)
     98
     99(let ((in (gensym 'in)) (out (gensym 'out)))
     100
     101  (set! checker
     102    (lambda args
     103      (cond
     104        ((null? args)
     105         (error 'checker "correct args are" '(sym .. ok? ....)))
     106        ((and (null? (cdr args)) (symbol? (car args)))
     107         (error 'checker "correct args are" '(sym .. ok? ....)))
     108        (else
     109          (let ((location (if (symbol? (car args))
     110                            (car args)
     111                            'checker))
     112                (predicates (if (symbol? (car args))
     113                              (cdr args)
     114                              args)))
     115            (lambda (arg)
     116              (if (and (symbol? arg) (eq? arg in))
     117                out
     118                (let loop ((preds predicates))
     119                  (cond
     120                    ((null? preds) arg)
     121                    (((car preds) arg)
     122                     (loop (cdr preds)))
     123                    (else
     124                      (error location
     125                             "predicate failed"
     126                             (car preds) arg)))))))))))
     127
     128  (set! checker?
     129    (lambda (xpr)
     130      (and (procedure? xpr)
     131           (condition-case (eq? (xpr in) out)
     132             ((exn) #f)))))
     133  )
     134
     135#|[
     136(assert* loc xpr . xprs)
     137--- macro ---
     138checks, if its arguments xpr . xprs are not #f.
     139]|#
    48140(define-syntax assert*
    49141  (syntax-rules ()
     
    55147    ))
    56148
     149#|[
     150(named-lambda (name . args) xpr . xprs)
     151--- macro ---
     152can be used in place of lambda,
     153possibly improving error messages
     154]|#
    57155(define-syntax named-lambda
    58156  (syntax-rules ()
     
    63161;;;;;;;;;;; the macro versions below avoid the naming of arg or result
    64162
    65 ;;; (<<< loc arg arg? ...)
    66 ;;; ----------------------
    67 ;;; check a procedure argument, arg, against each predicate arg? ...
    68 ;;; in sequence and pass it to the procedure in case of success.
    69 ;;; loc names the location in the error message.
     163#|[
     164(<<< loc arg arg? ...)
     165--- macro ---
     166Precondition test.
     167Check a procedure argument, arg, against each predicate arg? ...
     168in sequence and pass it to the procedure in case of success.
     169loc names the location in the error message.
     170]|#
    70171(define-syntax <<<
    71172  (syntax-rules ()
     
    84185    ))
    85186
    86 ;;; (<< arg arg? ...)
    87 ;;; -----------------
    88 ;;; check a procedure argument, arg, against each predicate arg? ...
    89 ;;; in sequence and pass it to the procedure in case of success.
     187#|[
     188(<< arg arg? ...)
     189--- macro ---
     190Precondition test.
     191Check a procedure argument, arg, against each predicate arg? ...
     192in sequence and pass it to the procedure in case of success.
     193]|#
    90194(define-syntax <<
    91195  (syntax-rules ()
     
    93197     (<<< '<< arg ok? ...))))
    94198
    95 ;;; (>>> loc result result? ...)
    96 ;;; ----------------------------
    97 ;;; check a return value of a function, result, against each predicate
    98 ;;; result? ...in sequence and return it in case of success.
    99 ;;; loc names the location in case of error.
     199#|[
     200(>>> loc result result? ...)
     201--- macro ---
     202Postcondition test.
     203Check a return value of a function, result, against each predicate
     204result? ...in sequence and return it in case of success.
     205loc names the location in case of error.
     206]|#
    100207(define-syntax >>>
    101208  (syntax-rules ()
     
    114221    ))
    115222
    116 ;;; (>> result result? ...)
    117 ;;; -----------------------
    118 ;;; check a return value of a function, result, against each predicate
    119 ;;; result? ...in sequence and return it in case of success.
     223#|[
     224(>> result result? ...)
     225--- macro ---
     226Postcondition test.
     227Check a return value of a function, result, against each predicate
     228result? ...in sequence and return it in case of success.
     229]|#
    120230(define-syntax >>
    121231  (syntax-rules ()
     
    125235;;;;;; procedure versions need to name arg and result respectively
    126236
     237#|[
     238(<<<% loc arg-name arg . tests)
     239--- procedure ---
     240Precondition test.
     241Procedure version of <<<, arg needs to be named.
     242]|#
    127243(define (<<<% loc arg-name arg . tests)
    128244  (let loop ((tests tests))
     
    140256
    141257
     258#|[
     259(<<% arg-name arg . tests)
     260--- procedure ---
     261Precondition test.
     262Procedure version of <<, arg needs to be named.
     263]|#
    142264(define (<<% arg-name arg . tests)
    143265  (apply <<<% '<< arg-name arg tests))
    144266
     267#|[
     268(>>>% loc result-name result . tests)
     269--- procedure ---
     270Postcondition test.
     271Procedure version of >>>, result needs to be named.
     272]|#
    145273(define (>>>% loc result-name result . tests)
    146274  (let loop ((tests tests))
     
    157285
    158286
     287#|[
     288(>>% result-name result . tests)
     289--- procedure ---
     290Postcondition test.
     291Procedure version of <<, result needs to be named.
     292]|#
    159293(define (>>% result-name result . tests)
    160294  (apply >>>% '>> result-name result tests))
    161295
     296#|[
     297(true? xpr)
     298--- procedure ---
     299always true
     300]|#
    162301(define (true? xpr) #t)
     302
     303#|[
     304(false? xpr)
     305--- procedure ---
     306always false
     307]|#
    163308(define (false? xpr) #f)
    164309
    165 ;;; (named-lambda (name . args) xpr . xprs)
    166 ;;; -----------------------------------
    167 ;;; can replace anonymous procedures in << and >>
    168 ;;; to improve error messages
    169 ;;; (checks [sym])
    170 ;;; -------------------------
    171 ;;; documentation procedure
     310
     311#|[
     312(checks)
     313(checks sym)
     314--- procedure ---
     315documentation procedure
     316]|#
    172317(define checks
    173   (let ((als '(
    174     (checks
    175       procedure:
    176       (checks sym ..)
    177       "documentation procedure")
    178     (assert*
    179       macro:
    180       (assert* loc xpr ....)
    181       "checks, if its arguments xpr .... are  not #f")
    182     (named-lambda
    183       macro:
    184       (named-lambda (name . args) xpr . xprs)
    185       "can be used in place of lambda,"
    186       "possibly improving error messages")
    187     (<<<
    188       macro:
    189       (<<< loc arg arg? ...)
    190       "precondition test:"
    191       "check arg against each predicate arg? in sequence"
    192       "and return it in case of success."
    193       "Otherwise print an error message with the"
    194       "offending predicate at location loc.")
    195     (<<
    196       macro:
    197       (<<< arg arg? ...)
    198       "precondition test:"
    199       "check arg against each predicate arg? in sequence"
    200       "and return it in case of success."
    201       "Otherwise print an error message with the"
    202       "offending predicate")
    203     (>>>
    204       macro:
    205       (<<< loc result result? ...)
    206       "postcondition test:"
    207       "check result against each predicate result? in sequence"
    208       "and return it in case of success."
    209       "Otherwise print an error message with the"
    210       "offending predicate at location loc.")
    211     (>>
    212       macro:
    213       (<<< result result? ...)
    214       "postcondition test:"
    215       "check result against each predicate result? in sequence"
    216       "and return it in case of success."
    217       "Otherwise print an error message with the"
    218       "offending predicate.")
    219     (<<<%
    220       procedure:
    221       (<<<% loc name arg arg? ...)
    222       "precondition test:"
    223       "check arg against each predicate arg? in sequence"
    224       "and return it in case of success."
    225       "Otherwise print an error message with the"
    226       "offending predicate at location loc with arg-name name.")
    227     (<<%
    228       procedure:
    229       (<<% name arg arg? ...)
    230       "precondition test:"
    231       "check arg against each predicate arg? in sequence"
    232       "and return it in case of success."
    233       "Otherwise print an error message with the"
    234       "offending predicate and arg-name name")
    235     (>>>%
    236       procedure:
    237       (>>>% loc name result result? ...)
    238       "postcondition test:"
    239       "check result against each predicate result? in sequence"
    240       "and return it in case of success."
    241       "Otherwise print an error message with the"
    242       "offending predicate at location loc with result-name name.")
    243     (>>%
    244       procedure:
    245       (<<% name result result? ...)
    246       "postcondition test:"
    247       "check result against each predicate result? in sequence"
    248       "and return it in case of success."
    249       "Otherwise print an error message with the"
    250       "offending predicate and result-name name.")
    251     (true?
    252       procedure?
    253       (true? xpr)
    254       "returns always #t")
    255     (false?
    256       procedure?
    257       (false? xpr)
    258       "returns always #f")
    259     )))
    260     (case-lambda
    261       (()
    262        (map car als))
    263       ((sym)
    264        (let ((pair (assq sym als)))
    265          (if pair
    266            (for-each print (cdr pair))
    267            (error "Not in list"
    268                   sym
    269                   (map car als))))))))
    270 
    271   ) ; module checks
    272 
     318  (let (
     319    (alist '(
     320      (checker
     321        procedure:
     322        (checker sym .. ok? ....)
     323        "creates a checker routine, i.e. a unuary procedure, which returns its"
     324        "argument unchanged, provided it passes all ok? tests. If not, an error"
     325        "is generated with location sym, whose default is 'checker."
     326        )
     327      (checker?
     328        procedure:
     329        (checker? xpr)
     330        "type predicate."
     331        )
     332      (assert*
     333        macro:
     334        (assert* loc xpr . xprs)
     335        "checks, if its arguments xpr . xprs are not #f."
     336        )
     337      (named-lambda
     338        macro:
     339        (named-lambda (name . args) xpr . xprs)
     340        "can be used in place of lambda,"
     341        "possibly improving error messages"
     342        )
     343      (<<<
     344        macro:
     345        (<<< loc arg arg? ...)
     346        "Precondition test."
     347        "Check a procedure argument, arg, against each predicate arg? ..."
     348        "in sequence and pass it to the procedure in case of success."
     349        "loc names the location in the error message."
     350        )
     351      (<<
     352        macro:
     353        (<< arg arg? ...)
     354        "Precondition test."
     355        "Check a procedure argument, arg, against each predicate arg? ..."
     356        "in sequence and pass it to the procedure in case of success."
     357        )
     358      (>>>
     359        macro:
     360        (>>> loc result result? ...)
     361        "Postcondition test."
     362        "Check a return value of a function, result, against each predicate"
     363        "result? ...in sequence and return it in case of success."
     364        "loc names the location in case of error."
     365        )
     366      (>>
     367        macro:
     368        (>> result result? ...)
     369        "Postcondition test."
     370        "Check a return value of a function, result, against each predicate"
     371        "result? ...in sequence and return it in case of success."
     372        )
     373      (<<<%
     374        procedure:
     375        (<<<% loc arg-name arg . tests)
     376        "Precondition test."
     377        "Procedure version of <<<, arg needs to be named."
     378        )
     379      (<<%
     380        procedure:
     381        (<<% arg-name arg . tests)
     382        "Precondition test."
     383        "Procedure version of <<, arg needs to be named."
     384        )
     385      (>>>%
     386        procedure:
     387        (>>>% loc result-name result . tests)
     388        "Postcondition test."
     389        "Procedure version of >>>, result needs to be named."
     390        )
     391      (>>%
     392        procedure:
     393        (>>% result-name result . tests)
     394        "Postcondition test."
     395        "Procedure version of <<, result needs to be named."
     396        )
     397      (true?
     398        procedure:
     399        (true? xpr)
     400        "always true"
     401        )
     402      (false?
     403        procedure:
     404        (false? xpr)
     405        "always false"
     406        )
     407      (checks
     408        procedure:
     409        (checks)
     410        (checks sym)
     411        "with sym: documentation of exported symbol"
     412        "without sym: list of exported symbols"
     413        )
     414        ))
     415      )
     416      (case-lambda
     417        (() (map car alist))
     418        ((sym)
     419         (let ((pair (assq sym alist)))
     420           (if pair
     421             (for-each print (cdr pair))
     422             (print "Choose one of " (map car alist))))))))
     423)
  • release/5/checks/trunk/tests/run.scm

    r37483 r39594  
    1 (import scheme (chicken base) checks simple-tests)
     1(import checks)
    22
    3 (define x 5)
     3(import scheme (chicken base) (chicken condition) simple-tests)
    44
    5 (define-test (checks?)
     5(define-tester
     6  (checkers?
     7    checkit
     8    (checker 'foo integer? positive?)
     9    checkme
     10    (checker integer? positive?))
     11  (checker? checkit)
     12  #t
     13  (checker? checkme)
     14  #t
     15  (checker? string?)
     16  #f
     17  (checkit 5)
     18  5
     19  (checkme 5)
     20  5
     21  (condition-case (checkme -1) ((exn) #f))
     22  #f
     23  (condition-case ((checker 'bar string?) 5) ((exn) #f))
     24  #f)
    625
     26(define-tester
     27  (checks? x 5)
    728  (assert* 'x (integer? x))
     29  #t
    830  (assert* 'x (integer? x) (odd? x))
    9   (not
    10     (condition-case
    11       (assert* 'x (integer? x) (even? x))
    12       ((exn assert) #f)))
     31  #t
     32  (condition-case (assert* 'x (integer? x) (even? x)) ((exn assert) #f))
     33  #f
     34  x
     35  5
     36  (>> x)
     37  5
     38  (<< x)
     39  5
     40  (>> x integer? odd?)
     41  5
     42  (>>% 'x x integer? odd?)
     43  5
     44  (<< x integer? odd?)
     45  5
     46  (<<% 'x x integer? odd?)
     47  5
     48  (<<< 'loc x integer? odd?)
     49  5
     50  (>>> 'loc x integer? odd?)
     51  5
     52  (<<<% 'loc 'x x integer? odd?)
     53  5
     54  (>>>% 'loc 'x x integer? odd?)
     55  5
     56  (condition-case (<<% 'x x integer? even?) ((exn argument) #f))
     57  #f
     58  (condition-case (<<<% 'loc 'x x integer? even?) ((exn argument) #f))
     59  #f
     60  (condition-case (>> x integer? even?) ((exn result) #f))
     61  #f
     62  (<< ((lambda () #f)) boolean?)
     63  #f
     64  ((named-lambda (! n) (if (zero? n) 1 (* n (! (- n 1))))) 5)
     65  120)
    1366
    14   (= (>> x) 5)
    15   (= (<< x) 5)
    16   (= (>> x integer? odd?) 5)
    17   (= (>>% 'x x integer? odd?) 5)
    18   (= (<< x integer? odd?) 5)
    19   (= (<<% 'x x integer? odd?) 5)
    20   (= (<<< 'loc x integer? odd?) 5)
    21   (= (>>> 'loc x integer? odd?) 5)
    22   (= (<<<% 'loc 'x x integer? odd?) 5)
    23   (= (>>>% 'loc 'x x integer? odd?) 5)
    24   (not (condition-case
    25          (<<% 'x x integer? even?)
    26          ((exn argument) #f)))
    27   (not (condition-case
    28          (<<<% 'loc 'x x integer? even?)
    29          ((exn argument) #f)))
    30   (not (condition-case
    31          (>> x integer? even?)
    32          ((exn result) #f)))
    33   (not (<< ((lambda () #f)) boolean?))
    34   (= ((named-lambda (! n)
    35         (if (zero? n)
    36           1
    37           (* n (! (- n 1)))))
    38       5)
    39      120)
     67(test-all CHECKS
     68  checkers?
     69  checks?
    4070  )
    41 
    42 (compound-test (CHECKS)
    43   (checks?)
    44   )
    45 
Note: See TracChangeset for help on using the changeset viewer.