check.k (15395B)
1 ;;; Simple test framework based on srfi-78 2 ;;; 3 ;;; See Copyright Notice in klisp.h 4 ;;; 5 ;;; SOURCE NOTE: Based on the reference implementation by Sebastian Egner 6 ;;; 7 ;;; TEMP: No eager comprehension for now 8 ;;; XXX: modes are encapsulated values instead of symbols, it could also 9 ;;; be done with a $check-set-mode! operative, or with keyword objects 10 ;;; it they were implemented. 11 ;;; 12 ;;; 13 14 ;; TODO refactor out some of the code in $check, $check-error, and the -ec 15 ;; variants, there is too much duplication and the applicatives are a bit 16 ;; too long. 17 ($provide! 18 ($check $check-error check-report check-reset! check-set-mode! 19 check-passed? check-mode-off check-mode-summary 20 check-mode-report-failed check-mode-report) 21 ;; PRIVATE 22 23 ;; STATE 24 25 ;; internal count 26 ($define! passed 0) 27 ($define! failed 0) 28 ($define! first-failed #inert) ;; form: (error? . extra-data) 29 ;; no error: (#f exp actual expected) 30 ;; error: (#t string exp error) 31 ;; failed = 0 => first-failed = #inert 32 33 ;; initial state: report-failed (states are off summary report-failed and 34 ;; report) 35 ($define! report-on? #t) ; #t except in all states except: off 36 ($define! report-fail? #t) ; #t in states: report-failed and report 37 ($define! report-pass? #f) ; #t in state: report 38 39 ;; encapsulation for mode parameter 40 ($define! (enc-mode mode? get-mode-params) (make-encapsulation-type)) 41 ;; /STATE 42 43 ;; little helper for error catching 44 ;; This evaluates expression in the dynamic environment 45 ;; If no error occurs it returs #t 46 ;; If an there is an error, the handler applicative is called 47 ;; in the dynamic environment with the object passed to the error 48 ;; continuation as sole argument 49 ($define! $without-error? 50 ($vau (exp handler) denv 51 (guard-dynamic-extent 52 () 53 ($lambda () 54 (eval exp denv) 55 #t) 56 (list (list error-continuation 57 ($lambda (error-obj divert) 58 (apply (eval handler denv) 59 (list error-obj) denv) 60 (apply divert #f))))))) 61 62 ;; ;; another way to do the same: return a pair of (error? result/error-obj) 63 ;; ;; but it is difficult to use because it starts nesting (see $check) 64 ;; ($define! $try 65 ;; ($vau (exp) denv 66 ;; (guard-dynamic-extent 67 ;; () 68 ;; ($lambda () 69 ;; (list #t (eval exp denv)) 70 ;; (list (list error-continuation 71 ;; ($lambda (error-obj divert) 72 ;; (apply divert (list #f error-obj))))))))) 73 74 75 76 ($define! check-passed! 77 ($let ((env (get-current-environment))) 78 ($lambda () 79 ($set! env passed (+ passed 1))))) 80 81 ($define! check-failed/expected! 82 ($let ((env (get-current-environment))) 83 ($lambda ls 84 ($if (zero? failed) 85 ($set! env first-failed (cons #f ls)) 86 #inert) 87 ($set! env failed (+ failed 1))))) 88 89 ($define! check-failed/error! 90 ($let ((env (get-current-environment))) 91 ($lambda ls 92 ($if (zero? failed) 93 ($set! env first-failed (cons #t ls)) 94 #inert) 95 ($set! env failed (+ failed 1))))) 96 97 ($define! describe-passed 98 ($lambda (exp actual) 99 (show-exp exp) 100 (show-res actual) 101 (show-passed 1))) 102 103 ($define! describe-failed 104 ($lambda (exp actual expected) 105 (show-exp exp) 106 (show-res actual) 107 (show-failed expected))) 108 109 ($define! describe-error 110 ($lambda (str exp err-obj) 111 (display str) 112 (show-exp exp) 113 (show-error err-obj))) 114 115 ($define! describe-first-failed 116 ($lambda () 117 ($if (not? (zero? failed)) 118 ($let (((error? . extra-data) first-failed)) 119 (apply ($if error? 120 describe-error 121 describe-failed) 122 extra-data)) 123 #inert))) 124 125 ;; show applicatives 126 ($define! show-exp 127 ($lambda (exp) 128 (write exp) 129 (display " => "))) 130 131 ($define! show-res 132 ($lambda (res) 133 (write res))) 134 135 ($define! show-passed 136 ($lambda (cases) 137 (display "; *** passed ") 138 ($if (not? (=? cases 1)) 139 ($sequence (display "(") 140 (display cases) 141 (display " cases)")) 142 #inert) 143 (display "***") 144 (newline))) 145 146 ($define! show-failed 147 ($lambda (expected) 148 (display "; *** failed ***") 149 (newline) 150 (display " ; expected result: ") 151 (write expected) 152 (newline))) 153 154 ($define! show-error 155 ($lambda (err-obj) 156 (display "; *** error ***") 157 (newline) 158 (display "; error object: ") 159 (write err-obj) 160 (newline))) 161 ;; /PRIVATE 162 163 ;; PUBLIC 164 165 ;; general check facility. It always take an equality predicate 166 ;; needs to be operative to save the original expression 167 ($define! $check 168 ($let ((handler (wrap ($vau (error-obj) denv 169 ($set! denv error-obj error-obj))))) 170 ($vau (test? exp expected) denv 171 ($cond ((not? report-on?) #inert) 172 ((not? ($without-error? ($define! test? (eval test? denv)) 173 handler)) 174 ($let ((error-ls 175 (list "error evaling test? applicative: " test? 176 error-obj))) 177 (apply check-failed/error! error-ls) 178 ($if report-fail? 179 (apply describe-error error-ls) 180 #inert))) 181 ((not? ($without-error? ($define! expected (eval expected denv)) 182 handler)) 183 ($let ((error-ls 184 (list "error evaling expected value: " expected 185 error-obj))) 186 (apply check-failed/error! error-ls) 187 ($if report-fail? 188 (apply describe-error error-ls) 189 #inert))) 190 ((not? ($without-error? ($define! res (eval exp denv)) handler)) 191 ($let ((error-ls 192 (list "error evaling expression: " exp error-obj))) 193 (apply check-failed/error! error-ls) 194 ($if report-fail? 195 (apply describe-error error-ls) 196 #inert))) 197 ((not? ($without-error? ($define! test-result 198 (apply test? (list res expected))) 199 handler)) ;; no dyn env here 200 ($let ((error-ls 201 (list "error evaling (test? exp expected): " 202 (list test? exp expected) error-obj))) 203 (apply check-failed/error! error-ls) 204 ($if report-fail? 205 (apply describe-error error-ls) 206 #inert))) 207 (test-result 208 (check-passed!) 209 ($if report-pass? (describe-passed exp res) #inert)) 210 (#t ; test-result = #f 211 (check-failed/expected! exp res expected) 212 ($if report-fail? (describe-failed exp res expected) 213 #inert)))))) 214 215 ;; XXX /work in progress 216 217 ;; helpers 218 ($define! $check-ec-helper 219 ($vau (test?-exp exp expected-exp escape/c) denv 220 ;; TODO, add argument-list for errors 221 ($cond ((not? ($without-error? ($define! test? (eval test? denv)) 222 handler)) 223 ($let ((error-ls 224 (list "error evaling test? applicative: " test? 225 error-obj))) 226 (apply check-failed/error! error-ls) 227 ($if report-fail? 228 (apply describe-error error-ls) 229 #inert) 230 (apply-continuation escape/c #inert))) 231 ((not? ($without-error? ($define! expected (eval expected denv)) 232 handler)) 233 ($let ((error-ls 234 (list "error evaling expected value: " expected 235 error-obj))) 236 (apply check-failed/error! error-ls) 237 ($if report-fail? 238 (apply describe-error error-ls) 239 #inert) 240 (apply-continuation escape/c #inert) 241 )) 242 ((not? ($without-error? ($define! res (eval exp denv)) handler)) 243 ($let ((error-ls 244 (list "error evaling expression: " exp error-obj))) 245 (apply check-failed/error! error-ls) 246 ($if report-fail? 247 (apply describe-error error-ls) 248 #inert) 249 (apply-continuation escape/c #inert))) 250 ((not? ($without-error? ($define! test-result 251 (apply test? (list res expected))) 252 handler)) ;; no dyn env here 253 ($let ((error-ls 254 (list "error evaling (test? exp expected): " 255 (list test? exp expected) error-obj))) 256 (apply check-failed/error! error-ls) 257 ($if report-fail? 258 (apply describe-error error-ls) 259 #inert) 260 (apply-continuation escape/c #inert))) 261 (test-result 262 ; (check-passed!) passed only after all passed 263 ; ($if report-pass? (describe-passed exp res) #inert)) 264 #inert 265 (#t ; test-result = #f 266 (check-failed/expected! exp res expected) 267 ($if report-fail? (describe-failed exp res expected) #inert) 268 (apply-continuation escape/c #inert)))))) 269 270 ($define! $check-ec 271 ($let ((handler (wrap ($vau (error-obj) denv 272 ($set! denv error-obj error-obj))))) 273 ($vau (gens test? exp expected . maybe-arg-list) denv 274 ;; TODO add check 275 ($define! arg-list ($if (null? maybe-arg-list) 276 () 277 (car maybe-arg-list))) 278 ($cond ((not? report-on?) #inert) 279 ((not? ($without-error? ($define! gen (eval (cons $nested-ec 280 gens) 281 denv)) handler)) 282 ($let ((error-ls 283 (list "error evaling qualifiers: " gens error-obj))) 284 (apply check-failed/error! error-ls) 285 ($if report-fail? 286 (apply describe-error error-ls) 287 #inert))) 288 (($let/cc escape/c 289 ;; TODO add some security to the continuation 290 ;; (like make it one-shot and/or avoid reentry) 291 (eval (list do-ec (list gen) 292 (list check-ec-helper 293 test?-exp exp expected-exp 294 escape/c))) 295 #t) 296 ;; ... TODO passed with n cases 297 (check-passed!) 298 ($if report-pass? (describe-passed exp res) #inert) 299 ) 300 (#t ;; TODO didn't pass... 301 #inert 302 ))))) 303 304 ;; XXX /work in progress 305 306 ;; Check that the given expression throws an error 307 ;; needs to be operative to save the original expression 308 ;; (not in the srfi, probably because of poor specification of error 309 ;; signaling in R5RS 310 ;; but very useful for checking proper argument checking) 311 ($define! $check-error 312 ($let ((handler (wrap ($vau (error-obj) denv 313 ($set! denv error-obj error-obj))))) 314 ($vau (exp) denv 315 ($cond ((not? report-on?) #inert) 316 (($without-error? ($define! result 317 (eval exp denv)) handler) 318 ($let ((error-ls 319 (list exp result "<ERROR>"))) 320 (apply check-failed/expected! error-ls) 321 ($if report-fail? 322 (apply describe-failed error-ls) 323 #inert))) 324 (#t ;; didn't throw error 325 (check-passed!) 326 ($if report-pass? 327 (describe-passed exp error-obj) 328 #inert)))))) 329 330 ($define! check-report 331 ($lambda () 332 ($if report-on? 333 ($sequence 334 (display "Tests Passed: ") 335 (write passed) 336 (newline) 337 (display "Tests Failed: ") 338 (write failed) 339 (newline) 340 (display "Tests Total: ") 341 (write (+ failed passed)) 342 (newline) 343 (describe-first-failed)) 344 #inert))) ;; state: off don't show anything 345 346 347 ;; the modes are an encapsulated object each of 348 ;; '(off summary report-failed report) 349 ;; is an ecapsulated list of their effect on state variables 350 ;; (report-on? report-error? report-pass?) 351 ($define! check-mode-off (enc-mode (list #f #f #f))) 352 ($define! check-mode-summary (enc-mode (list #t #f #f))) 353 ($define! check-mode-report-failed (enc-mode (list #t #t #f))) 354 ($define! check-mode-report (enc-mode (list #t #t #t))) 355 356 ($define! check-set-mode! 357 ($let ((env (get-current-environment))) 358 ($lambda (mode) 359 ($if (mode? mode) 360 ($set! env 361 (report-on? report-error? report-pass?) 362 (get-mode-params mode)) 363 (#t (error "$check-set-mode: invalid mode")))))) 364 365 ($define! check-reset! 366 ($let ((env (get-current-environment))) 367 ($lambda () 368 ($set! env passed 0) 369 ($set! env failed 0) 370 ($set! env first-failed #inert)))) 371 372 ($define! check-passed? 373 ($lambda (expected) 374 (and? (zero? failed) 375 (=? passed expected))))) 376 ;; /PUBLIC 377 378 379 ;; I drawed freely from the reference implementation so here is the 380 ;; copyright notice: 381 382 ;; 383 ;; Permission is hereby granted, free of charge, to any person obtaining 384 ;; a copy of this software and associated documentation files (the 385 ;; ``Software''), to deal in the Software without restriction, including 386 ;; without limitation the rights to use, copy, modify, merge, publish, 387 ;; distribute, sublicense, and/or sell copies of the Software, and to 388 ;; permit persons to whom the Software is furnished to do so, subject to 389 ;; the following conditions: 390 ;; 391 ;; The above copyright notice and this permission notice shall be 392 ;; included in all copies or substantial portions of the Software. 393 ;; 394 ;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, 395 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 396 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 397 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 398 ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 399 ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 400 ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 401 ;; 402 ;; ----------------------------------------------------------------------- 403 ;; 404 ;; Lightweight testing (reference implementation) 405 ;; ============================================== 406 ;; 407 ;; Sebastian.Egner@philips.com 408