1;;; 2;;; srfi-78 - Lightweight testing 3;;; 4;;; Copyright (c) 2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34;; If srfi-78 is used within gauche.test framework, we integrate 35;; it into gauche.test---that is, check works as a wrapper of test*. 36;; Otherwise, check bookkeeps its own testing. 37 38(define-module srfi-78 39 (use gauche.test) 40 (use srfi-42) 41 (use util.match) 42 (export check check-ec check-report check-set-mode! check-reset! 43 check-passed?)) 44(select-module srfi-78) 45 46(define check-mode (make-parameter 'report)) 47 48;; API 49;; NB: If srfi-78 runs within gauche.test, it doesn't do any reporting 50;; by itself. 51(define (check-set-mode! mode) 52 (ecase mode 53 [(off summary report-failed report) (check-mode mode)])) 54 55;; Track the test results 56(define-class <check-results> () 57 ((total-count :init-value 0) 58 (pass-count :init-value 0) 59 (first-failure :init-value #f) ; (name expected result aux) 60 )) 61 62(define (reset-results! results) 63 (set! (~ results'total-count) 0) 64 (set! (~ results'pass-count) 0) 65 (set! (~ results'first-failure) #f)) 66 67(define *global-results* (make <check-results>)) 68 69(define (register-failure! results name expected result aux) 70 (unless (~ results'first-failure) 71 (set! (~ results'first-failure) 72 (list name expected result aux)))) 73 74;; API 75(define (check-reset!) (reset-results! *global-results*)) 76 77(define ((%check-hook results) verdict name expected result) 78 (inc! (~ results'total-count)) 79 (case verdict 80 [(pass) (inc! (~ results'pass-count))] 81 [(fail) (register-failure! results name expected result '())])) 82 83(define (do-check results name expected thunk eqproc aux) 84 (if (test-running?) 85 ;; delegate to gauche.test 86 (test name expected thunk eqproc (%check-hook results)) 87 (guard ([e (else 88 (register-failure! results name expected e aux))]) 89 (inc! (~ results'total-count)) 90 (let1 result (thunk) 91 (if (eqproc expected result) 92 (begin 93 (when (and (eq? results *global-results*) 94 (eq? (check-mode) 'report)) 95 (format #t "Checking ~s, expecting ~s => ok\n" 96 name expected)) 97 (inc! (~ results'pass-count))) 98 (begin 99 (when (and (eq? result *global-results*) 100 (memq (check-mode) '(report report-failed))) 101 (format #t "Checking ~s, expecting ~s => ERROR: got ~s\n" 102 name expected result)) 103 (register-failure! results name expected result aux))))))) 104 105;; API 106(define-syntax check 107 (syntax-rules (=>) 108 [(_ expr (=> eqproc) expected) 109 (unless (eq? (check-mode) 'off) 110 (do-check *global-results* 'expr expected (^[] expr) eqproc '()))] 111 [(_ expr => expected) 112 (check expr (=> equal?) expected)])) 113 114;; API 115(define (check-passed? expected-num-passed) 116 (and (not (~ *global-results*'first-failure)) 117 (= expected-num-passed (~ *global-results*'pass-count)))) 118 119;; format the argument part of check-ec 120(define (%format-aux aux) 121 (if (null? aux) 122 "" 123 (string-append ", with " 124 (string-join (map (^p (format "~s: ~s" (car p) (cdr p))) 125 aux) 126 ", ")))) 127 128;; API 129;; This only reports in standalone-mode 130(define (check-report) 131 (unless (or (test-running?) (eq? (check-mode) 'off)) 132 (match (~ *global-results*'first-failure) 133 [(name expected result aux) 134 (format #t "Passed ~d tests out of ~d tests. First failure on ~s, \ 135 expected: ~s, result: ~s~a\n" 136 (~ *global-results*'pass-count) 137 (~ *global-results*'total-count) 138 name expected result 139 (%format-aux aux))] 140 [_ 141 (format #t "All ~d tests passed.\n" 142 (~ *global-results*'pass-count))]))) 143 144;; API 145(define-syntax check-ec 146 (syntax-rules (=>) 147 [(_ q ... expr (=> eqproc) expected (arg ...)) 148 (let ((results (make <check-results>))) 149 (do-ec q ... 150 (do-check results 'expr expected (^[] expr) eqproc 151 (list (cons 'arg arg) ...))) 152 (inc! (~ *global-results*'total-count)) 153 (match (~ results'first-failure) 154 [(and (name expected result aux) failure) 155 (when (and (not (test-running?)) 156 (memq (check-mode) '(report report-failed))) 157 (format #t "Checking ~s, expecting ~s => ERROR: got ~s~a\n" 158 name expected result 159 (%format-aux aux))) 160 (apply register-failure! *global-results* failure)] 161 [_ 162 (when (and (not (test-running?)) 163 (eq? (check-mode) 'report)) 164 (format #t "Checking ~s, expecting ~s => ok\n" 165 'expr 'expected)) 166 (inc! (~ *global-results*'pass-count))]))] 167 [(_ q ... expr => expected (arg ...)) 168 (check-ec q ... expr (=> equal?) expected (arg ...))] 169 [(_ q ... expr (=> eqproc) expected) 170 (check-ec q ... expr (=> exproc) expected ())] 171 [(_ q ... expr => expected) 172 (check-ec q ... expr (=> equal?) expected ())])) 173