www

commit 6db8138e58dd22e1151b2b19a2b13e2eaa5aea77
parent 1ffcf1763a5014b9c6dbae578a446d8e41269937
Author: AlexKnauth <alexander@knauth.org>
Date:   Fri,  3 Jun 2016 17:40:24 -0400

use ~literal/else for better τ-expander error messages

Diffstat:
M
tapl/typecheck.rkt
 | 
28
++++++++++++++++++++--------

1 file changed, 20 insertions(+), 8 deletions(-)
diff --git a/tapl/typecheck.rkt b/tapl/typecheck.rkt
@@ -551,11 +551,11 @@
                  #:with expanded-τ (generate-temporary)
                  #:with tycon-expander (format-id #'tycon "~~~a" #'tycon)
                  #'(~and expanded-τ
-                         (~parse
-                          (~Any/bvs (~literal τ-internal)
-                                    (~and bvs (tv (... (... ...))))
-                                    . rst)
-                          #'expanded-τ)
+                         (~Any/bvs (~literal/else τ-internal
+                                                  (format "Expected ~a type, got: ~a"
+                                                          'τ (type->str #'expanded-τ)))
+                                   (~and bvs (tv (... (... ...))))
+                                   . rst)
                          #,(if (attribute has-bvs?)
                                (if (attribute has-annotations?)
                                    #'(~and (~parse (tycon-expander k (... (... ...))) (typeof #'expanded-τ))
@@ -565,9 +565,13 @@
                 ;; TODO: fix this to handle has-annotations?
                 [(_ (~optional (~and (~fail #:unless #,(attribute has-bvs?)) bvs-pat)
                                #:defaults ([bvs-pat #'()])) . pat)
-                 #'(~Any/bvs (~literal τ-internal)
-                             bvs-pat
-                             . pat)])))
+                 #:with expanded-τ (generate-temporary)
+                 #'(~and expanded-τ
+                         (~Any/bvs (~literal/else τ-internal
+                                                  (format "Expected ~a type, got: ~a"
+                                                          'τ (type->str #'expanded-τ)))
+                                   bvs-pat
+                                   . pat))])))
            (define-syntax τ-expander*
              (pattern-expander
               (syntax-parser
@@ -736,6 +740,14 @@
      (syntax-parser
        [(_ tycons x ...)
         #'(~Any/bvs tycons _ x ...)])))
+  (define-syntax ~literal/else
+    (pattern-expander
+     (syntax-parser
+       [(_ lit:id fail-msg:expr)
+        #'(~and actual
+                (~fail #:unless (and (identifier? #'actual)
+                                     (free-identifier=? #'actual #'lit))
+                       fail-msg))])))
   (define (merge-type-tags stx)
     (define t (syntax-property stx 'type))
     (or (and (pair? t)