diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt index cf91be9..212c393 100644 --- a/tapl/mlish.rkt +++ b/tapl/mlish.rkt @@ -113,11 +113,11 @@ #`(begin (define-type-constructor Name #:arity = #,(stx-length #'(X ...)) - #:other-prop variants #'(X ...) #'((Cons τ ...) ...)) + #:other-prop variants #'(X ...) #'((Cons StructName [fld : τ] ...) ...)) (struct StructName (fld ...) #:reflection-name 'Cons #:transparent) ... (define-syntax (Cons stx) (syntax-parse stx - ; no args and not poly morphic + ; no args and not polymorphic [C:id #:when (and (stx-null? #'(X ...)) (stx-null? #'(τ ...))) #'(C)] ; no args but polymorphic, check inferred type [C:id @@ -191,18 +191,27 @@ (syntax-parse stx #:datum-literals (with ->) [(_ e with . clauses) #:fail-when (null? (syntax->list #'clauses)) "no clauses" - #:with ([Clause:id x ... -> e_c] ...) (stx-sort #'clauses symbol e_c_un] ...) (stx-sort #'clauses symbol Nil] + [Cons x xs -> (Cons (f x) (map f xs))])) + ;; end infer.rkt tests -------------------------------------------------- @@ -271,7 +280,7 @@ ;; tests from stlc+lit-tests.rkt -------------------------- ; most should pass, some failing may now pass due to added types/forms (check-type 1 : Int) -;(check-not-type 1 : (Int → Int)) +(check-not-type 1 : (→ Int Int)) ;(typecheck-fail "one") ; literal now supported ;(typecheck-fail #f) ; literal now supported (check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) diff --git a/tapl/typecheck.rkt b/tapl/typecheck.rkt index 84885c5..9a106f4 100644 --- a/tapl/typecheck.rkt +++ b/tapl/typecheck.rkt @@ -124,6 +124,9 @@ ; #:when (printf "adding expected type ~a to expression ~a\n" ; (syntax->datum #'τ) (syntax->datum #'e)) (syntax-property #'e 'expected-type #'τ)])) +(define-for-syntax (add-expected-ty e ty) + (or (and (syntax-e ty) (syntax-property e 'expected-type ((current-type-eval) ty))) + e)) ;; type assignment (begin-for-syntax