From fef4b28b88a403c02d06f5a39552ea2616e831b6 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 3 Sep 2013 18:12:51 -0400 Subject: [PATCH] Refactoring. --- .../typed-racket/typecheck/tc-app-helper.rkt | 178 +++++++++--------- 1 file changed, 84 insertions(+), 94 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt index 8e46cfc466..59ca4911e5 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt @@ -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))] + + [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))) - ;; 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)) + (cons p parts-res))) - ;; 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 - - (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