diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt index da25221..59de9ba 100644 --- 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 index adeaeb2..790a885 100644 --- 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 --------------------------------------------------