Some correction and moving around.
[com-informatimago:com-informatimago.git] / common-lisp / cesarum / simple-test.lisp
1 ;;;; -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               simple-test.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    Defines a simple test tool.
10 ;;;;    
11 ;;;;AUTHORS
12 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
13 ;;;;MODIFICATIONS
14 ;;;;    2010-12-14 <PJB> Created.
15 ;;;;BUGS
16 ;;;;LEGAL
17 ;;;;    AGPL3
18 ;;;;    
19 ;;;;    Copyright Pascal J. Bourguignon 2010 - 2012
20 ;;;;    
21 ;;;;    This program is free software: you can redistribute it and/or modify
22 ;;;;    it under the terms of the GNU Affero General Public License as published by
23 ;;;;    the Free Software Foundation, either version 3 of the License, or
24 ;;;;    (at your option) any later version.
25 ;;;;    
26 ;;;;    This program is distributed in the hope that it will be useful,
27 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
28 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
29 ;;;;    GNU Affero General Public License for more details.
30 ;;;;    
31 ;;;;    You should have received a copy of the GNU Affero General Public License
32 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
33 ;;;;**************************************************************************
34
35 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
36   (:use "COMMON-LISP"
37         "COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM")
38   (:export "*DEBUG-ON-ERROR*" "WITH-DEBUGGER-ON-ERROR"
39            "DEFINE-TEST" "TEST" "ASSERT-TRUE" "EXPECT-CONDITION"
40
41            "*VERBOSE-TALLY*" "*VERBOSE-PROGRESS*")
42   (:documentation "
43 This package defines a simple test tool.
44
45 License:
46
47     AGPL3
48     
49     Copyright Pascal J. Bourguignon 2010 - 2012
50     
51     This program is free software: you can redistribute it and/or modify
52     it under the terms of the GNU Affero General Public License as published by
53     the Free Software Foundation, either version 3 of the License, or
54     (at your option) any later version.
55     
56     This program is distributed in the hope that it will be useful,
57     but WITHOUT ANY WARRANTY; without even the implied warranty of
58     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
59     GNU Affero General Public License for more details.
60     
61     You should have received a copy of the GNU Affero General Public License
62     along with this program.
63     If not, see <http://www.gnu.org/licenses/>
64 "))
65 (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST")
66
67
68 (defvar *debug-on-error*          nil
69   "Whether an error in a test should go to the debugger.")
70 (defvar *success-count*           0
71   "The total number of successful tests.")
72 (defvar *failure-count*           0
73   "The total number of failed tests.")
74
75 (defvar *verbose-tally* t
76   "Whether to print the number of successful, failed and performed tests.")
77 (defvar *verbose-progress* nil
78   "Whether to display dots or exclamation points while testing.")
79
80 (defvar *test-output* *standard-output*)
81
82 ;; Private:
83 (defvar *last-success-p*          nil)
84 (defvar *current-test-name*       nil)
85 (defvar *current-test-parameters* nil)
86 (defvar *current-test-printed-p*  nil)
87 (defvar *report-string*           "")
88 (defparameter *cr*                #\return)
89
90
91 (defun progress-start ()
92   (setf *success-count*  0
93         *failure-count*  0
94         *last-success-p* nil
95         *report-string*  (make-array 8
96                                      :element-type 'character
97                                      :adjustable t
98                                      :fill-pointer 0))
99   (values))
100
101
102 (defun verbose (default)
103   (and default
104        (or (not *load-pathname*)
105            *load-verbose*
106            (and (find-package "ASDF")
107                 (find-symbol "*ASDF-VERBOSE*" "ASDF")
108                 (symbol-value (find-symbol "*ASDF-VERBOSE*" "ASDF")))
109            (and (find-package "QUICKLISP")
110                 (find-symbol "*QUICKLOAD-VERBOSE*" "QUICKLISP-CLIENT")
111                 (symbol-value (find-symbol "*QUICKLOAD-VERBOSE*" "QUICKLISP-CLIENT"))))))
112
113
114 (defun progress-report (new-last-succcess-p)
115   (setf *last-success-p* new-last-succcess-p)
116   (when (verbose *verbose-progress*)
117     (if *last-success-p*
118         (format *test-output* "~A" (aref *report-string* (1- (length *report-string*))))
119         (format *test-output* "~&~A" *report-string*))
120     (finish-output *test-output*))
121   (values))
122
123
124 (defun progress-success ()
125   (incf *success-count*)
126   (vector-push-extend #\. *report-string*)
127   (progress-report t))
128
129
130 (defun current-test-identification (&optional max-length)
131   (let ((*print-circle* nil))
132    (if max-length
133        (let* ((items (mapcar (lambda (parameter)
134                                (let ((label (let ((*package* (if (and (symbolp parameter)
135                                                                       (symbol-package parameter))
136                                                                  (symbol-package parameter)
137                                                                  *package*)))
138                                               (format nil "~S" parameter))))
139                                  (list (length label) label)))
140                              (cons *current-test-name* *current-test-parameters*)))
141               (idlength (+ 1 (length items) (reduce (function +) items :key (function first))))
142               (candidates (sort (butlast (loop
143                                            :for cell :on items
144                                            :collect cell))
145                                 (function >)
146                                 :key (function caadr))))
147          (loop
148            :until (<= idlength max-length)
149            :do (progn
150                  (decf idlength (1- (caadar candidates)))
151                  (setf (car (cdadar candidates)) "…")
152                  (pop candidates))
153            :finally (return (format nil "(~{~A~^ ~})" (mapcar (function second) items)))))
154        (format nil "(~{~S~^ ~})" (cons *current-test-name* *current-test-parameters*)))))
155
156 ;; (let ((*current-test-name* 'hello-world)
157 ;;       (*current-test-parameters* '((1 2 3 4) "howdy doo dabadaboo" #(a b c d e f))))
158 ;;   (current-test-identification  nil))
159
160
161
162 (defun progress-failure-message (expression message &rest arguments)
163   (incf *failure-count*)
164   (vector-push-extend #\! *report-string*)
165   (unless *current-test-printed-p*
166     (setf  *current-test-printed-p* t)
167     (format *test-output* "~&~A" (current-test-identification)))
168   (format *test-output* "~&Failure:     expression: ~S~@
169              ~&~?~%"
170           expression message arguments)
171   (progress-report nil))
172
173
174 (defun progress-failure (compare expression expected-result result &optional places)
175   (progress-failure-message expression "~&           evaluates to: ~S~@
176                                         ~&           which is not  ~A~@
177                                         ~& to the expected result: ~S~@
178                                         ~{~&~23A: ~S~}"
179                             result compare expected-result places))
180
181
182 (defun progress-tally (success-count failure-count)
183   (when (verbose *verbose-tally*)
184     (let ((name-max-length 40))
185      (flet ((genline (name)
186               (format nil "~VA~3D ~9A~3D ~8A~5D ~A"
187                       name-max-length name
188                       success-count (format nil "success~[es~;~:;es~]," success-count)
189                       failure-count (format nil "failure~P," failure-count)
190                       (+ success-count failure-count)
191                       (format nil "test~P." (+ success-count failure-count)))))
192        (format *test-output* "~&~A~%"
193                (genline  (current-test-identification name-max-length)))
194        (finish-output *test-output*)
195        ;; (let* ((test-name (current-test-identification name-max-length))
196        ;;        (data (genline ""))
197        ;;        (nlen (length test-name)))
198        ;;   (format *test-output* "~&~A~%" 
199        ;;           (if (and (< nlen (+ name-max-length 4)) (char= #\space (aref data nlen)))
200        ;;               (progn
201        ;;                 (replace data test-name)
202        ;;                 data)
203        ;;               (genline (concatenate 'string (subseq test-name 0 43) "…"))))
204        ;;   (finish-output *test-output*))
205        )))
206   (values))
207
208
209 (defmacro assert-true (expression)
210   "Evaluates a test EXPRESSION and check it returns true.
211 EXAMPLE:  (assert-true (= 2 (+ 1 1))))
212 "
213   (let ((vresult   (gensym "RESULT-")))
214     `(let ((,vresult   (if *debug-on-error*
215                            (handler-bind
216                                ((error (function invoke-debugger)))
217                              ,expression)
218                            (handler-case
219                                ,expression
220                              (error (err) (list 'error (princ-to-string err)))))))
221        (if ,vresult
222            (progress-success)
223            (progress-failure 'equivalent ',expression 't ,vresult)))))
224
225
226 (defmacro expect-condition (condition-class expression)
227   "Evaluates a test EXPRESSION and check that it signals a condition of the specified CONDITION-CLASS.
228 EXAMPLE:  (expect-condition division-by-zero (/ 1 0))
229 "
230   (let ((body (gensym)))
231     `(flet ((,body ()
232                    ,expression
233                    (progress-failure-message ',expression
234                                              "Didn't signal the expected ~S condition."
235                                              ',condition-class)))
236        (if *debug-on-error*
237            (block expect
238              (handler-bind
239                  ((,condition-class (lambda (condition)
240                                       (declare (ignore condition))
241                                       (progress-success)
242                                       (return-from expect)))
243                   (t (function invoke-debugger)))
244                (,body)))
245            (handler-case
246                (,body)
247              (,condition-class ()
248                (progress-success))
249              (t (condition)
250                (progress-failure-message ',expression
251                                          "Signaled an unexpected ~S condition instead of ~S."
252                                          condition
253                                          ',condition-class)))))))
254
255
256
257 (defmacro test (compare expression expected &optional places)
258   "Evaluates a test EXPRESSION and compare the result with EXPECTED (evaluated) using the COMPARE operator.
259 EXAMPLE:  (test equal (list 1 2 3) '(1 2 3))
260 "
261   (let ((vresult   (gensym "RESULT-"))
262         (vexpected (gensym "EXPECTED-")))
263     `(let ((,vresult   (if *debug-on-error*
264                            (handler-bind
265                                ((error (function invoke-debugger)))
266                              ,expression)
267                            (handler-case
268                                ,expression
269                              (error (err) (list 'error (princ-to-string err))))))
270            (,vexpected ,expected))
271        (if (,compare ,vresult ,vexpected)
272            (progress-success)
273            (progress-failure ',compare ',expression ,vexpected ,vresult
274                              (list ,@(mapcan (lambda (place) `(',place ,place)) places)))))))
275
276
277 (defmacro define-test (name parameters &body body)
278   "Like DEFUN, but wraps the body in test reporting boilerplate."
279   (let ((mandatory (loop
280                      :for param :in parameters
281                      :while (symbolp param)
282                      :collect param)))
283     (multiple-value-bind (docstrings declarations forms) (parse-body :lambda body)
284       `(defun ,name ,parameters
285          ,@docstrings
286          ,@declarations
287          (multiple-value-bind (successes failures)
288              (let ((*success-count* 0)
289                    (*failure-count* 0)
290                    (*current-test-name*        ',name)
291                    (*current-test-parameters* (list ,@mandatory))
292                    (*current-test-printed-p*  nil))
293                (progress-start)
294                (progn ,@forms)
295                (progress-tally *success-count* *failure-count*)
296                (values *success-count* *failure-count*))
297            (incf *success-count* successes)
298            (incf *failure-count* failures)
299            (if (zerop failures)
300                :success
301                :failure))))))
302
303 (defmacro with-debugger-on-error (&body body)
304   `(let ((*debug-on-error* t))
305      ,@body))
306
307 ;;;; THE END ;;;;