Fixing PR10950

collects/rackunit/private/check-info.rkt

@@ -1,12 +1,21 @@
 #lang racket/base
-
+(require racket/contract
-(provide (all-defined-out))
+         "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
+      check-info-mark
-   (append (if current-marks current-marks null) info)
+    (append (if current-marks current-marks null) info)
-   (thunk)))
+    (thunk)))
 
 (define-syntax with-check-info
   (syntax-rules ()
     [(_ ((name val) ...) body ...)
      (with-check-info*
-      (list (make-check-info name val) ...)
+         (list (make-check-info name val) ...)
-      (lambda () body ...))]))
+       (lambda () body ...))]))
 
-(define (make-check-name name)
+(define-syntax (define-check-type stx)
-  (make-check-info 'name name))
+  (syntax-case stx ()
-(define (make-check-params params)
+    [(_ id contract)
-  (make-check-info 'params params))
+     (with-syntax
-(define (make-check-location stx)
+         ([make-check-id (format-id #'id "make-check-~a" #'id)]
-  (make-check-info 'location stx))
+          [check-id? (format-id #'id "check-~a?" #'id)])
-(define (make-check-expression msg)
+       (syntax/loc stx
-  (make-check-info 'expression msg))
+         (begin (define (make-check-id a) (make-check-info 'id a))
-(define (make-check-message msg)
+                (define (check-id? info) (eq? (check-info-name info) 'id))
-  (make-check-info 'message msg))
+                (provide/contract
-(define (make-check-actual param)
+                 [make-check-id (contract . -> . check-info?)]
-  (make-check-info 'actual param))
+                 [check-id? (check-info? . -> . boolean?)]))))]))
-(define (make-check-expected param)
-  (make-check-info 'expected param))
 
-(define (check-name? info)
+(define-check-type name any/c)
-  (eq? (check-info-name info) 'name))
+(define-check-type params any/c)
-(define (check-params? info)
+(define-check-type location location/c)
-  (eq? (check-info-name info) 'params))
+(define-check-type expression any/c)
-(define (check-location? info)
+(define-check-type message any/c)
-  (eq? (check-info-name info) 'location))
+(define-check-type actual any/c)
-(define (check-expression? info)
+(define-check-type expected any/c)
-  (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))

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 ()

collects/rackunit/private/location.rkt

@@ -1,17 +1,10 @@
 #lang racket/base
-
+(require racket/list
-(require racket/list)
+         racket/contract)
-
-(provide location-source
-         location-line
-         location-column
-         location-position
-         location-span
-         syntax->location
-         location->string)
 
 ;; 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)

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")