From 256b660a15f15fcbfcc404da2b51494199a625d1 Mon Sep 17 00:00:00 2001
From: AlexKnauth <alexander@knauth.org>
Date: Tue, 7 Jun 2016 15:58:17 -0400
Subject: [PATCH] fix typecheck-fail to use check-exn correctly and fix all the
 broken tests

---
 tapl/stlc+reco+var.rkt               |  2 +-
 tapl/tests/exist-tests.rkt           |  4 ++--
 tapl/tests/rackunit-typechecking.rkt | 27 ++++++++++-----------------
 tapl/tests/stlc+box-tests.rkt        |  8 ++++----
 tapl/tests/stlc+cons-tests.rkt       | 12 ++++++------
 tapl/tests/stlc+effect-tests.rkt     |  8 ++++----
 tapl/tests/stlc+lit-tests.rkt        |  2 +-
 tapl/tests/stlc+rec-iso-tests.rkt    |  6 +++---
 tapl/tests/stlc+reco+var-tests.rkt   | 14 +++++++-------
 tapl/tests/sysf-tests.rkt            |  2 +-
 tapl/typecheck.rkt                   | 10 ++++++----
 11 files changed, 45 insertions(+), 50 deletions(-)

diff --git a/tapl/stlc+reco+var.rkt b/tapl/stlc+reco+var.rkt
index ef201e8..2975d0a 100644
--- a/tapl/stlc+reco+var.rkt
+++ b/tapl/stlc+reco+var.rkt
@@ -84,7 +84,7 @@
     [any
      (type-error #:src #'any
                  #:msg (string-append
-                        "Improper usage of type constructor ∨: ~a,"
+                        "Improper usage of type constructor ∨: ~a, "
                         "expected (∨ [label:id : τ:type] ...+)")
                  #'any)]))
 (begin-for-syntax
diff --git a/tapl/tests/exist-tests.rkt b/tapl/tests/exist-tests.rkt
index 9ec8114..3913a7b 100644
--- a/tapl/tests/exist-tests.rkt
+++ b/tapl/tests/exist-tests.rkt
@@ -179,11 +179,11 @@
 (typecheck-fail
  (pack (Int 1) as Int)
  #:with-msg
- "Expected type of expression to match pattern \\(∃ \\(\\(X)) τ_body), got: Int")
+ "Expected ∃ type, got: Int")
 (typecheck-fail
  (open ([(X x) <= 2]) 3)
  #:with-msg
- "Expected type of expression to match pattern \\(∃ \\(\\(X)) τ_body), got: Int")
+ "Expected expression 2 to have ∃ type, got: Int")
 
 ;; previous tets from stlc+reco+var-tests.rkt ---------------------------------
 ;; define-type-alias
