diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index 57c2810e81..cc4b584762 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -418,10 +418,9 @@ This file defines two sorts of primitives. All of them are provided into any mod (add-ann #'arg #'ty)])) (define-for-syntax (add-ann expr-stx ty-stx) - (type-ascription-property - (quasisyntax/loc expr-stx - (#%expression #,expr-stx)) - ty-stx)) + (quasisyntax/loc expr-stx + (#,(type-ascription-property #'#%expression ty-stx) + #,expr-stx))) (define-syntax (inst stx) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-annotation.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-annotation.rkt index 76df1fccef..21b5bd071c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-annotation.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-annotation.rkt @@ -15,8 +15,6 @@ get-type get-types get-type/infer - type-ascription - remove-ascription check-type dotted?) @@ -50,19 +48,6 @@ #:attr type (type-annotation #'i) #:when (attribute type)]) -(define (type-ascription stx) - (syntax-parse stx - [s:type-ascription^ - (define prop (attribute s.value)) - (unless (syntax? prop) - (int-err "Type ascription is bad: ~a" prop)) - (add-scoped-tvars stx (parse-literal-alls prop)) - (parse-tc-results prop)] - [_ #f])) - -(define (remove-ascription stx) - (type-ascription-property stx #f)) - ;; get the type annotation of this identifier, otherwise error ;; if #:default is provided, return that instead of error ;; identifier #:default Type -> Type diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index 6b0aeb3ebd..78e21bf734 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -9,7 +9,7 @@ (private-in parse-type type-annotation syntax-properties) (rep type-rep filter-rep object-rep) (utils tc-utils) - (env lexical-env tvar-env index-env) + (env lexical-env tvar-env index-env scoped-tvar-env) racket/format racket/list racket/private/class-internal syntax/parse syntax/stx @@ -153,17 +153,7 @@ (int-err "bad form input to tc-expr: ~a" form)) ;; typecheck form (let loop ([form* form] [expected expected] [checked? #f]) - (cond [(type-ascription form*) - => - (lambda (ann) - (let* ([r (tc-expr/check/internal form* ann)] - [r* (check-below (check-below r ann) expected)]) - ;; add this to the *original* form, since the newer forms aren't really in the program - (add-typeof-expr form r) - ;; around again in case there is an instantiation - ;; remove the ascription so we don't loop infinitely - (loop (remove-ascription form*) r* #t)))] - [(external-check-property form*) + (cond [(external-check-property form*) => (lambda (check) (check form*) @@ -269,6 +259,9 @@ [((~and exp #%expression) e) #:when (type-inst-property #'exp) (do-inst (tc-expr #'e) (type-inst-property #'exp))] + [((~and exp:type-ascription^ #%expression) e) + (add-scoped-tvars #'e (parse-literal-alls (attribute exp.value))) + (tc-expr/check #'e (parse-tc-results (attribute exp.value)))] [(#%expression e) (tc-expr/check #'e expected)] ;; syntax @@ -306,7 +299,7 @@ (tc-expr/check/type #'fun (kw-convert f #:split #t)) expected] [(or (tc-results: _) (tc-any-results:)) - (tc-expr (remove-ascription form))])] + (tc-expr form)])] ;; opt function def [(~and (let-values ([(f) fun]) . body) opt:opt-lambda^) (define conv-type @@ -318,7 +311,7 @@ [_ #f])) (if conv-type (begin (tc-expr/check/type #'fun conv-type) expected) - (tc-expr (remove-ascription form)))] + (tc-expr form))] ;; let [(let-values ([(name ...) expr] ...) . body) (tc/let-values #'((name ...) ...) #'(expr ...) #'body expected)] @@ -437,6 +430,9 @@ [((~and exp #%expression) e) #:when (type-inst-property #'exp) (do-inst (tc-expr #'e) (type-inst-property #'exp))] + [((~and exp:type-ascription^ #%expression) e) + (add-scoped-tvars #'e (parse-literal-alls (attribute exp.value))) + (tc-expr/check #'e (parse-tc-results (attribute exp.value)))] [(#%expression e) (tc-expr #'e)] ;; #%variable-reference [(#%variable-reference . _) @@ -470,12 +466,9 @@ (unless (syntax? form) (int-err "bad form input to tc-expr: ~a" form)) ;; typecheck form - (cond - [(type-ascription form) => (lambda (ann) (tc-expr/check form ann))] - [else - (let ([ty (internal-tc-expr form)]) - (add-typeof-expr form ty) - ty)]))) + (let ([ty (internal-tc-expr form)]) + (add-typeof-expr form ty) + ty))) (define (single-value form [expected #f]) (define t (if expected (tc-expr/check form expected) (tc-expr form))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt index 086457c90c..141591fa5b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt @@ -28,7 +28,6 @@ "parse-type-tests.rkt" "subst-tests.rkt" "infer-tests.rkt" - "type-annotation-test.rkt" "keyword-expansion-test.rkt" "special-env-typecheck-tests.rkt" "contract-tests.rkt" diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-annotation-test.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-annotation-test.rkt deleted file mode 100644 index 043f19c45e..0000000000 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/type-annotation-test.rkt +++ /dev/null @@ -1,36 +0,0 @@ -#lang racket/base -(require "test-utils.rkt" - "evaluator.rkt" - (for-syntax - racket/base - racket/list - (rep type-rep filter-rep object-rep) - (private type-annotation) - (types abbrev numeric-tower tc-result)) - (only-in typed-racket/typed-racket do-standard-inits) - (base-env prims base-types base-types-extra colon) - rackunit) - -(provide tests) -(gen-test-main) - -(begin-for-syntax - (do-standard-inits)) - - -(define-syntax-rule (tat ann-stx ty) - (test-case (format "~a" (quote ann-stx)) - (unless - (phase1-phase0-eval - (define stx (local-expand (quote-syntax ann-stx) 'expression empty)) - (define ascrip (type-ascription stx)) - #`#,(equal? ascrip ty)) - (fail-check "Unequal types")))) - -(define tests - (test-suite - "Type Annotation tests" - ;; FIXME - ask Ryan - (tat (ann foo : Number) (ret -Number -no-filter -no-obj)) - (tat foo #f) - (tat (ann foo : 3) (ret (-val 3) -no-filter -no-obj))))