From 7b5753163c42dbfbd70721b20f193e20d67c2129 Mon Sep 17 00:00:00 2001 From: Noel Welsh Date: Thu, 11 Jun 2009 16:22:55 +0000 Subject: [PATCH] Install the check-info stack in continuation marks. This means that if an exception is thrown within a check some useful information about that check (e.g. name, location) can still be extracted. svn: r15147 --- collects/schemeunit/all-schemeunit-tests.ss | 1 + collects/schemeunit/check-info-test.ss | 6 +- collects/schemeunit/check-info.ss | 29 ++++---- collects/schemeunit/check.ss | 22 +++--- collects/schemeunit/text-ui.ss | 82 +++++++++++---------- 5 files changed, 74 insertions(+), 66 deletions(-) diff --git a/collects/schemeunit/all-schemeunit-tests.ss b/collects/schemeunit/all-schemeunit-tests.ss index e296beaab8..83291e9a05 100644 --- a/collects/schemeunit/all-schemeunit-tests.ss +++ b/collects/schemeunit/all-schemeunit-tests.ss @@ -50,5 +50,6 @@ (test-case "Also intended to fail" (check-eq? 'apples 'orange)) (test-equal? "Yet again intended to fail" "apples" "oranges") (test-case "Intended to throw error" (error 'testing "<>")) + (test-case "Error within a check" (check error 'foo 'bar)) )) diff --git a/collects/schemeunit/check-info-test.ss b/collects/schemeunit/check-info-test.ss index b578a061fa..2d00365c2d 100644 --- a/collects/schemeunit/check-info-test.ss +++ b/collects/schemeunit/check-info-test.ss @@ -1,6 +1,6 @@ ;;; ;;; ---- Tests for check-util -;;; Time-stamp: <2008-06-19 21:04:14 noel> +;;; Time-stamp: <2009-06-11 17:03:21 noel> ;;; ;;; Copyright (C) 2003 by Noel Welsh. ;;; @@ -40,7 +40,7 @@ (('1 1) ('2 2) ('3 3)) - (check-info-stack)))) + (check-info-stack (current-continuation-marks))))) (for-each (lambda (actual expected) (check-eq? (check-info-name actual) expected)) @@ -57,7 +57,7 @@ (('4 4) ('5 5) ('6 6)) - (check-info-stack))))) + (check-info-stack (current-continuation-marks)))))) (for-each (lambda (actual expected) (check-eq? (check-info-name actual) expected)) diff --git a/collects/schemeunit/check-info.ss b/collects/schemeunit/check-info.ss index dda1c4993a..efea4e9a26 100644 --- a/collects/schemeunit/check-info.ss +++ b/collects/schemeunit/check-info.ss @@ -10,29 +10,28 @@ ;; Infrastructure ---------------------------------------------- -;; parameter check-info-stack : (listof check-info) -(define check-info-stack - (make-parameter - (list) - (lambda (v) - (if (list? v) - v - (raise-type-error 'check-info-stack "list" v))))) +;; The continuation mark under which all check-info is keyed +(define check-info-mark (gensym 'schemeunit)) + +;; (continuation-mark-set -> (listof check-info)) +(define (check-info-stack marks) + (apply append (continuation-mark-set->list marks check-info-mark))) ;; with-check-info* : (list-of check-info) thunk -> any (define (with-check-info* info thunk) - (parameterize - ((check-info-stack (append (check-info-stack) info))) - (thunk))) + (define current-marks + (continuation-mark-set-first #f check-info-mark)) + (with-continuation-mark + check-info-mark + (append (if current-marks current-marks null) info) + (thunk))) (define-syntax with-check-info (syntax-rules () - ((_ ((name val) ...) body ...) + [(_ ((name val) ...) body ...) (with-check-info* (list (make-check-info name val) ...) - (lambda () - body ...))))) - + (lambda () body ...))])) (define (make-check-name name) (make-check-info 'name name)) diff --git a/collects/schemeunit/check.ss b/collects/schemeunit/check.ss index af1219b51d..fe38c48a61 100644 --- a/collects/schemeunit/check.ss +++ b/collects/schemeunit/check.ss @@ -75,20 +75,22 @@ (define-syntax fail-check (syntax-rules () ((_) - (raise - (make-exn:test:check - "Check failure" - (current-continuation-marks) - (check-info-stack)))))) + (let ([marks (current-continuation-marks)]) + (raise + (make-exn:test:check + "Check failure" + marks + (check-info-stack marks))))))) (define-syntax fail-internal (syntax-rules () ((_) - (raise - (make-exn:test:check:internal - "Internal failure" - (current-continuation-marks) - (check-info-stack)))))) + (let ([marks (current-continuation-marks)]) + (raise + (make-exn:test:check:internal + "Internal failure" + marks + (check-info-stack marks))))))) ;; refail-check : exn:test:check -> (exception raised) ;; diff --git a/collects/schemeunit/text-ui.ss b/collects/schemeunit/text-ui.ss index 8b8edb3f01..e71391f7e5 100644 --- a/collects/schemeunit/text-ui.ss +++ b/collects/schemeunit/text-ui.ss @@ -1,5 +1,5 @@ ;;; -;;; Time-stamp: <2008-08-08 21:38:07 noel> +;;; Time-stamp: <2009-06-11 17:11:22 noel> ;;; ;;; Copyright (C) 2005 by Noel Welsh. ;;; @@ -39,6 +39,7 @@ "location.ss" "result.ss" "test.ss" + "check-info.ss" "monad.ss" "hash-monad.ss" "name-collector.ss" @@ -127,45 +128,50 @@ [(test-failure? result) (let* ([exn (test-failure-result result)] [stack (exn:test:check-stack exn)]) - (for-each - (lambda (info) - (cond - [(check-name? info) - (display-check-info info)] - [(check-location? info) - (display-check-info-name-value - 'location - (trim-current-directory - (location->string - (check-info-value info))) - display)] - [(check-params? info) - (display-check-info-name-value - 'params - (check-info-value info) - (lambda (v) (map pretty-print v)))] - [(check-actual? info) - (display-check-info-name-value - 'actual - (check-info-value info) - pretty-print)] - [(check-expected? info) - (display-check-info-name-value - 'expected - (check-info-value info) - pretty-print)] - [(and (check-expression? info) - (not verbose?)) - (void)] - [else - (display-check-info info)])) - (if verbose? - stack - (strip-redundant-params stack))))] + (textui-display-check-info-stack stack verbose?))] [(test-error? result) - (display-exn (test-error-result result))] + (let ([exn (test-error-result result)]) + (textui-display-check-info-stack (check-info-stack (exn-continuation-marks exn))) + (display-exn exn))] [else (void)])) - + +(define (textui-display-check-info-stack stack [verbose? #f]) + (for-each + (lambda (info) + (cond + [(check-name? info) + (display-check-info info)] + [(check-location? info) + (display-check-info-name-value + 'location + (trim-current-directory + (location->string + (check-info-value info))) + display)] + [(check-params? info) + (display-check-info-name-value + 'params + (check-info-value info) + (lambda (v) (map pretty-print v)))] + [(check-actual? info) + (display-check-info-name-value + 'actual + (check-info-value info) + pretty-print)] + [(check-expected? info) + (display-check-info-name-value + 'expected + (check-info-value info) + pretty-print)] + [(and (check-expression? info) + (not verbose?)) + (void)] + [else + (display-check-info info)])) + (if verbose? + stack + (strip-redundant-params stack)))) + ;; display-verbose-check-info : test-result -> void (define (display-verbose-check-info result) (cond