|
| 1 | +(import (except (rnrs) current-output-port)) |
| 2 | + |
| 3 | +(define test-fields '(input expected actual)) |
| 4 | + |
| 5 | +(define (test-run-solution solution input) |
| 6 | + (if (procedure? solution) (apply solution input) solution)) |
| 7 | + |
| 8 | +(define (scheme->string o) |
| 9 | + (with-output-to-string |
| 10 | + (lambda () |
| 11 | + (write o)))) |
| 12 | + |
| 13 | +(define (process-condition e) |
| 14 | + (if (not (condition? e)) e |
| 15 | + `(error |
| 16 | + ,(if (who-condition? e) (condition-who e) |
| 17 | + 'unknown) |
| 18 | + ,(condition-message e) |
| 19 | + ,@(if (not (irritants-condition? e)) '() |
| 20 | + (condition-irritants e))))) |
| 21 | + |
| 22 | +(define (test-success description success-predicate |
| 23 | + procedure input expected code) |
| 24 | + (call/cc |
| 25 | + (lambda (k) |
| 26 | + (let ([out (open-output-string)]) |
| 27 | + (dynamic-wind |
| 28 | + (lambda () (set! out (open-output-string))) |
| 29 | + (lambda () |
| 30 | + (with-exception-handler |
| 31 | + (lambda (e) |
| 32 | + (k `(fail |
| 33 | + (description . ,description) |
| 34 | + (code . ,code) |
| 35 | + (input . ,input) |
| 36 | + (expected . ,expected) |
| 37 | + (actual . ,(process-condition e)) |
| 38 | + (stdout . ,(get-output-string out))))) |
| 39 | + (lambda () |
| 40 | + (let ([result (parameterize ([current-output-port out]) |
| 41 | + (test-run-solution procedure input))]) |
| 42 | + (unless (success-predicate result expected) |
| 43 | + (raise result)) |
| 44 | + `(pass |
| 45 | + (description . ,description) |
| 46 | + (code . ,code) |
| 47 | + (stdout . ,(get-output-string out))))))) |
| 48 | + (lambda () (close-output-port out))))))) |
| 49 | + |
| 50 | +(define (test-error description procedure input code) |
| 51 | + (call/cc |
| 52 | + (lambda (k) |
| 53 | + (let ([out '()]) |
| 54 | + (dynamic-wind |
| 55 | + (lambda () (set! out (open-output-string))) |
| 56 | + (lambda () |
| 57 | + (with-exception-handler |
| 58 | + (lambda (e) |
| 59 | + (k `(pass |
| 60 | + (description . ,description) |
| 61 | + (code . ,code) |
| 62 | + (stdout . ,(get-output-string out))))) |
| 63 | + (lambda () |
| 64 | + (let ((result (parameterize ([current-output-port out]) |
| 65 | + (test-run-solution procedure input)))) |
| 66 | + `(fail |
| 67 | + (description . ,description) |
| 68 | + (code . ,code) |
| 69 | + (input . ,input) |
| 70 | + (expected . error) |
| 71 | + (actual . ,result) |
| 72 | + (stdout . ,(get-output-string out))))))) |
| 73 | + (lambda () (close-output-port out))))))) |
| 74 | + |
| 75 | +(define (run-test test) |
| 76 | + (eval (append test `((quote ,test))) (interaction-environment))) |
| 77 | + |
| 78 | +(define (run-test-suite tests . query) |
| 79 | + (for-each |
| 80 | + (lambda (field) |
| 81 | + (unless (and (symbol? field) (memq field test-fields)) |
| 82 | + (error 'run-test-suite |
| 83 | + (format #t "~a not in ~a" field test-fields)))) |
| 84 | + query) |
| 85 | + (let-values ([(passes failures) |
| 86 | + (partition |
| 87 | + (lambda (result) (eq? 'pass (car result))) |
| 88 | + (map run-test tests))]) |
| 89 | + (cond |
| 90 | + [(null? failures) (format #t "~%Well done!~%~%")] |
| 91 | + [else |
| 92 | + (format |
| 93 | + #t |
| 94 | + "~%Passed ~a/~a tests.~%~%The following test cases failed:~%~%" |
| 95 | + (length passes) |
| 96 | + (length tests)) |
| 97 | + (for-each |
| 98 | + (lambda (failure) |
| 99 | + (format |
| 100 | + #t |
| 101 | + "* ~a~%" |
| 102 | + (cond |
| 103 | + [(assoc 'description (cdr failure)) => cdr] |
| 104 | + [else (cdr failure)])) |
| 105 | + (for-each |
| 106 | + (lambda (field) |
| 107 | + (let ([info (assoc field (cdr failure))]) |
| 108 | + (display " - ") |
| 109 | + (write (car info)) |
| 110 | + (display ": ") |
| 111 | + (write (cdr info)) |
| 112 | + (newline))) |
| 113 | + query)) |
| 114 | + failures) |
| 115 | + (error 'test "incorrect solution")]))) |
| 116 | + |
| 117 | + |
| 118 | +(define (run-docker suite) |
| 119 | + (write (map run-test suite))) |
| 120 | + |
| 121 | +(define (test suite . query) |
| 122 | + (apply run-test-suite suite query)) |
| 123 | + |
| 124 | +(define (tests suites . query) |
| 125 | + (for-each (lambda (suite) (apply test suite query)) suites)) |
| 126 | + |
| 127 | +(define (run-with-cli solution suites) |
| 128 | + (let ((args (command-line))) |
| 129 | + (cond |
| 130 | + ;; Normal execution. This is the default behavior used by students |
| 131 | + ;; running their tests locally. |
| 132 | + [(null? (cdr args)) |
| 133 | + (load solution) |
| 134 | + (tests suites 'input 'expected 'actual)] |
| 135 | + ;; Scheme programs ingesting this output can expect an alist with |
| 136 | + ;; the keys 'test-lib-version and 'status. No test-lib version |
| 137 | + ;; means an older version of these test utilities is in use, so there |
| 138 | + ;; will only be pass/fail lists in the output. When status is 'error, |
| 139 | + ;; A message is provided for explanation. It is usually a stringified |
| 140 | + ;; condition. When status is 'completed everything is normal, and the |
| 141 | + ;; rest of the list comsists of pass/fail lists. |
| 142 | + [(string=? (cadr args) "--docker") |
| 143 | + (write |
| 144 | + `((test-lib-version . 1) |
| 145 | + ,@(call/cc |
| 146 | + (lambda (k) |
| 147 | + (with-exception-handler |
| 148 | + ;; Catch failures while loading/compiling the solution. |
| 149 | + (lambda (e) |
| 150 | + (k `((status . error) |
| 151 | + (message |
| 152 | + . ,(string-append |
| 153 | + "Failed with value: " |
| 154 | + (scheme->string (process-condition e))))))) |
| 155 | + (lambda () |
| 156 | + (load solution) |
| 157 | + `((status . ok) |
| 158 | + ,@(fold-left (lambda (results suite) |
| 159 | + (append results (map run-test suite))) |
| 160 | + '() suites))))))))] |
| 161 | + ;; You can pass the name of a file to load instead of the "expected" solution filename. |
| 162 | + [else (load (cadr args)) (tests suites 'input 'expected)]))) |
0 commit comments