diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index e63b943c..d4f548b7 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -16,6 +16,7 @@ type-ascrip-symbol type-dotted-symbol type-ascription + remove-ascription check-type dotted?) @@ -65,6 +66,9 @@ [(syntax-property stx type-ascrip-symbol) => pt] [else #f])) +(define (remove-ascription stx) + (syntax-property stx type-ascrip-symbol #f)) + (define (log/ann stx ty) (printf/log "Required Annotated Variable: ~a ~a~n" (syntax-e stx) ty)) (define (log/extra stx ty ty2) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 6e4c884f..4c3aeb3e 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -462,8 +462,28 @@ (ret (-Promise (tc-expr/t #'e)))] ;; special case for `list' [(#%plain-app list . args) - (let ([tys (map tc-expr/t (syntax->list #'args))]) - (ret (apply -lst* tys)))] + (begin + ;(printf "calling list: ~a ~a~n" (syntax->datum #'args) (Type? expected)) + (match expected + [(tc-result1: (Mu: var (Union: (or + (list (Pair: elem-ty (F: var)) (Value: '())) + (list (Value: '()) (Pair: elem-ty (F: var))))))) + ;(printf "special case 1 ~a~n" elem-ty) + (for ([i (in-list (syntax->list #'args))]) + (tc-expr/check i (ret elem-ty))) + expected] + [(tc-result1: (app untuple (? (lambda (ts) (and ts (= (length (syntax->list #'args)) + (length ts)))) + ts))) + ;(printf "special case 2 ~a~n" ts) + (for ([ac (in-list (syntax->list #'args))] + [exp (in-list ts)]) + (tc-expr/check ac (ret exp))) + expected] + [_ + ;(printf "not special case~n") + (let ([tys (map tc-expr/t (syntax->list #'args))]) + (ret (apply -lst* tys)))]))] ;; special case for `list*' [(#%plain-app list* . args) (match-let* ([(list last tys-r ...) (reverse (map tc-expr/t (syntax->list #'args)))] @@ -490,9 +510,24 @@ #'(let-values ([(x) fixed-args] ... [(rst) varg]) . body) expected)))] [(#%plain-app f . args) - (let* ([f-ty (single-value #'f)] - [arg-tys (map single-value (syntax->list #'args))]) - (tc/funapp #'f #'args f-ty arg-tys expected))])) + (let* ([f-ty (single-value #'f)]) + (match f-ty + [(tc-result1: + (and t (Function: + (list (and a (arr: (? (lambda (d) + (= (length d) + (length (syntax->list #'args)))) + dom) + (Values: (list (Result: v (LFilterSet: '() '()) (LEmpty:)))) + #f #f '())))))) + ;(printf "f dom: ~a ~a~n" (syntax->datum #'f) dom) + (let ([arg-tys (map (lambda (a t) (tc-expr/check a (ret t))) + (syntax->list #'args) + dom)]) + (tc/funapp #'f #'args f-ty arg-tys expected))] + [_ + (let ([arg-tys (map single-value (syntax->list #'args))]) + (tc/funapp #'f #'args f-ty arg-tys expected))]))])) ;(trace tc/app/internal) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 046cb66c..f84244ac 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -68,7 +68,7 @@ ([inst (in-improper-stx inst)]) (cond [(not inst) ty] [(not (or (Poly? ty) (PolyDots? ty))) - (tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)] + (tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)] [(and (Poly? ty) (not (= (length (syntax->list inst)) (Poly-n ty)))) (tc-error/expr #:return (Un) @@ -199,20 +199,34 @@ (define (tc-expr/check form expected) (parameterize ([current-orig-stx form]) - ;(printf "form: ~a~n" (syntax->datum form)) ;; the argument must be syntax (unless (syntax? form) (int-err "bad form input to tc-expr: ~a" form)) ;; typecheck form - (let ([ty (cond [(type-ascription form) => (lambda (ann) - (let ([r (tc-expr/check/internal form ann)]) - (check-below r expected)))] - [else (tc-expr/check/internal form expected)])]) - (match ty - [(tc-results: ts fs os) - (let ([ts* (do-inst form ts)]) - (ret ts* fs os))] - [_ ty])))) + (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 r expected)]) + ;; around again in case there is an instantiation + ;; remove the ascription so we don't loop infinitely + (loop (remove-ascription form) r* #t)))] + [(syntax-property form 'type-inst) + ;; check without property first + ;; to get the appropriate type to instantiate + (match (tc-expr (syntax-property form 'type-inst #f)) + [(tc-results: ts fs os) + ;; do the instantiation on the old type + (let* ([ts* (do-inst form ts)] + [ts** (ret ts* fs os)]) + ;; make sure the new type is ok + (check-below ts** expected))] + ;; no annotations possible on dotted results + [ty ty])] + ;; nothing to see here + [checked? expected] + [else (tc-expr/check/internal form expected)])))) ;; tc-expr/check : syntax tc-results -> tc-results (define (tc-expr/check/internal form expected) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 323d7713..14cee3ce 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -78,7 +78,7 @@ null)])] [with-syntax ([(pmb body2 ...) #'new-mod])] [begin (do-time "Local Expand Done")] - [with-syntax ([after-code (parameterize ([orig-module-stx stx] + [with-syntax ([after-code (parameterize ([orig-module-stx (or (orig-module-stx) stx)] [expanded-module-stx #'new-mod]) (type-check #'(body2 ...)))] [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]