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

Refactoring.

Browse Source
This commit is contained in:
Vincent St-Amour 2013-09-03 18:12:51 -04:00
parent 6ffc3eb7b6
commit fef4b28b88
1 changed files with 84 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

176
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -205,108 +205,98 @@
;; is not necessary to get the expected type ;; is not necessary to get the expected type
(define (possible-domains doms rests drests rngs expected) (define (possible-domains doms rests drests rngs expected)
;; is fun-ty subsumed by a function type in others? ;; is fun-ty subsumed by a function type in others?
(define (is-subsumed-in? fun-ty others) (define (is-subsumed-in? fun-ty others)
;; a case subsumes another if the first one is a subtype of the other ;; a case subsumes another if the first one is a subtype of the other
(ormap (lambda (x) (subtype x fun-ty)) (ormap (lambda (x) (subtype x fun-ty))
others)) others))
;; currently does not take advantage of multi-valued or arbitrary-valued expected types, ;; currently does not take advantage of multi-valued or arbitrary-valued expected types,
(define expected-ty (define expected-ty
(and expected (and expected
(match expected (match expected
[(tc-result1: t) t] [(tc-result1: t) t]
[(tc-any-results:) #t] ; anything is a subtype of expected [(tc-any-results:) #t] ; anything is a subtype of expected
[_ #f]))) ; don't know what it is, don't do any pruning [_ #f]))) ; don't know what it is, don't do any pruning
(define (returns-subtype-of-expected? fun-ty) (define (returns-subtype-of-expected? fun-ty)
(or (not expected) ; no expected type, anything is fine (or (not expected) ; no expected type, anything is fine
(eq? expected-ty #t) ; expected is tc-anyresults, anything is fine (eq? expected-ty #t) ; expected is tc-anyresults, anything is fine
(and expected-ty ; not some unknown expected tc-result (and expected-ty ; not some unknown expected tc-result
(match fun-ty (match fun-ty
[(Function: (list (arr: _ rng _ _ _))) [(Function: (list (arr: _ rng _ _ _)))
(let ([rng (match rng (let ([rng (match rng
[(Values: (list (Result: t _ _))) [(Values: (list (Result: t _ _)))
t] t]
[(ValuesDots: (list (Result: t _ _)) _ _) [(ValuesDots: (list (Result: t _ _)) _ _)
t])]) t])])
(subtype rng expected-ty))])))) (subtype rng expected-ty))]))))
(define orig (map list doms rngs rests drests)) (define orig (map list doms rngs rests drests))
(define cases (define cases
(map (compose make-Function list make-arr) (map (compose make-Function list make-arr)
doms doms
(map (match-lambda ; strip filters (map (match-lambda ; strip filters
[(AnyValues:) ManyUniv] [(AnyValues:) ManyUniv]
[(Values: (list (Result: t _ _) ...)) [(Values: (list (Result: t _ _) ...))
(-values t)] (-values t)]
[(ValuesDots: (list (Result: t _ _) ...) _ _) [(ValuesDots: (list (Result: t _ _) ...) _ _)
(-values t)]) (-values t)])
rngs) rngs)
rests drests (make-list (length doms) null))) rests drests (make-list (length doms) null)))
;; iterate in lock step over the function types we analyze and the parts ;; iterate in lock step over the function types we analyze and the parts
;; that we will need to print the error message, to make sure we throw ;; that we will need to print the error message, to make sure we throw
;; away cases consistently ;; away cases consistently
(let loop ([cases cases] (define-values (candidates parts-acc)
;; the parts we'll need to print the error message (for/fold ([candidates '()] ; from cases
[parts orig] [parts-acc '()]) ; from orig
;; accumulators ([c (in-list cases)]
[candidates '()] ; from cases ;; the parts we'll need to print the error message
[parts-acc '()]) ; from parts [p (in-list orig)])
(if (returns-subtype-of-expected? c)
(values (cons c candidates) ; we keep this one
(cons p parts-acc))
;; we discard this one
(values candidates parts-acc))))
;; keep only the domains for which the associated function type ;; among the domains that fit with the expected type, we only need to
;; is consistent with the expected type ;; keep the most liberal
(if (not (null? cases)) ;; since we only care about permissiveness of domains, we reconstruct
(if (returns-subtype-of-expected? (car cases)) ;; function types with a return type of any then test for subtyping
(loop (cdr cases) (cdr parts) (define fun-tys-ret-any
(cons (car cases) candidates) ; we keep this one (map (match-lambda
(cons (car parts) parts-acc)) [(Function: (list (arr: dom _ rest drest _)))
(loop (cdr cases) (cdr parts) (make-Function (list (make-arr dom
candidates parts-acc)) ; we discard this one (-values (list Univ))
rest drest null)))])
candidates))
;; among the domains that fit with the expected type, we only ;; Heuristic: often, the last case in the definition (first at this
;; need to keep the most liberal ;; point, we've reversed the list) is the most general of all, subsuming
;; since we only care about permissiveness of domains, we ;; all the others. If that's the case, just go with it. Otherwise, go
;; reconstruct function types with a return type of any then test ;; the slow way.
;; for subtyping (cond [(and (not (null? fun-tys-ret-any))
(let ([fun-tys-ret-any (andmap (lambda (c) (subtype (car fun-tys-ret-any) c))
(map (match-lambda fun-tys-ret-any))
[(Function: (list (arr: dom _ rest drest _))) ;; Yep. Return early.
(make-Function (list (make-arr dom (map list (car parts-acc))]
(-values (list Univ))
rest drest null)))])
candidates)])
;; Heuristic: often, the last case in the definition (first at [else
;; this point, we've reversed the list) is the most general of ;; No luck, do it the slow way
;; all, subsuming all the others. If that's the case, just go (define parts-res
;; with it. Otherwise, go the slow way. ;; final pass, we only need the parts to print the error message
(if (and (not (null? fun-tys-ret-any)) (for/fold ([parts-res '()])
(andmap (lambda (c) (subtype (car fun-tys-ret-any) c)) ([c (in-list fun-tys-ret-any)]
fun-tys-ret-any)) [p (in-list parts-acc)]
;; Yep. Return early. ;; if a case is a supertype of another, we discard it
(map list (car parts-acc)) #:unless (is-subsumed-in? c (remove c fun-tys-ret-any)))
;; No luck, do it the slow way (cons p parts-res)))
(let loop ([cases fun-tys-ret-any]
[parts parts-acc]
;; accumulators
;; final pass, we only need the parts to print the
;; error message
[parts-acc '()])
(if (not (null? cases))
;; if a case is a supertype of another, we discard it
(let ([head (car cases)])
(if (is-subsumed-in? head (remove head fun-tys-ret-any))
(loop (cdr cases) (cdr parts)
parts-acc) ; we discard this one
(loop (cdr cases) (cdr parts)
(cons (car parts) parts-acc)))) ; we keep this one
(call-with-values (call-with-values
(lambda () (unzip4 (reverse parts-acc))) (lambda () (unzip4 (reverse parts-res)))
list)))))))) list)]))
;; Wrapper over possible-domains that works on types. ;; Wrapper over possible-domains that works on types.
(provide/cond-contract (provide/cond-contract