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