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