diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index ae5fc69a..e63b943c 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -4,8 +4,9 @@ (require (rep type-rep) (utils tc-utils) (env type-env) - (types subtype union convenience resolve) + (except-in (types subtype union convenience resolve utils) -> ->*) (private parse-type) + (only-in scheme/contract listof ->) scheme/match mzlib/trace) (provide type-annotation get-type @@ -89,40 +90,38 @@ (define (get-types stxs #:default [default #f]) (map (lambda (e) (get-type e #:default default)) stxs)) -;; get the type annotations on this list of identifiers -;; if not all identifiers have annotations, return the supplied inferred type -;; list[identifier] type -> list[type] -(define (get-type/infer stxs expr tc-expr tc-expr/check) +;; list[identifier] stx (stx -> tc-results?) (stx tc-results? -> tc-results?) -> tc-results? +(d/c (get-type/infer stxs expr tc-expr tc-expr/check) + ((listof identifier?) syntax? (syntax? . -> . tc-results?) (syntax? tc-results? . -> . tc-results?) . -> . tc-results?) (match stxs ['() - (tc-expr/check expr (-values null)) - (list)] + (tc-expr/check expr (ret null))] [(list stx) (cond [(type-annotation stx #:infer #t) => (lambda (ann) - (list (tc-expr/check expr ann)))] - [else (list (tc-expr expr))])] + (tc-expr/check expr (ret ann)))] + [else (tc-expr expr)])] [(list stx ...) (let ([anns (for/list ([s stxs]) (type-annotation s #:infer #t))]) (if (for/and ([a anns]) a) - (begin (tc-expr/check expr (-values anns)) anns) + (begin (tc-expr/check expr (ret anns))) (let ([ty (tc-expr expr)]) (match ty - [(Values: tys) + [(tc-results: tys) (if (not (= (length stxs) (length tys))) (begin (tc-error/delayed "Expression should produce ~a values, but produces ~a values of types ~a" (length stxs) (length tys) (stringify tys)) - (map (lambda _ (Un)) stxs)) - (map (lambda (stx ty a) - (cond [a => (lambda (ann) (check-type stx ty ann) #;(log/extra stx ty ann) ann)] - [else #;(log/noann stx ty) ty])) - stxs tys anns))] + (ret (map (lambda _ (Un)) stxs))) + (ret + (for/list ([stx stxs] [ty tys] [a anns]) + (cond [a => (lambda (ann) (check-type stx ty ann) ann)] + [else ty]))))] [ty (tc-error/delayed "Expression should produce ~a values, but produces one values of type ~a" (length stxs) ty) - (map (lambda _ (Un)) stxs)]))))])) + (ret (map (lambda _ (Un)) stxs))]))))])) ;; check that e-type is compatible with ty in context of stx diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index e1aa8fda..d683efa9 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -34,27 +34,6 @@ (tc-exprs/check (syntax->list body) expected) (tc-exprs (syntax->list body))))) -#| -;; this is more abstract, but sucks - (define ((mk f) namess exprs body form) - (let* ([names (map syntax->list (syntax->list namess))] - [exprs (syntax->list exprs)]) - (f (lambda (e->t namess types exprs) (do-check e->t namess types form exprs body)) names exprs))) - - (define tc/letrec-values - (mk (lambda (do names exprs) - (let ([types (map (lambda (l) (map get-type l)) names)]) - (do tc-expr/t names types exprs))))) - - (define tc/let-values - (mk (lambda (do names exprs) - (let* (;; the types of the exprs - [inferred-types (map tc-expr/t exprs)] - ;; the annotated types of the name (possibly using the inferred types) - [types (map get-type/infer names inferred-types)]) - (do (lambda (x) x) names types inferred-types))))) - |# - (define (tc/letrec-values/check namess exprs body form expected) (tc/letrec-values/internal namess exprs body form expected)) @@ -72,8 +51,7 @@ (andmap values expecteds) (tc-expr/check e (mk expecteds)) (tc-expr e))) - (match tcr - [(tc-result1: t) t])) + tcr) (define (tc/letrec-values/internal namess exprs body form expected) (let* ([names (map syntax->list (syntax->list namess))] @@ -100,8 +78,9 @@ ;; then check this expression separately (with-lexical-env/extend (list (car names)) - (list (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names))) - (lambda (e t) (tc-expr/check/t e (ret t))))) + (list (match (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names))) + tc-expr/check) + [(tc-results: ts) ts])) (loop (cdr names) (cdr exprs) (apply append (cdr names)) (cdr clauses)))] [else ;(for-each (lambda (vs) (for-each (lambda (v) (printf/log "Letrec Var: ~a~n" (syntax-e v))) vs)) names) @@ -115,9 +94,8 @@ [(#%plain-lambda () _) (and expected (syntax-property e 'typechecker:called-in-tail-position)) (begin - (tc-expr/check e (-> expected)) - (-> expected))] - [_ (tc-expr/t e)])) + (tc-expr/check e (ret (-> expected))))] + [_ (tc-expr e)])) (define (tc/let-values namess exprs body form [expected #f]) (let* (;; a list of each name clause @@ -127,8 +105,10 @@ ;; the types of the exprs #;[inferred-types (map (tc-expr-t/maybe-expected expected) exprs)] ;; the annotated types of the name (possibly using the inferred types) - [types (for/list ([name names] [e exprs]) (get-type/infer name e (tc-expr-t/maybe-expected expected) - (lambda (e t) (tc-expr/check/t e (ret t)))))] + [types (for/list ([name names] [e exprs]) + (match (get-type/infer name e (tc-expr-t/maybe-expected expected) + tc-expr/check) + [(tc-results: ts) ts]))] ;; the clauses for error reporting [clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])]) (do-check void names types form types body clauses expected)))