diff --git a/collects/typed-racket/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt index 0eeb9e82..91be6c6b 100644 --- a/collects/typed-racket/typecheck/signatures.rkt +++ b/collects/typed-racket/typecheck/signatures.rkt @@ -52,6 +52,9 @@ (define-signature tc-app-eq^ ([cond-contracted tc/app-eq (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) +(define-signature tc-app-lambda^ + ([cond-contracted tc/app-lambda (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) + (define-signature tc-apply^ ([cond-contracted tc/apply (syntax? syntax? . -> . tc-results?)])) diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index bd73e4c7..64b3d684 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -28,68 +28,10 @@ (import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-app-keywords^ tc-app-hetero^ tc-app-list^ tc-app-apply^ tc-app-values^ - tc-app-objects^ tc-app-eq^) + tc-app-objects^ tc-app-eq^ tc-app-lambda^) (export tc-app^) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; let loop - -(define (let-loop-check form lam lp actuals args body expected) - (syntax-parse #`(#,args #,body #,actuals) - #:literals (#%plain-app if null? pair? null) - [((val acc ...) - ((~and inner-body (if (#%plain-app (~or pair? null?) val*) thn els))) - (actual actuals ...)) - #:when - (and (free-identifier=? #'val #'val*) - (ormap (lambda (a) (find-annotation #'inner-body a)) - (syntax->list #'(acc ...)))) - (let* ([ts1 (generalize (tc-expr/t #'actual))] - [ann-ts (for/list ([a (in-syntax #'(acc ...))] - [ac (in-syntax #'(actuals ...))]) - (or (find-annotation #'inner-body a) - (generalize (tc-expr/t ac))))] - [ts (cons ts1 ann-ts)]) - ;; check that the actual arguments are ok here - (for/list ([a (syntax->list #'(actuals ...))] - [t ann-ts]) - (tc-expr/check a (ret t))) - ;; then check that the function typechecks with the inferred types - (add-typeof-expr lam (tc/rec-lambda/check form args body lp ts expected)) - expected)] - ;; special case `for/list' - [((val acc ...) - ((~and inner-body (if e1 e2 e3:id))) - (null actuals ...)) - #:when (free-identifier=? #'val #'e3) - (let ([ts (for/list ([ac (syntax->list #'(actuals ...))] - [f (syntax->list #'(acc ...))]) - (or - (type-annotation f #:infer #t) - (generalize (tc-expr/t ac))))] - [acc-ty (or - (type-annotation #'val #:infer #t) - (match expected - [(tc-result1: (and t (Listof: _))) t] - [_ #f]) - (generalize (-val '())))]) - (add-typeof-expr lam (tc/rec-lambda/check form args body lp (cons acc-ty ts) expected)) - expected)] - ;; special case when argument needs inference - [(_ body* _) - (let ([ts (for/list ([ac (syntax->list actuals)] - [f (syntax->list args)]) - (let* ([infer-t (or (type-annotation f #:infer #t) - (find-annotation #'(begin . body*) f))]) - (if infer-t - (check-below (tc-expr/t ac) infer-t) - (generalize (tc-expr/t ac)))))]) - (add-typeof-expr lam (tc/rec-lambda/check form args body lp ts expected)) - expected)])) - - - ;; the main dispatching function ;; syntax tc-results? -> tc-results? (define (tc/app/internal form expected) @@ -100,6 +42,7 @@ (tc/app-keywords form expected) (tc/app-objects form expected) (tc/app-eq form expected) + (tc/app-lambda form expected) (syntax-parse form #:literals (#%plain-app #%plain-lambda letrec-values quote not false? list @@ -140,12 +83,6 @@ (match (single-value #'arg) [(tc-result1: t (FilterSet: f+ f-) _) (ret -Boolean (make-FilterSet f- f+))])] - ;; even more special case for match - [(#%plain-app (letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals) - #:fail-unless expected #f - #:fail-unless (not (andmap type-annotation (syntax->list #'(lp . args)))) #f - #:fail-unless (free-identifier=? #'lp #'lp*) #f - (let-loop-check form #'lam #'lp #'actuals #'args #'body expected)] ;; special case for (current-contract-region)'s default expansion ;; just let it through without any typechecking, since module-name-fixup ;; is a private function from syntax/location, so this must have been @@ -160,30 +97,6 @@ #:declare mp1 (id-from 'make-promise 'racket/promise) #:declare mp2 (id-from 'make-promise 'racket/promise) (ret (-Promise (tc-expr/t #'e)))] - ;; inference for ((lambda - [(#%plain-app (#%plain-lambda (x ...) . body) args ...) - #:fail-unless (= (length (syntax->list #'(x ...))) - (length (syntax->list #'(args ...)))) - #f - #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f - (tc/let-values #'((x) ...) #'(args ...) #'body - #'(let-values ([(x) args] ...) . body) - expected)] - ;; inference for ((lambda with dotted rest - [(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...) - #:fail-unless (<= (length (syntax->list #'(x ...))) - (length (syntax->list #'(args ...)))) #f - ;; FIXME - remove this restriction - doesn't work because the annotation - ;; on rst is not a normal annotation, may have * or ... - #:fail-when (type-annotation #'rst) #f - #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f - (let-values ([(fixed-args varargs) - (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) - (with-syntax ([(fixed-args ...) fixed-args] - [varg #`(#%plain-app list #,@varargs)]) - (tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body - #'(let-values ([(x) fixed-args] ... [(rst) varg]) . body) - expected)))] [_ (tc/app/regular form expected)]))) (define (tc/app/regular form expected) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt new file mode 100644 index 00000000..9100e412 --- /dev/null +++ b/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt @@ -0,0 +1,104 @@ +#lang racket/unit + +(require "../../utils/utils.rkt" + syntax/parse racket/match racket/list + unstable/sequence + (typecheck signatures tc-app-helper tc-funapp check-below find-annotation ) + (types abbrev utils generalize type-table) + (private type-annotation) + (rep type-rep) + + (for-template racket/base)) + + +(import tc-expr^ tc-let^ tc-lambda^) +(export tc-app-lambda^) + +(define (tc/app-lambda form expected) + (syntax-parse form + #:literals (#%plain-app #%plain-lambda letrec-values) + ;; let loop + [(#%plain-app (letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals) + #:fail-unless expected #f + #:fail-unless (not (andmap type-annotation (syntax->list #'(lp . args)))) #f + #:fail-unless (free-identifier=? #'lp #'lp*) #f + (let-loop-check form #'lam #'lp #'actuals #'args #'body expected)] + ;; inference for ((lambda + [(#%plain-app (#%plain-lambda (x ...) . body) args ...) + #:fail-unless (= (length (syntax->list #'(x ...))) + (length (syntax->list #'(args ...)))) + #f + #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f + (tc/let-values #'((x) ...) #'(args ...) #'body + #'(let-values ([(x) args] ...) . body) + expected)] + ;; inference for ((lambda with dotted rest + [(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...) + #:fail-unless (<= (length (syntax->list #'(x ...))) + (length (syntax->list #'(args ...)))) #f + ;; FIXME - remove this restriction - doesn't work because the annotation + ;; on rst is not a normal annotation, may have * or ... + #:fail-when (type-annotation #'rst) #f + #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f + (let-values ([(fixed-args varargs) + (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) + (with-syntax ([(fixed-args ...) fixed-args] + [varg #`(#%plain-app list #,@varargs)]) + (tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body + #'(let-values ([(x) fixed-args] ... [(rst) varg]) . body) + expected)))] + [_ #f])) + +(define (let-loop-check form lam lp actuals args body expected) + (syntax-parse #`(#,args #,body #,actuals) + #:literals (#%plain-app if null? pair? null) + [((val acc ...) + ((~and inner-body (if (#%plain-app (~or pair? null?) val*) thn els))) + (actual actuals ...)) + #:when + (and (free-identifier=? #'val #'val*) + (ormap (lambda (a) (find-annotation #'inner-body a)) + (syntax->list #'(acc ...)))) + (let* ([ts1 (generalize (tc-expr/t #'actual))] + [ann-ts (for/list ([a (in-syntax #'(acc ...))] + [ac (in-syntax #'(actuals ...))]) + (or (find-annotation #'inner-body a) + (generalize (tc-expr/t ac))))] + [ts (cons ts1 ann-ts)]) + ;; check that the actual arguments are ok here + (for/list ([a (syntax->list #'(actuals ...))] + [t ann-ts]) + (tc-expr/check a (ret t))) + ;; then check that the function typechecks with the inferred types + (add-typeof-expr lam (tc/rec-lambda/check form args body lp ts expected)) + expected)] + ;; special case `for/list' + [((val acc ...) + ((~and inner-body (if e1 e2 e3:id))) + (null actuals ...)) + #:when (free-identifier=? #'val #'e3) + (let ([ts (for/list ([ac (syntax->list #'(actuals ...))] + [f (syntax->list #'(acc ...))]) + (or + (type-annotation f #:infer #t) + (generalize (tc-expr/t ac))))] + [acc-ty (or + (type-annotation #'val #:infer #t) + (match expected + [(tc-result1: (and t (Listof: _))) t] + [_ #f]) + (generalize (-val '())))]) + (add-typeof-expr lam (tc/rec-lambda/check form args body lp (cons acc-ty ts) expected)) + expected)] + ;; special case when argument needs inference + [(_ body* _) + (let ([ts (for/list ([ac (syntax->list actuals)] + [f (syntax->list args)]) + (let* ([infer-t (or (type-annotation f #:infer #t) + (find-annotation #'(begin . body*) f))]) + (if infer-t + (check-below (tc-expr/t ac) infer-t) + (generalize (tc-expr/t ac)))))]) + (add-typeof-expr lam (tc/rec-lambda/check form args body lp ts expected)) + expected)])) + diff --git a/collects/typed-racket/typecheck/typechecker.rkt b/collects/typed-racket/typecheck/typechecker.rkt index 491ab8dd..80cd76bc 100644 --- a/collects/typed-racket/typecheck/typechecker.rkt +++ b/collects/typed-racket/typecheck/typechecker.rkt @@ -10,6 +10,7 @@ "tc-app/tc-app-eq.rkt" "tc-app/tc-app-hetero.rkt" "tc-app/tc-app-keywords.rkt" + "tc-app/tc-app-lambda.rkt" "tc-app/tc-app-list.rkt" "tc-app/tc-app-objects.rkt" "tc-app/tc-app-values.rkt" @@ -23,4 +24,4 @@ (define-values/invoke-unit/infer (link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@ tc-apply@ tc-app-hetero@ tc-app-list@ tc-app-apply@ tc-app-values@ tc-app-keywords@ - tc-app-objects@ tc-app-eq@)) + tc-app-objects@ tc-app-eq@ tc-app-lambda@))