From: Chris Hanson Date: Sun, 30 May 2010 11:04:34 +0000 (-0700) Subject: Refactor test infrastructure to use conditions and to have more flexible reporting. X-Git-Tag: 20100708-Gtk~51 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1c4135ff26828b21fe37da6e42534e03b3bac73c;p=mit-scheme.git Refactor test infrastructure to use conditions and to have more flexible reporting. --- diff --git a/tests/load.scm b/tests/load.scm index c615f9cec..e3895d682 100644 --- a/tests/load.scm +++ b/tests/load.scm @@ -27,6 +27,9 @@ USA. (environment-link-name environment '(runtime mit-macros) 'PARSE-DEFINE-FORM) (load (merge-pathnames "unit-testing" (current-load-pathname)) environment) - (if (environment-bound? system-global-environment 'RUN-UNIT-TESTS) - (unbind-variable system-global-environment 'RUN-UNIT-TESTS)) - (environment-link-name system-global-environment environment 'RUN-UNIT-TESTS)) \ No newline at end of file + (for-each (lambda (name) + (if (environment-bound? system-global-environment name) + (unbind-variable system-global-environment name)) + (link-variables system-global-environment name + environment name)) + '(RUN-UNIT-TEST RUN-UNIT-TESTS THROW-TEST-ERRORS?))) \ No newline at end of file diff --git a/tests/runtime/test-char-set.scm b/tests/runtime/test-char-set.scm index 69bd0648a..9857f5cf5 100644 --- a/tests/runtime/test-char-set.scm +++ b/tests/runtime/test-char-set.scm @@ -27,34 +27,43 @@ USA. (declare (usual-integrations)) -(define-test 'scalar-value-list +(define-test 'interesting-svl-round-trip (lambda () - (list (run-random-svl-tests 0 1) - (map (lambda (i) - (run-random-svl-tests i 100)) - (iota 4 1)) - (run-random-svl-tests 100 100)))) + (map (lambda (svl) + (run-sub-test + (lambda () + (assert-equal-canonical-svls (named-call 'SVL-ROUND-TRIP + svl-round-trip svl) + svl)))) + interesting-svls))) -(define (run-random-svl-tests n-ranges n-iter) +(define (svl-round-trip svl) + (char-set->scalar-values (scalar-values->char-set svl))) + +(define-test 'random-svl-round-trip + (lambda () + (map (lambda (svl) + (run-sub-test + (lambda () + (guarantee-well-formed-scalar-value-list svl) + (assert-equal-canonical-svls + (named-call '%CANONICALIZE-SCALAR-VALUE-LIST + %canonicalize-scalar-value-list + svl) + (svl-round-trip svl))))) + (append! (append-map! (lambda (i) + (make-random-svls i 100)) + (iota 4 1)) + (make-random-svls 100 100))))) + +(define (make-random-svls n-ranges n-iter) (map (lambda (i) i - (run-random-svl-test n-ranges)) + (make-random-svl n-ranges)) (iota n-iter))) -(define (run-random-svl-test n-ranges) - (let ((svl (make-random-svl n-ranges))) - (guarantee-well-formed-scalar-value-list svl) - (let ((svl1 (%canonicalize-scalar-value-list svl)) - (svl2 (char-set->scalar-values (scalar-values->char-set svl)))) - (list (assert-true `(canonical-svl? ,svl1) - (canonical-svl? svl1)) - (assert-true `(canonical-svl? ,svl2) - (canonical-svl? svl2)) - (assert-equal svl1 svl2))))) - (define (make-random-svl n-ranges) - ;; Random modulus must exceed %LOW-LIMIT. - (let ((modulus #x1000)) + (let ((modulus (* %low-limit 2))) (make-initialized-list n-ranges (lambda (i) (let loop () @@ -63,6 +72,186 @@ USA. (if (= m 0) n (cons n (+ n m 1)))))))))) + +(define-test 'invert + (lambda () + (map (lambda (svl) + (run-sub-test + (lambda () + (assert-equal (named-call 'SVL-INVERT-THRU + svl-invert-thru svl) + (named-call 'SVL-INVERT-DIRECT + svl-invert-DIRECT svl))))) + interesting-svls))) + +(define (svl-invert-thru svl) + (char-set->scalar-values (char-set-invert (scalar-values->char-set svl)))) + +(define (svl-invert-direct svl) + + (define (go svl prev-end) + (if (pair? svl) + (cons (make-segment prev-end + (segment-start (car svl))) + (go (cdr svl) + (segment-end (car svl)))) + (if (< prev-end char-code-limit) + (list (make-segment prev-end char-code-limit)) + '()))) + + (if (and (pair? svl) + (= (segment-start (car svl)) 0)) + (go (cdr svl) + (segment-end (car svl))) + (go svl 0))) + +(define (make-binary-test name operation svl-direct) + (lambda () + (map (lambda (svl1) + (map (lambda (svl2) + (run-sub-test + (lambda () + (with-test-properties + (lambda () + (assert-equal + (char-set->scalar-values + (operation (scalar-values->char-set svl1) + (scalar-values->char-set svl2))) + (svl-direct svl1 svl2))) + 'EXPRESSION `(,name ,svl1 ,svl2))))) + interesting-svls)) + interesting-svls))) + +(define-test 'union + (make-binary-test 'CHAR-SET-UNION + char-set-union + (lambda (svl1 svl2) + (named-call 'SVL-UNION svl-union svl1 svl2)))) + +(define (svl-union svl1 svl2) + (if (pair? svl1) + (if (pair? svl2) + (let ((s1 (segment-start (car svl1))) + (e1 (segment-end (car svl1))) + (s2 (segment-start (car svl2))) + (e2 (segment-end (car svl2)))) + (cond ((< e1 s2) + (cons (car svl1) + (svl-union (cdr svl1) svl2))) + ((< e2 s1) + (cons (car svl2) + (svl-union svl1 (cdr svl2)))) + (else + (let ((s3 (min s1 s2))) + (receive (e3 svl1 svl2) + (union:find-end (max e1 e2) + (cdr svl1) + (cdr svl2)) + (cons (make-segment s3 e3) + (svl-union svl1 svl2))))))) + svl1) + svl2)) + +(define (union:find-end e0 svl1 svl2) + (let ((s1 + (if (pair? svl1) + (segment-start (car svl1)) + #f)) + (s2 + (if (pair? svl2) + (segment-start (car svl2)) + #f))) + (if (or (and (not s1) (not s2)) + (< e0 + (cond ((not s1) s2) + ((not s2) s1) + (else (min s1 s2))))) + (values e0 svl1 svl2) + (if (and s1 + (or (not s2) + (< s1 s2))) + (union:find-end (max e0 (segment-end (car svl1))) + (cdr svl1) + svl2) + (union:find-end (max e0 (segment-end (car svl2))) + svl1 + (cdr svl2)))))) + +(define-test 'intersection + (make-binary-test 'CHAR-SET-INTERSECTION + char-set-intersection + (lambda (svl1 svl2) + (named-call 'SVL-INTERSECTION + svl-intersection svl1 svl2)))) + +(define (svl-intersection svl1 svl2) + (let loop ((svl1 svl1) (svl2 svl2)) + (if (and (pair? svl1) (pair? svl2)) + (let ((s1 (segment-start (car svl1))) + (e1 (segment-end (car svl1))) + (s2 (segment-start (car svl2))) + (e2 (segment-end (car svl2)))) + (cond ((<= e1 s2) (loop (cdr svl1) svl2)) + ((<= e2 s1) (loop svl1 (cdr svl2))) + (else + (cons (make-segment (max s1 s2) (min e1 e2)) + (cond ((< e1 e2) + (loop (cdr svl1) svl2)) + ((> e1 e2) + (loop svl1 (cdr svl2))) + (else + (loop (cdr svl1) (cdr svl2)))))))) + '()))) + +(define-test 'difference + (make-binary-test 'CHAR-SET-DIFFERENCE + char-set-difference + (lambda (svl1 svl2) + (named-call 'SVL-DIFFERENCE svl-difference svl1 svl2)))) + +(define (svl-difference svl1 svl2) + (let loop ((svl1 svl1) (svl2 svl2)) + (if (pair? svl1) + (if (pair? svl2) + (let ((s1 (segment-start (car svl1))) + (e1 (segment-end (car svl1))) + (s2 (segment-start (car svl2))) + (e2 (segment-end (car svl2)))) + (cond ((<= e1 s2) + (cons (car svl1) + (loop (cdr svl1) svl2))) + ((<= e2 s1) + (loop svl1 (cdr svl2))) + (else + (let ((tail + (cond ((< e1 e2) + (loop (cdr svl1) + (cons (make-segment e1 e2) + (cdr svl2)))) + ((= e1 e2) + (loop (cdr svl1) (cdr svl2))) + (else + (loop (cons (make-segment e2 e1) + (cdr svl1)) + (cdr svl2)))))) + (if (< s1 s2) + (cons (make-segment s1 s2) tail) + tail))))) + svl1) + '()))) + +(define (assert-equal-canonical-svls svl1 svl2) + (list (assert-canonical-svl svl1) + (assert-canonical-svl svl2) + (assert-equal svl1 svl2))) + +(define (assert-canonical-svl svl) + (assert-true `(CANONICAL-SVL? ,svl) + (canonical-svl? svl))) + +(define (named-call name operation . args) + (with-test-properties (lambda () (apply operation args)) + 'EXPRESSION (cons name args))) (define (canonical-svl? items) (and (list-of-type? items @@ -77,19 +266,80 @@ USA. (every-tail (lambda (tail) (if (and (pair? tail) (pair? (cdr tail))) - (< (let ((a (car tail))) - (if (pair? a) - (cdr a) - (+ a 1))) - (let ((b (cadr tail))) - (if (pair? b) - (car b) - b))) + (< (segment-end (car tail)) + (segment-start (cadr tail))) #t)) items))) +(define (make-segment start end) + (if (= (- end start) 1) + start + (cons start end))) + +(define (segment-start segment) + (if (pair? segment) + (car segment) + segment)) + +(define (segment-end segment) + (if (pair? segment) + (cdr segment) + (+ segment 1))) + +(define (append-map-tail! procedure items) + (if (pair? items) + (append! (procedure items) + (append-map-tail! procedure (cdr items))) + '())) + (define (every-tail pred items) (if (pair? items) (and (pred items) (every-tail pred (cdr items))) - (pred items))) \ No newline at end of file + (pred items))) + +(define interesting-points + (list 0 + 1 + (- %low-limit 1) + %low-limit + (+ %low-limit 1) + (- char-code-limit 1) + char-code-limit)) + +(define (mapper->generator mapper) + (lambda (points) + (let loop ((points points)) + (if (pair? points) + (append! (mapper (car points) (cdr points)) + (loop (cdr points))) + '())))) + +(define 1-generator + (mapper->generator + (lambda (start ends) + (map (lambda (end) + (list (make-segment start end))) + ends)))) + +(define (n+1-generator n-generator) + (mapper->generator + (lambda (start tails) + (append-map-tail! (lambda (tail) + (let ((segment (make-segment start (car tail)))) + (map (lambda (segments) + (cons segment segments)) + (n-generator (cdr tail))))) + tails)))) + +(define 2-generator + (n+1-generator 1-generator)) + +(define 3-generator + (n+1-generator 2-generator)) + +(define interesting-svls + (cons (list) + (append! (1-generator interesting-points) + (2-generator interesting-points) + (3-generator interesting-points)))) \ No newline at end of file diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index 5e1ff9219..1b1d2ef58 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -27,10 +27,22 @@ USA. (declare (usual-integrations)) +(define (run-unit-test filename/s test-name #!optional environment) + (let ((port (notification-output-port))) + (let ((tests (load-unit-tests filename/s environment))) + (let ((test (assq test-name tests))) + (if (not test) + (error "Unknown test name:" test-name (map car tests))) + (run-and-report test port))))) + (define (run-unit-tests filename/s #!optional environment) - (report-results - (map run-unit-test - (load-unit-tests filename/s environment)))) + (let ((port (notification-output-port)) + (pass? #t)) + (for-each (lambda (test) + (if (not (run-and-report test port)) + (set! pass? #f))) + (load-unit-tests filename/s environment)) + pass?)) (define (load-unit-tests filename/s #!optional environment) (let ((test-environment (make-test-environment! environment))) @@ -61,12 +73,47 @@ USA. test-definitions) test-environment)) -(define (run-unit-test name.test) - (cons (car name.test) - (append-map! (lambda (named-sub-test) - (name-and-flatten (car named-sub-test) - (cdr named-sub-test))) - (run-sub-tests (name-and-flatten "" (cdr name.test)))))) +(define-syntax define-for-tests + (er-macro-transformer + (lambda (form rename compare) + compare + (receive (name value) + (parse-define-form form rename) + `(,(rename 'BEGIN) + (,(rename 'DEFINE) ,name ,value) + (,(rename 'ADD-TEST-DEFINITION) ',name ,name)))))) + +(define (add-test-definition name value) + (let ((p (assq name test-definitions))) + (if p + (set-cdr! p value) + (begin + (set! test-definitions (cons (cons name value) test-definitions)) + unspecific)))) + +(define test-definitions '()) + +(define-for-tests (define-test name test . tests) + (register-test name + (if (null? tests) + test + (cons test tests))) + name) + +;;;; Test runner + +(define (run-and-report name.test port) + (let ((start-time (process-time-clock))) + (let ((results + (append-map! (lambda (named-sub-test) + (name-and-flatten (car named-sub-test) + (cdr named-sub-test))) + (run-sub-tests (name-and-flatten "" (cdr name.test)))))) + (report-result (car name.test) + (internal-time/ticks->seconds + (- (process-time-clock) start-time)) + results + port)))) (define (run-sub-tests named-sub-tests) ;; Runs sub-tests in left-to-right order. @@ -74,7 +121,7 @@ USA. (if (pair? named-sub-tests) (loop (cdr named-sub-tests) (cons (cons (caar named-sub-tests) - (run-test-thunk (cdar named-sub-tests))) + ((cdar named-sub-tests))) results)) (reverse! results)))) @@ -94,57 +141,44 @@ USA. (if (list? items) (append-map! flatten items) (list items))) - -(define (run-test-thunk thunk) - (call-with-current-continuation - (lambda (k) - (bind-condition-handler (list condition-type:error) - (lambda (condition) - (k (make-failure 'CONDITION condition))) - thunk)))) -(define (report-results results) - (fold (lambda (a b) (and a b)) - #t - (let ((port (notification-output-port))) - (map (lambda (result) - (report-result-group (car result) (cdr result) port)) - results)))) - -(define (report-result-group test-name sub-test-results port) - (let ((n-sub-test-results (length sub-test-results))) - (cond ((> n-sub-test-results 1) - (let ((n-failed (count failing-sub-test? sub-test-results))) - (write test-name port) - (write-string ": " port) - (if (> n-failed 0) - (begin - (write-string "failed " port) - (write n-failed port) - (write-string " sub-tests out of " port) - (write n-sub-test-results port) - (write-string ":" port) - (newline port) - (for-each - (lambda (sub-test-result) - (if (failing-sub-test? sub-test-result) - (report-test-failure " " - (car sub-test-result) - (cdr sub-test-result) - port))) - sub-test-results)) - (begin - (write-string "passed " port) - (write n-sub-test-results port) - (write-string " sub-tests" port) - (newline port))))) - ((> n-sub-test-results 0) - (report-test-failure "" - (write-to-string test-name) - (cdar sub-test-results) - port)))) +;;;; Reporting + +(define (report-result test-name elapsed-time sub-test-results port) + (let ((n-sub-test-results (length sub-test-results)) + (n-failed (count failing-sub-test? sub-test-results))) + (write test-name port) + (write-string ": " port) + (if (> n-failed 0) + (begin + (write-string "failed " port) + (write n-failed port) + (write-string " sub-tests out of " port) + (write n-sub-test-results port) + (report-test-time elapsed-time port) + (write-string ":" port) + (newline port) + (for-each + (lambda (sub-test-result) + (if (failing-sub-test? sub-test-result) + (report-test-failure " " + (car sub-test-result) + (cdr sub-test-result) + port))) + sub-test-results)) + (begin + (write-string "passed " port) + (write n-sub-test-results port) + (write-string " sub-tests" port) + (report-test-time elapsed-time port) + (newline port)))) (every passing-sub-test? sub-test-results)) +(define (report-test-time elapsed-time port) + (write-string " in " port) + (write elapsed-time port) + (write-string " seconds" port)) + (define (report-test-failure prefix name failure port) (write-string prefix port) (write-string name port) @@ -160,6 +194,12 @@ USA. (define (passing-sub-test? sub-test-result) (not (cdr sub-test-result))) +(define condition-type:failure + (make-condition-type 'FAILURE #f '(FAILURE) #f)) + +(define condition-failure + (condition-accessor condition-type:failure 'FAILURE)) + (define-record-type (%make-failure alist) failure? @@ -168,6 +208,11 @@ USA. (define (make-failure . plist) (%make-failure (keyword-list->alist plist))) +(define (extend-failure failure plist) + (%make-failure + (append (failure-alist failure) + (keyword-list->alist plist)))) + (define (failure-property key failure) (assq key (failure-alist failure))) @@ -221,69 +266,94 @@ USA. (else (error "Ill-formed failure:" failure)))) -(define-syntax define-for-tests - (er-macro-transformer - (lambda (form rename compare) - compare - (receive (name value) - (parse-define-form form rename) - `(,(rename 'BEGIN) - (,(rename 'DEFINE) ,name ,value) - (,(rename 'ADD-TEST-DEFINITION) ',name ,name)))))) +;;;; Assertions -(define (add-test-definition name value) - (let ((p (assq name test-definitions))) - (if p - (set-cdr! p value) - (begin - (set! test-definitions (cons (cons name value) test-definitions)) - unspecific)))) +(define-for-tests (run-sub-test thunk) + (call-with-current-continuation + (lambda (k) + (bind-condition-handlers + (list condition-type:failure + (lambda (condition) + (k (access-condition condition 'FAILURE))) + condition-type:error + (lambda (condition) + (if (not throw-test-errors?) + (k (make-failure 'CONDITION condition))))) + (lambda () + (thunk) + #f))))) + +(define-for-tests (with-test-properties thunk . properties) + (bind-condition-handlers + (list condition-type:failure + (lambda (condition) + (error + (remake-failure-condition + condition + (extend-failure (condition-failure condition) + properties)))) + condition-type:error + (lambda (condition) + (if (not throw-test-errors?) + (apply fail 'CONDITION condition properties)))) + thunk)) -(define test-definitions '()) +(define throw-test-errors? #f) -(define-for-tests (define-test name test . tests) - (register-test name - (if (null? tests) - test - (cons test tests))) - name) +(define (bind-condition-handlers bindings thunk) + (if (pair? bindings) + (bind-condition-handler (list (car bindings)) + (cadr bindings) + (lambda () + (bind-condition-handlers (cddr bindings) thunk))) + (thunk))) + +(define-for-tests (fail . plist) + (call-with-current-continuation + (lambda (continuation) + (error + (make-failure-condition continuation + (apply make-failure plist)))))) + +(define (make-failure-condition continuation failure) + (make-condition condition-type:failure + continuation + 'BOUND-RESTARTS + (list 'FAILURE failure))) + +(define (remake-failure-condition condition failure) + (make-condition condition-type:failure + (condition/continuation condition) + (condition/restarts condition) + (list 'FAILURE failure))) + +(define-for-tests (assert predicate description value . properties) + (%assert predicate value description properties)) (define-for-tests (predicate-assertion predicate description) (lambda (value . properties) - (if (predicate value) - #f - (apply make-failure - 'RESULT-OBJECT value - 'EXPECTATION-DESCRIPTION description - properties)))) + (%assert predicate value description properties))) -(define-for-tests (assert predicate description value . properties) - (apply (predicate-assertion predicate description) - value - properties)) - -(define-for-tests (assert-true expr value) - (if value - #f - (make-failure 'EXPRESSION expr - 'RESULT-DESCRIPTION "false" - 'EXPECTATION-DESCRIPTION "true"))) - -(define-for-tests (assert-false expr value) - (if value - (make-failure 'EXPRESSION expr - 'RESULT-DESCRIPTION "true" - 'EXPECTATION-DESCRIPTION "false") - #f)) +(define (%assert predicate value description properties) + (if (not (predicate value)) + (apply fail + 'RESULT-OBJECT value + 'EXPECTATION-DESCRIPTION description + properties))) + +(define-for-tests assert-true + (predicate-assertion (lambda (x) x) "true")) + +(define-for-tests assert-false + (predicate-assertion not "false")) (define-for-tests assert-null (predicate-assertion null? "an empty list")) (define-for-tests (binary-assertion comparator) (lambda (value expected . properties) - (if (comparator value expected) - #f - (apply make-failure + (if (not (comparator value expected)) + (apply fail 'RESULT-OBJECT value 'EXPECTATION-OBJECT expected properties)))) @@ -302,7 +372,7 @@ USA. (define-for-tests (assert-error thunk condition-types . properties) (call-with-current-continuation (lambda (k) - (apply make-failure + (apply fail 'RESULT-OBJECT (bind-condition-handler condition-types (lambda (condition)