www

commit 9b9c1dda9610daa4af1ad247e04a09a49a5004b3
parent b439327d78085069960714b0ec9116edfc3fd264
Author: Stephen Chang <stchang@ccs.neu.edu>
Date:   Wed, 20 Apr 2016 14:12:43 -0400

datatype constructors are functions

Diffstat:
M
tapl/mlish.rkt
 | 
29
+++++++++--------------------
M
tapl/tests/mlish-tests.rkt
 | 
26
++++++++++++++++++++++++++

2 files changed, 35 insertions(+), 20 deletions(-)
diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt
@@ -281,28 +281,17 @@
               #:when (stx-null? #'(τ ...))
               #:with τ-expected (syntax-property #'C 'expected-type)
               #:fail-unless (syntax-e #'τ-expected)
-                            (type-error #:src stx 
-                             #:msg (format "cannot infer type of ~a; add annotations" 
-                                           (syntax->datum #'C)))
+                            (raise
+                              (exn:fail:type:infer
+                                (string-append
+                                  (format "TYPE-ERROR: ~a (~a:~a): "
+                                          (syntax-source stx) (syntax-line stx) (syntax-column stx))
+                                  (format "cannot infer type of ~a; add annotations" 
+                                          (syntax->datum #'C)))
+                                (current-continuation-marks)))
               #:with (NameExpander τ-expected-arg (... ...)) ((current-type-eval) #'τ-expected)
               #'(C {τ-expected-arg (... ...)})]
-             [_:id 
-              #:when (and (not (stx-null? #'(X ...)))
-                          (not (stx-null? #'(τ ...))))
-              (raise
-               (exn:fail:type:infer
-                 (string-append
-                   (format "TYPE-ERROR: ~a (~a:~a):"
-                           (syntax-source stx) (syntax-line stx) (syntax-column stx))
-                   "\n"
-                   (format "Constructor ~a must be applied to ~a argument(s) with type(s): "
-                           'Cons (stx-length #'(τ ...)))
-                   (string-join (stx-map type->str #'(τ ...)) ", ")
-                   "\n"
-                   (format "The arguments should instantiate ~a type argument(s): "
-                           (stx-length #'(X ...)))
-                   (string-join (stx-map type->str #'(X ...)) ", "))
-                 (current-continuation-marks)))]
+             [_:id (⊢ StructName (∀ (X ...) (ext-stlc:→ τ ... (Name X ...))))] ; HO fn
              [(C τs e_arg ...)
               #:when (brace? #'τs) ; commit to this clause
               #:with {~! τ_X:type (... ...)} #'τs
diff --git a/tapl/tests/mlish-tests.rkt b/tapl/tests/mlish-tests.rkt
@@ -31,6 +31,17 @@
   Nil
   (Cons X (List X)))
 
+;; arity err
+(typecheck-fail (Cons 1) #:with-msg "Cons.+Wrong number of arguments")
+
+;; type err
+(typecheck-fail (Cons 1 1)
+  #:with-msg (expected "Int, (List Int)" #:given "Int, Int"))
+  
+;; check Nil still available as tyvar
+(define (f11 [x : Nil] -> Nil) x)
+(check-type f11 : (→/test X X))
+
 (typecheck-fail 
   (match (Cons 1 Nil) with
    [Nil -> 1])
@@ -179,6 +190,17 @@
   INil
   (ConsI Int IntList))
 
+;; HO, monomorphic
+(check-type ConsI : (→ Int IntList IntList))
+(define (new-cons [c : (→ Int IntList IntList)] [x : Int] [xs : IntList] 
+                  -> IntList)
+  (c x xs))
+(check-type (new-cons ConsI 1 INil) : IntList -> (ConsI 1 INil))
+
+;; check that ConsI and INil are available as tyvars
+(define (f10 [x : INil] [y : ConsI] -> ConsI) y)
+(check-type f10 : (→/test X Y Y))
+
 (check-type INil : IntList)
 (check-type (ConsI 1 INil) : IntList)
 (check-type
@@ -363,6 +385,10 @@
 (check-type (rt-fn (RT2 #f 2 Nil)) : Int -> 2)
 (check-type (rt-fn (RT3 10 20)) : Int -> 10)
 
+;; HO constructors
+(check-type RT1 : (→/test X Y String (RecoTest X Y)))
+(check-type RT2 : (→/test {X Y} Y X (List X) (RecoTest X Y)))
+(check-type RT3 : (→/test X Y (RecoTest X Y)))
 
 ; ext-stlc tests --------------------------------------------------