From fdf902121e528e0dcec51e10182d8f6e68d18d09 Mon Sep 17 00:00:00 2001
From: Stephen Chang <stchang@ccs.neu.edu>
Date: Mon, 11 Apr 2016 14:01:24 -0400
Subject: [PATCH] fix more stx-parse err msgs; and other err msgs

- all tests now passing
---
 tapl/mlish.rkt                   | 31 ++++++++++++++++++++-----------
 tapl/tests/mlish-tests.rkt       |  8 ++++----
 tapl/tests/mlish/bg/basics.mlish |  2 +-
 tapl/typecheck.rkt               |  7 +++++--
 4 files changed, 30 insertions(+), 18 deletions(-)

diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt
index 864b66c..be96e63 100644
--- a/tapl/mlish.rkt
+++ b/tapl/mlish.rkt
@@ -99,10 +99,12 @@
                  (cons #'a- as-)
                  (stx-append cs (compute-constraint (list tyXin #'ty_a))))))
          (define maybe-solved-tys (try-to-solve Xs cs))
+         
          (if maybe-solved-tys
              (list (reverse as-) maybe-solved-tys)
              (type-error #:src stx
-              #:msg (mk-app-err-msg stx #:expected #'(τ_inX ...) #:given (infers+erase #'args)
+              #:msg (mk-app-err-msg stx #:expected #'(τ_inX ...) 
+                                        #:given (stx-map stx-cadr (infers+erase #'args))
                      #:note (format "Could not infer instantiation of polymorphic function ~a."
                                     (syntax->datum #'e_fn)))))])]))
 
@@ -289,13 +291,16 @@
                         (infer+erase (syntax-property e 'expected-type τ_e)))
                       #'(e_arg ...) #'(τ_in.norm (... ...)))
               #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in.norm (... ...)))
-                           (mk-app-err-msg (syntax/loc stx (C e_arg ...))
+                           (mk-app-err-msg (syntax/loc stx (#%app C e_arg ...))
                             #:expected #'(τ_in.norm (... ...)) #:given #'(τ_arg ...)
                             #:name (format "constructor ~a" 'Cons))
               (⊢ (StructName e_arg- ...) : (Name τ_X (... ...)))]
              [(C . args) ; no type annotations, must infer instantiation
               #:with StructName/ty 
-                     (⊢ StructName : (∀ (X ...) (ext-stlc:→ τ ... (Name X ...))))
+                     (syntax-property
+                       (⊢ StructName : (∀ (X ...) (ext-stlc:→ τ ... (Name X ...))))
+                       'orig
+                       (list #'C))
               ; stx/loc transfers expected-type
               (syntax/loc stx (mlish:#%app StructName/ty . args))]))
          ...)]))
@@ -604,14 +609,15 @@
         #:with ((_ ((~literal quote) ConsAll) . _) ...) #'info-body
         #:fail-unless (set=? (syntax->datum #'(Clause ...))
                              (syntax->datum #'(ConsAll ...)))
-                      (string-append
-                       "clauses not exhaustive; missing: "
-                       (string-join      
-                           (map symbol->string
-                                (set-subtract 
-                                    (syntax->datum #'(ConsAll ...))
-                                  (syntax->datum #'(Clause ...))))
-                         ", "))
+                      (type-error #:src stx
+                       #:msg (string-append
+                              "match: clauses not exhaustive; missing: "
+                              (string-join      
+                                (map symbol->string
+                                     (set-subtract 
+                                       (syntax->datum #'(ConsAll ...))
+                                       (syntax->datum #'(Clause ...))))
+                                ", ")))
         #:with ((_ ((~literal quote) Cons) ((~literal quote) StructName) Cons? [_ acc τ] ...) ...)
                (map ; ok to compare symbols since clause names can't be rebound
                 (lambda (Cl) 
@@ -716,6 +722,9 @@
     [(stx-null? #'Xs)
      (syntax-parse #'(e_args tyX_args)
        [((e_arg ...) (τ_inX ... _))
+        #:fail-unless (stx-length=? #'(e_arg ...) #'(τ_inX ...))
+                      (mk-app-err-msg stx #:expected #'(τ_inX ...) 
+                                      #:note "Wrong number of arguments.")
         #:with e_fn/ty (⊢ e_fn- : (ext-stlc:→ . tyX_args))
         #'(ext-stlc:#%app e_fn/ty (add-expected e_arg τ_inX) ...)])]
     [else
diff --git a/tapl/tests/mlish-tests.rkt b/tapl/tests/mlish-tests.rkt
index b8ac623..076482e 100644
--- a/tapl/tests/mlish-tests.rkt
+++ b/tapl/tests/mlish-tests.rkt
@@ -189,7 +189,7 @@
 (typecheck-fail (ConsI #f INil)
  #:with-msg 
  (expected "Int, IntList" #:given "Bool, IntList"
-  #:note "Type error applying constructor ConsI"))
+  #:note "Type error applying.*ConsI"))
 
 ;; annotated
 (check-type (Nil {Int}) : (List Int))
@@ -215,15 +215,15 @@
 (typecheck-fail (Cons 1 (Nil {Bool}))
  #:with-msg 
  (expected "Int, (List Int)" #:given "Int, (List Bool)"
-  #:note "Type error applying constructor Cons"))
+  #:note "Type error applying.*Cons"))
 (typecheck-fail (Cons {Bool} 1 (Nil {Int}))
  #:with-msg 
  (expected "Bool, (List Bool)" #:given "Int, (List Int)"
-  #:note "Type error applying constructor Cons"))
+  #:note "Type error applying.*Cons"))
 (typecheck-fail (Cons {Bool} 1 Nil)
  #:with-msg 
  (expected "Bool, (List Bool)" #:given "Int, (List Bool)"
-  #:note "Type error applying constructor Cons"))
+  #:note "Type error applying.*Cons"))
 
 (typecheck-fail (match Nil with [Cons x xs -> 2] [Nil -> 1])
                 #:with-msg "add annotations")
diff --git a/tapl/tests/mlish/bg/basics.mlish b/tapl/tests/mlish/bg/basics.mlish
index f4dec72..f4a3757 100644
--- a/tapl/tests/mlish/bg/basics.mlish
+++ b/tapl/tests/mlish/bg/basics.mlish
@@ -59,7 +59,7 @@
 (check-type
   (permutations (Nil {Int}))
   : (List (List Int))
-  ⇒ (Cons (Nil {(List Int)}) Nil))
+  ⇒ (Cons (Nil {Int}) Nil))
 
 (check-type
   (permutations (Cons 1 Nil))
diff --git a/tapl/typecheck.rkt b/tapl/typecheck.rkt
index 393e1a7..cab80dc 100644
--- a/tapl/typecheck.rkt
+++ b/tapl/typecheck.rkt
@@ -584,9 +584,12 @@
                       (if (stx-null? #'extra-bvs)
                           #'extra-info
                           (substs #'τs- #'extra-bvs #'extra-info))
+               (add-orig
                 (assign-type 
-                  (syntax/loc stx (τ-internal (λ bvs- (#%expression extra-info-inst) . τs-))) 
-                  #'k_result)]
+                  (syntax/loc stx 
+                    (τ-internal (λ bvs- (#%expression extra-info-inst) . τs-))) 
+                  #'k_result)
+                #'(τ . args))]
              ;; else fail with err msg
              [_
               (type-error #:src stx