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

handle nested polymorphic types in the expected type of a lambda

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2008-07-07 15:36:33 -04:00
parent acd6664c52
commit 2de55888f1
1 changed files with 9 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/typed-scheme/private/tc-lambda-unit.ss
View File

@ -220,8 +220,13 @@
;; tc/plambda syntax syntax-list syntax-list type -> Poly ;; tc/plambda syntax syntax-list syntax-list type -> Poly
;; formals and bodies must by syntax-lists ;; formals and bodies must by syntax-lists
(define (tc/plambda form formals bodies expected) (define (tc/plambda form formals bodies expected)
(define (maybe-loop form formals bodies expected)
(match expected
[(Function: _) (tc/mono-lambda formals bodies expected)]
[(or (Poly: _ _) (PolyDots: _ _))
(tc/plambda form formals bodies expected)]))
(match expected (match expected
[(Poly-names: ns (and expected* (Function: _))) [(Poly-names: ns expected*)
(let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)]) (let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)])
(when (and (pair? p) (eq? '... (car (last p)))) (when (and (pair? p) (eq? '... (car (last p))))
(tc-error "Expected a polymorphic function without ..., but given function had ...")) (tc-error "Expected a polymorphic function without ..., but given function had ..."))
@ -230,10 +235,10 @@
[literal-tvars tvars] [literal-tvars tvars]
[new-tvars (map make-F literal-tvars)] [new-tvars (map make-F literal-tvars)]
[ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
(tc/mono-lambda formals bodies expected*))]) (maybe-loop form formals bodies expected*))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
(ret expected))] (ret expected))]
[(PolyDots-names: (list ns ... dvar) (and expected* (Function: _))) [(PolyDots-names: (list ns ... dvar) expected*)
(let-values (let-values
([(tvars dotted) ([(tvars dotted)
(let ([p (syntax-property form 'typechecker:plambda)]) (let ([p (syntax-property form 'typechecker:plambda)])
@ -249,7 +254,7 @@
(cons (make-Dotted (make-F dotted)) (cons (make-Dotted (make-F dotted))
new-tvars) new-tvars)
(current-tvars))]) (current-tvars))])
(tc/mono-lambda formals bodies expected*))]) (maybe-loop form formals bodies expected*))])
(ret expected)))] (ret expected)))]
[#f [#f
(match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda))) (match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda)))