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

Cleanup Poly cases in tc-apply

Browse Source
This commit is contained in:
Eric Dobson 2014-04-26 14:15:31 -07:00
parent 33a31d2868
commit ab2877ed7f
1 changed files with 56 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt
View File

@ -79,61 +79,62 @@
[(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
(let*-values ([(arg-tres) (map tc-expr fixed-args)] (let*-values ([(arg-tres) (map tc-expr fixed-args)]
[(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] [(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)]
[(tail-ty tail-bound) (match (tc-expr/t tail) [(full-tail-ty) (tc-expr/t tail)]
[(tail-ty tail-bound)
(match full-tail-ty
[(ListDots: tail-ty tail-bound) [(ListDots: tail-ty tail-bound)
(values tail-ty tail-bound)] (values tail-ty tail-bound)]
[t (values t #f)])]) [t (values #f #f)])])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (or
(cond [(null? doms*) (for/or ([domain (in-list doms)]
[range (in-list rngs)]
[rest (in-list rests)]
[drest (in-list drests)])
(define (finish substitution) (do-ret (subst-all substitution range)))
(cond
;; the actual work, when we have a * function and a list final argument
[(and rest
(not tail-bound)
(<= (length domain) (length arg-tys))
(infer/vararg vars null
(cons full-tail-ty arg-tys)
(cons (make-Listof rest) domain)
rest
range))
=> finish]
;; the function has no rest argument, but provides all the necessary fixed arguments
[(and (not rest) (not drest) (not tail-bound)
(infer vars null
(list (apply -lst* arg-tys #:tail full-tail-ty))
(list (apply -lst* domain))
range))
=> finish]
;; actual work, when we have a * function and ... final arg
[(and rest
tail-bound
(<= (length domain) (length arg-tys))
(infer/vararg vars null
(cons (make-Listof tail-ty) arg-tys)
(cons (make-Listof rest) domain)
rest
range))
=> finish]
;; ... function, ... arg
[(and drest
tail-bound
(eq? tail-bound (cdr drest))
(= (length domain) (length arg-tys))
(infer vars null (cons tail-ty arg-tys) (cons (car drest) domain)
range))
=> finish]
[else #f]))
(match f-ty (match f-ty
[(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) [(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))))
(domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound
#:msg-thunk (lambda (dom) #:msg-thunk (lambda (dom)
(string-append (string-append
"Bad arguments to polymorphic function in apply:\n" "Bad arguments to polymorphic function in apply:\n"
dom)))])] dom)))])))]
;; the actual work, when we have a * function and a list final argument
[(and (car rests*)
(not tail-bound)
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars null
(cons tail-ty arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; the function has no rest argument, but provides all the necessary fixed arguments
[(and (not (car rests*)) (not (car drests*)) (not tail-bound)
(infer vars null
(list (apply -lst* arg-tys #:tail tail-ty))
(list (apply -lst* (car doms*)))
(car rngs*)))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; actual work, when we have a * function and ... final arg
[(and (car rests*)
tail-bound
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars null
(cons (make-Listof tail-ty) arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; ... function, ... arg
[(and (car drests*)
tail-bound
(eq? tail-bound (cdr (car drests*)))
(= (length (car doms*))
(length arg-tys))
(infer vars null (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*))
(car rngs*)))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; if nothing matches, around the loop again
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result1: (Poly: vars (Function: '()))) [(tc-result1: (Poly: vars (Function: '())))
(tc-error/expr "Function has no cases")] (tc-error/expr "Function has no cases")]
[(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var)) [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var))