suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Moved lambda special cases out of tc-app.rkt.

Browse Source 
original commit: 67c7e3537b69fbccf1e30c1fcecca86f9d9ac5eb
This commit is contained in:
Eric Dobson 2012-08-16 21:52:57 -07:00 committed by Sam Tobin-Hochstadt
parent 30239cf42f
commit 5871c0c182
4 changed files with 111 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/typed-racket/typecheck/signatures.rkt
View File

@ -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?)]))

91
collects/typed-racket/typecheck/tc-app.rkt
View File

@ -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)

104
collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt Normal file
View File

@ -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)]))

3
collects/typed-racket/typecheck/typechecker.rkt
View File

@ -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@))