Make tc-l test cases give better error messages.

original commit: 83d39a50b86500c26627db76e71f8efc03b2a8e2

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt

@@ -1,8 +1,37 @@
 #lang racket/base
 
+(module cross-phase-failure racket/base
+  (require
+    rackunit
+    racket/contract)
+
+  (provide
+    (contract-out
+      [rename cross-phase-failure* cross-phase-failure
+        (->* (string?) (#:actual any/c #:expected any/c) cross-phase-failure?)]
+      [cross-phase-failure? predicate/c]
+      [cross-phase-failure-message (-> cross-phase-failure? string?)]
+      [rename cross-phase-failure-check-infos* cross-phase-failure-check-infos
+        (-> cross-phase-failure? (listof check-info?))]))
+
+  (struct cross-phase-failure (message check-infos) #:prefab)
+
+  (define no-arg (gensym 'no-arg))
+
+  (define (cross-phase-failure* message #:actual [actual no-arg] #:expected [expected no-arg])
+    (cross-phase-failure
+      message
+      (append
+        (if (eq? actual no-arg) null (list (list 'actual actual)))
+        (if (eq? expected no-arg) null (list (list 'expected expected))))))
+
+  (define (cross-phase-failure-check-infos* cpf)
+    (map (λ (args) (apply check-info args)) (cross-phase-failure-check-infos cpf))))
+
 ;; Functions for testing correct behavior of typechecking
 (module tester racket/base
   (require
+    (submod ".." cross-phase-failure)
     typed-racket/utils/utils
     racket/base
     syntax/parse
@@ -10,7 +39,9 @@
     (typecheck typechecker)
     (utils mutated-vars)
     (env mvar-env))
-  (provide test-literal test test/proc tc tc-literal tr-expand)
+  (provide
+    test-literal test-literal/fail
+    test test/proc test/fail)
 
 
   (do-standard-inits)
@@ -43,20 +74,59 @@
     (define result (tc expanded-expr expected))
     (define golden (golden-fun expanded-expr))
     (unless (equal? golden result)
-      (error 'test "failed: ~a != ~a" golden result)))
+      (raise (cross-phase-failure
+               #:actual result
+               #:expected golden
+               "tc-expr did not return the expected value"))))
 
-  ;; test/literal syntax? tc-results? [(option/c tc-results?)] -> void?
+  ;; test/fail syntax? (or/c string? regexp?) (option/c tc-results?) -> void?
+  ;; Checks that the expression doesn't typecheck using the expected type and the golden message
+  (define (test/fail code message expected)
+    (with-handlers ([exn:fail:syntax?
+                     (lambda (exn)
+                       (when message
+                         (unless (regexp-match? message (exn-message exn))
+                           (raise (cross-phase-failure
+                                    #:actual (exn-message exn)
+                                    #:expected message
+                                    "tc-expr raised the wrong error message")))))])
+      (define result (tc (tr-expand code) expected))
+      (raise (cross-phase-failure
+               #:actual result
+               "tc-expr did not raise an error"))))
+
+
+  ;; test-literal syntax? tc-results? (option/c tc-results?) -> void?
   ;; Checks that the literal typechecks using the expected type to the golden result.
   (define (test-literal literal golden expected)
     (define result (tc-literal literal expected))
     (unless (equal? golden result)
-      (error 'test "failed: ~a != ~a" golden result))))
+      (raise (cross-phase-failure
+               #:actual result
+               #:expected golden
+               "tc-literal did not return the expected value"))))
+
+  ;; test-literal/fail syntax? (or/c string? regexp?) (option/c tc-results?) -> void?
+  ;; Checks that the literal doesn't typecheck using the expected type and the golden message
+  (define (test-literal/fail literal message expected)
+    (with-handlers ([exn:fail:syntax?
+                     (lambda (exn)
+                       (unless (regexp-match? message (exn-message exn))
+                         (raise (cross-phase-failure
+                                  #:actual (exn-message exn)
+                                  #:expected message
+                                  "tc-literal raised the wrong error message"))))])
+      (define result (tc-literal literal expected))
+      (raise (cross-phase-failure
+               #:actual result
+               "tc-literal did not raise an error")))))
 
 
 (require
+  'cross-phase-failure
   "evaluator.rkt"
   (except-in "test-utils.rkt" private)
-  syntax/location
+  syntax/location syntax/srcloc
   (for-syntax
     racket/base
     syntax/parse
@@ -90,32 +160,34 @@
   ;; for specifying the error message in a test
   (define-splicing-syntax-class expected-msg
     (pattern (~seq #:msg v:expr))
-    (pattern (~seq) #:attr v #'#f))
+    (pattern (~seq) #:attr v #'#f)))
 
-
-  (define (test-no-error stx name body)
-    (quasisyntax/loc stx
-      (test-not-exn (format "~a ~a" (quote-line-number #,name) '#,name)
-        (lambda () #,body))))
-
-  (define (test-syntax-error stx name msg body)
-    (quasisyntax/loc stx
-      (test-exn (format "~a ~a" (quote-line-number #,name) '#,name)
-        (λ (exn) (and (exn:fail:syntax? exn)
-                      (or (not #,msg)
-                          (regexp-match? #,msg (exn-message exn)))))
-        (lambda () #,body)))))
+(define-syntax (test-phase1 stx)
+  (syntax-parse stx
+    ([_ name:expr body:expr ...]
+     (quasisyntax/loc stx
+       (test-case (format "~a ~a" (quote-line-number name) 'name)
+         (with-check-info (['location (build-source-location-list (quote-srcloc #,stx))])
+           (with-handlers ([cross-phase-failure?
+                            (λ (tf)
+                              (with-check-info*
+                                (cross-phase-failure-check-infos tf)
+                                (lambda ()
+                                  (fail-check (cross-phase-failure-message tf)))))])
+             (phase1-eval body ...))))))))
 
 
 ;;Constructs the syntax that calls eval and returns the answer to the user
 (define-syntax (tc-e stx)
   (syntax-parse stx
     [(_ code:expr #:proc p)
-     (test-no-error stx #'code
-       #'(phase1-eval (test/proc (quote-syntax code) p)))]
-    [(_ code:expr return:return x:expected)
-     (test-no-error stx #'code
-       #'(phase1-eval (test (quote-syntax code) return.v x.v)))]))
+     (quasisyntax/loc stx
+       (test-phase1 code
+         (test/proc (quote-syntax code) p)))]
+    [(_ code:expr return:return ex:expected)
+     (quasisyntax/loc stx
+       (test-phase1 code
+         (test (quote-syntax code) return.v ex.v)))]))
 
 (define-syntax (tc-e/t stx)
   (syntax-parse stx
@@ -125,23 +197,25 @@
 (define-syntax (tc-l stx)
   (syntax-parse stx
     [(_ lit ty exp:expected)
-     (test-no-error stx (syntax/loc #'lit (LITERAL lit))
-       #'(phase1-eval (test-literal #'lit ty exp.v)))]))
+     (quasisyntax/loc stx
+       (test-phase1 #,(syntax/loc #'lit (LITERAL lit))
+         (test-literal (quote-syntax lit) ty exp.v)))]))
 
 
 ;; check that typechecking this expression fails
 (define-syntax (tc-err stx)
   (syntax-parse stx
     [(_ code:expr ex:expected msg:expected-msg)
-     (test-syntax-error stx (syntax/loc #'code (FAIL code)) #'msg.v
-       #'(phase1-eval (tc (tr-expand (quote-syntax code)) ex.v)))]))
+     (quasisyntax/loc stx
+        (test-phase1 #,(syntax/loc #'code (FAIL code))
+           (test/fail (quote-syntax code) msg.v ex.v)))]))
 
 (define-syntax (tc-l/err stx)
   (syntax-parse stx
     [(_ lit:expr ex:expected msg:expected-msg)
-     (test-syntax-error stx #'(syntax/loc #'lit (LITERAL/FAIL lit)) #'msg.v
-       #'(phase1-eval (tc-literal #'lit ex.v)))]))
-
+     (quasisyntax/loc stx
+       (test-phase1 #,(syntax/loc #'lit (LITERAL/FAIL lit))
+         (test-literal/fail (quote-syntax lit) msg.v ex.v)))]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;