From 2985001a79e4939c397176861ceddc72430a8f7c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 2 Jun 2010 10:20:05 -0600 Subject: [PATCH] Fixing PR10950 --- collects/rackunit/private/check-info.rkt | 70 ++++++++++++------------ collects/rackunit/private/check.rkt | 2 +- collects/rackunit/private/location.rkt | 23 ++++---- collects/tests/rackunit/pr10950.rkt | 16 ++++++ 4 files changed, 65 insertions(+), 46 deletions(-) create mode 100644 collects/tests/rackunit/pr10950.rkt diff --git a/collects/rackunit/private/check-info.rkt b/collects/rackunit/private/check-info.rkt index f518b5e3ec..127c2cb493 100644 --- a/collects/rackunit/private/check-info.rkt +++ b/collects/rackunit/private/check-info.rkt @@ -1,12 +1,21 @@ #lang racket/base - -(provide (all-defined-out)) +(require racket/contract + "location.rkt" + (for-syntax racket/base + unstable/syntax)) ;; Structures -------------------------------------------------- ;; struct check-info : symbol any (define-struct check-info (name value)) +(provide/contract + [struct check-info ([name symbol?] + [value any/c])] + [check-info-mark symbol?] + [check-info-stack (continuation-mark-set? . -> . (listof check-info?))] + [with-check-info* ((listof check-info?) (-> any) . -> . any)]) +(provide with-check-info) ;; Infrastructure ---------------------------------------------- @@ -22,43 +31,34 @@ (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))) + check-info-mark + (append (if current-marks current-marks null) info) + (thunk))) (define-syntax with-check-info (syntax-rules () [(_ ((name val) ...) body ...) (with-check-info* - (list (make-check-info name val) ...) - (lambda () body ...))])) + (list (make-check-info name val) ...) + (lambda () body ...))])) -(define (make-check-name name) - (make-check-info 'name name)) -(define (make-check-params params) - (make-check-info 'params params)) -(define (make-check-location stx) - (make-check-info 'location stx)) -(define (make-check-expression msg) - (make-check-info 'expression msg)) -(define (make-check-message msg) - (make-check-info 'message msg)) -(define (make-check-actual param) - (make-check-info 'actual param)) -(define (make-check-expected param) - (make-check-info 'expected param)) +(define-syntax (define-check-type stx) + (syntax-case stx () + [(_ id contract) + (with-syntax + ([make-check-id (format-id #'id "make-check-~a" #'id)] + [check-id? (format-id #'id "check-~a?" #'id)]) + (syntax/loc stx + (begin (define (make-check-id a) (make-check-info 'id a)) + (define (check-id? info) (eq? (check-info-name info) 'id)) + (provide/contract + [make-check-id (contract . -> . check-info?)] + [check-id? (check-info? . -> . boolean?)]))))])) -(define (check-name? info) - (eq? (check-info-name info) 'name)) -(define (check-params? info) - (eq? (check-info-name info) 'params)) -(define (check-location? info) - (eq? (check-info-name info) 'location)) -(define (check-expression? info) - (eq? (check-info-name info) 'expression)) -(define (check-message? info) - (eq? (check-info-name info) 'message)) -(define (check-actual? info) - (eq? (check-info-name info) 'actual)) -(define (check-expected? info) - (eq? (check-info-name info) 'expected)) +(define-check-type name any/c) +(define-check-type params any/c) +(define-check-type location location/c) +(define-check-type expression any/c) +(define-check-type message any/c) +(define-check-type actual any/c) +(define-check-type expected any/c) diff --git a/collects/rackunit/private/check.rkt b/collects/rackunit/private/check.rkt index 2e504a532c..c67285d449 100644 --- a/collects/rackunit/private/check.rkt +++ b/collects/rackunit/private/check.rkt @@ -119,7 +119,7 @@ (syntax (lambda (formal ... [message #f] - #:location [location 'unknown] + #:location [location (list 'unknown #f #f #f #f)] #:expression [expression 'unknown]) ((current-check-around) (lambda () diff --git a/collects/rackunit/private/location.rkt b/collects/rackunit/private/location.rkt index 2a9fa1b480..cace08e174 100644 --- a/collects/rackunit/private/location.rkt +++ b/collects/rackunit/private/location.rkt @@ -1,17 +1,10 @@ #lang racket/base - -(require racket/list) - -(provide location-source - location-line - location-column - location-position - location-span - syntax->location - location->string) +(require racket/list + racket/contract) ;; type location = (list any number/#f number/#f number/#f number/#f) ;; location : source line column position span +(define location/c (list/c any/c (or/c number? false/c) (or/c number? false/c) (or/c number? false/c) (or/c number? false/c))) (define location-source first) (define location-line second) @@ -19,6 +12,16 @@ (define location-position fourth) (define location-span fifth) +(provide/contract + [location/c contract?] + [location-source (location/c . -> . any/c)] + [location-line (location/c . -> . (or/c number? false/c))] + [location-column (location/c . -> . (or/c number? false/c))] + [location-position (location/c . -> . (or/c number? false/c))] + [location-span (location/c . -> . (or/c number? false/c))] + [syntax->location (syntax? . -> . location/c)] + [location->string (location/c . -> . string?)]) + ;; syntax->location : syntax -> location (define (syntax->location stx) (list (syntax-source stx) diff --git a/collects/tests/rackunit/pr10950.rkt b/collects/tests/rackunit/pr10950.rkt new file mode 100644 index 0000000000..1663aaaeb9 --- /dev/null +++ b/collects/tests/rackunit/pr10950.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require rackunit + rackunit/text-ui + racket/port + tests/eli-tester) + +(test + (with-output-to-string + (lambda () + (parameterize ([current-error-port (current-output-port)]) + (define-check (check3) + (fail-check)) + + (run-tests (test-suite "tests" (let ((foo check3)) (foo))))))) + => + "--------------------\ntests > #f\nUnnamed test \nFAILURE\nname: check3\nlocation: unknown:?:?\nparams: \n--------------------\n0 success(es) 1 failure(s) 0 error(s) 1 test(s) run\n") \ No newline at end of file