diff --git a/tapl/tests/rackunit-typechecking.rkt b/tapl/tests/rackunit-typechecking.rkt
index bdb651a..64bff9a 100644
--- a/tapl/tests/rackunit-typechecking.rkt
+++ b/tapl/tests/rackunit-typechecking.rkt
@@ -70,26 +70,19 @@
      #:with msg:str 
             (eval-syntax (datum->syntax #'here (syntax->datum #'msg-pat)))
      #:when (with-check-info*
-             (list (make-check-location (build-source-location-list stx)))
+             (list (make-check-expected (syntax-e #'msg))
+                   (make-check-expression (syntax->datum stx))
+                   (make-check-location (build-source-location-list stx))
+                   (make-check-name 'typecheck-fail)
+                   (make-check-params (list (syntax->datum #'e) (syntax-e #'msg))))
              (λ ()
                (check-exn
-                (λ (ex) (or (exn:fail? ex) (exn:test:check? ex)))
+                (λ (ex)
+                  (and (or (exn:fail? ex) (exn:test:check? ex))
+                       ; check err msg matches
+                       (regexp-match? (syntax-e #'msg) (exn-message ex))))
                 (λ ()
-                  (with-handlers
-                      ; check err msg matches
-                      ([exn:fail?
-                        (λ (ex)
-                          (unless (regexp-match? (syntax-e #'msg) (exn-message ex))
-                            (printf
-                             (string-append
-                              "ERROR-MSG ERROR: wrong err msg produced by expression ~v:\n"
-                              "EXPECTED:\nmsg matching pattern ~v,\nGOT:\n~v\n")
-                             (syntax->datum #'e) (syntax-e #'msg) (exn-message ex)))
-                          (raise ex))])
-                    (expand/df #'e)))
-                (format
-                 "Expected type check failure but expression ~a has valid type, OR wrong err msg received."
-                 (syntax->datum #'e)))))
+                  (expand/df #'e)))))
      #'(void)]))
 
 (define-syntax (check-runtime-exn stx)
diff --git a/tapl/tests/stlc+box-tests.rkt b/tapl/tests/stlc+box-tests.rkt
index ba5e4f7..2e14b36 100644
--- a/tapl/tests/stlc+box-tests.rkt
+++ b/tapl/tests/stlc+box-tests.rkt
@@ -18,19 +18,19 @@
 (typecheck-fail
  (λ ([lst : (Ref Int Int)]) lst)
  #:with-msg
- "Improper usage of type constructor Ref: \\(Ref Int Int), expected pattern \\(Ref τ)")
+ "Improper usage of type constructor Ref: \\(Ref Int Int\\), expected = 1 arguments")
 (typecheck-fail
  (λ ([lst : (Ref)]) lst)
  #:with-msg
- "Improper usage of type constructor Ref: \\(Ref), expected pattern \\(Ref τ)")
+ "Improper usage of type constructor Ref: \\(Ref\\), expected = 1 arguments")
 (typecheck-fail
  (deref 1)
  #:with-msg
- "Expected type of expression.+to match pattern \\(Ref τ), got: Int")
+ "Expected expression 1 to have Ref type, got: Int")
 (typecheck-fail
  (:= 1 1)
  #:with-msg
- "Expected type of expression.+to match pattern \\(Ref τ), got: Int")
+ "Expected expression 1 to have Ref type, got: Int")
 
 ;; previous tests: ------------------------------------------------------------
 (typecheck-fail (cons 1 2))
diff --git a/tapl/tests/stlc+cons-tests.rkt b/tapl/tests/stlc+cons-tests.rkt
index 6d1052f..00857f1 100644
--- a/tapl/tests/stlc+cons-tests.rkt
+++ b/tapl/tests/stlc+cons-tests.rkt
@@ -2,7 +2,7 @@
 (require "rackunit-typechecking.rkt")
 
 (typecheck-fail (cons 1 2)
-                #:with-msg "Expected type with pattern: \\(List τ)")
+                #:with-msg "Expected expression 2 to have List type, got: Int")
 ;(typecheck-fail (cons 1 nil)
 ;                #:with-msg "nil: requires type annotation")
 (check-type (cons 1 nil) : (List Int))
@@ -15,15 +15,15 @@
 (typecheck-fail
  (nil (Int))
  #:with-msg
- "Improperly formatted type annotation: \\(Int); should have shape {τ}, where τ is a valid type.")
+ "Improperly formatted type annotation: \\(Int\\); should have shape {τ}, where τ is a valid type.")
 (typecheck-fail
  (λ ([lst : (List Int Int)]) lst)
  #:with-msg
- "Improper usage of type constructor List: \\(List Int Int), expected pattern \\(List τ)")
+ "Improper usage of type constructor List: \\(List Int Int\\), expected = 1 arguments")
 (typecheck-fail
  (λ ([lst : (List)]) lst)
  #:with-msg
- "Improper usage of type constructor List: \\(List), expected pattern \\(List τ)")
+ "Improper usage of type constructor List: \\(List\\), expected = 1 arguments")
 ;; passes bc ⇒-rhs is only used for its runtime value
 (check-type (nil {Int}) : (List Int) ⇒ (nil {Bool}))
 (check-not-type (nil {Bool}) : (List Int))
@@ -35,7 +35,7 @@
 (typecheck-fail
  (isnil (head fn-lst))
  #:with-msg
- "Expected type of expression \\(head fn-lst) to match pattern \\(List τ), got: \\(→ Int Int)")
+ "Expected expression \\(head fn-lst\\) to have List type, got: \\(→ Int Int\\)")
 (check-type (isnil (tail fn-lst)) : Bool ⇒ #t)
 (check-type (head fn-lst) : (→ Int Int))
 (check-type ((head fn-lst) 25) : Int ⇒ 35)
@@ -45,7 +45,7 @@
 (typecheck-fail
  (cons 1 1)
  #:with-msg
- "Expected type of expression to match pattern \\(List τ), got: Int")
+ "Expected expression 1 to have List type, got: Int")
 
 ;; previous tests: ------------------------------------------------------------
 ;; define-type-alias
diff --git a/tapl/tests/stlc+effect-tests.rkt b/tapl/tests/stlc+effect-tests.rkt
index 6b7821f..9ce7a73 100644
--- a/tapl/tests/stlc+effect-tests.rkt
+++ b/tapl/tests/stlc+effect-tests.rkt
@@ -24,19 +24,19 @@
 (typecheck-fail
  (λ ([lst : (Ref Int Int)]) lst)
  #:with-msg
- "Improper usage of type constructor Ref: \\(Ref Int Int), expected pattern \\(Ref τ)")
+ "Improper usage of type constructor Ref: \\(Ref Int Int\\), expected = 1 arguments")
 (typecheck-fail
  (λ ([lst : (Ref)]) lst)
  #:with-msg
- "Improper usage of type constructor Ref: \\(Ref), expected pattern \\(Ref τ)")
+ "Improper usage of type constructor Ref: \\(Ref\\), expected = 1 arguments")
 (typecheck-fail
  (deref 1)
  #:with-msg
- "Expected type of expression.+to match pattern \\(Ref τ), got: Int")
+ "Expected Ref type, got: Int")
 (typecheck-fail
  (:= 1 1)
  #:with-msg
- "Expected type of expression.+to match pattern \\(Ref τ), got: Int")
+ "Expected Ref type, got: Int")
 
 ;; previous tests: ------------------------------------------------------------
 (typecheck-fail (cons 1 2))
diff --git a/tapl/tests/stlc+lit-tests.rkt b/tapl/tests/stlc+lit-tests.rkt
index 46fb8c2..95f6bc7 100644
--- a/tapl/tests/stlc+lit-tests.rkt
+++ b/tapl/tests/stlc+lit-tests.rkt
@@ -22,7 +22,7 @@
  #:with-msg "Improper usage of type constructor →: →, expected >= 1 arguments")
 (typecheck-fail
  (λ ([x : (→)]) x)
- #:with-msg "Improper usage of type constructor →: \\(→), expected >= 1 arguments")
+ #:with-msg "Improper usage of type constructor →: \\(→\\), expected >= 1 arguments")
 
 (check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int))
 (check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1)
diff --git a/tapl/tests/stlc+rec-iso-tests.rkt b/tapl/tests/stlc+rec-iso-tests.rkt
index 371c3b2..905607e 100644
--- a/tapl/tests/stlc+rec-iso-tests.rkt
+++ b/tapl/tests/stlc+rec-iso-tests.rkt
@@ -56,11 +56,11 @@
 (typecheck-fail
  (fld {Int} 1)
  #:with-msg
- "Expected type of expression to match pattern \\(μ \\(\\(tv)) τ_body), got: Int")
+ "Expected μ type, got: Int")
 (typecheck-fail
  (unfld {Int} 1)
  #:with-msg
- "Expected type of expression to match pattern \\(μ \\(\\(tv)) τ_body), got: Int")
+ "Expected μ type, got: Int")
 
 ;; previous stlc+var tests ----------------------------------------------------
 ;; define-type-alias
@@ -157,7 +157,7 @@
 (typecheck-fail
  (proj 1 2)
  #:with-msg
- "Expected type of expression 1 to match pattern \\(× τ ...), got: Int")
+ "Expected expression 1 to have × type, got: Int")
 
 ;; ext-stlc.rkt tests ---------------------------------------------------------
 ;; should still pass
diff --git a/tapl/tests/stlc+reco+var-tests.rkt b/tapl/tests/stlc+reco+var-tests.rkt
index 60a54ca..7d07f44 100644
--- a/tapl/tests/stlc+reco+var-tests.rkt
+++ b/tapl/tests/stlc+reco+var-tests.rkt
@@ -109,25 +109,25 @@
  "Expected expression 1 to have ∨ type, got: Int")
 (typecheck-fail
  (λ ([x : (∨)]) x)
- #:with-msg "Improper usage of type constructor ∨: \\(∨), expected \\(∨ [label:id : τ:type] ...+)")
+ #:with-msg "Improper usage of type constructor ∨: \\(∨\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)")
 (typecheck-fail
  (λ ([x : (∨ 1)]) x)
- #:with-msg "Improper usage of type constructor ∨: \\(∨ 1\\), expected \\(∨ [label:id : τ:type] ...+)")
+ #:with-msg "Improper usage of type constructor ∨: \\(∨ 1\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)")
 (typecheck-fail
  (λ ([x : (∨ [1 2])]) x)
- #:with-msg "Improper usage of type constructor ∨: \\(∨ (1 2)), expected \\(∨ [label:id : τ:type] ...+)")
+ #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(1 2\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)")
 (typecheck-fail
  (λ ([x : (∨ [a 2])]) x)
- #:with-msg "Improper usage of type constructor ∨: \\(∨ (a 2)), expected \\(∨ [label:id : τ:type] ...+)")
+ #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(a 2\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)")
 (typecheck-fail
  (λ ([x : (∨ [a Int])]) x)
- #:with-msg "Improper usage of type constructor ∨: \\(∨ (a Int)), expected \\(∨ [label:id : τ:type] ...+)")
+ #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(a Int\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)")
 (typecheck-fail
  (λ ([x : (∨ [1 : Int])]) x)
- #:with-msg "Improper usage of type constructor ∨: \\(∨ (1 : Int)), expected \\(∨ [label:id : τ:type] ...+)")
+ #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(1 : Int\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)")
 (typecheck-fail
  (λ ([x : (∨ [a : 1])]) x)
- #:with-msg "Improper usage of type constructor ∨: \\(∨ (a : 1)), expected \\(∨ [label:id : τ:type] ...+)")
+ #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(a : 1\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)")
 
 ;; previous tuple tests: ------------------------------------------------------------
 ;; wont work anymore
diff --git a/tapl/tests/sysf-tests.rkt b/tapl/tests/sysf-tests.rkt
index 470f0e5..d349dd1 100644
--- a/tapl/tests/sysf-tests.rkt
+++ b/tapl/tests/sysf-tests.rkt
@@ -27,7 +27,7 @@
 (typecheck-fail
  (inst 1 Int)
  #:with-msg
- "Expected type of expression to match pattern \\(∀ \\(\\(x ...)) body), got: Int")
+ "Expected expression 1 to have ∀ type, got: Int")
 
 ;; polymorphic arguments
 (check-type (Λ (t) (λ ([x : t]) x)) : (∀ (t) (→ t t)))
diff --git a/tapl/typecheck.rkt b/tapl/typecheck.rkt
index 96f08fd..7522e84 100644
--- a/tapl/typecheck.rkt
+++ b/tapl/typecheck.rkt
@@ -139,7 +139,7 @@
 
 (define-syntax add-expected
   (syntax-parser
-    [(_ e τ) (add-expected-ty #'e #'τ)]))
+    [(_ e τ) (add-orig (add-expected-ty #'e #'τ) (get-orig #'e))]))
 (define-syntax pass-expected
   (syntax-parser
     [(_ e stx) (add-expected-ty #'e (get-expected-type #'stx))]))
@@ -219,9 +219,9 @@
             (format
              "~a (~a:~a): Expected expression ~s to have ~a type, got: ~a"
              (syntax-source #'e) (syntax-line #'e) (syntax-column #'e)
-             (syntax-parse #'e-
-               ['x (syntax-e #'x)]
-               [_ (syntax->datum #'e-)])
+             (if (has-orig? #'e-)
+                 (syntax->datum (get-orig #'e-))
+                 (syntax->datum #'e))
              'tycon (type->str #'τ_e))
             (syntax-parse #'τ_e
               [(τ-expander . args) #'(e- args)]
@@ -407,6 +407,8 @@
     (set-stx-prop/preserved stx 'orig (cons orig origs)))
   (define (get-orig τ)
     (car (reverse (or (syntax-property τ 'orig) (list τ)))))
+  (define (has-orig? stx)
+    (and (syntax-property stx 'orig) #true))
   (define (type->str ty)
     (define τ (get-orig ty))
     (cond