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

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

@ -248,65 +248,55 @@
;; 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)
(for/fold ([candidates '()] ; from cases
[parts-acc '()]) ; from orig
([c (in-list cases)]
;; the parts we'll need to print the error message ;; the parts we'll need to print the error message
[parts orig] [p (in-list orig)])
;; accumulators (if (returns-subtype-of-expected? c)
[candidates '()] ; from cases (values (cons c candidates) ; we keep this one
[parts-acc '()]) ; from parts (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
(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
(let ([fun-tys-ret-any
(map (match-lambda (map (match-lambda
[(Function: (list (arr: dom _ rest drest _))) [(Function: (list (arr: dom _ rest drest _)))
(make-Function (list (make-arr dom (make-Function (list (make-arr dom
(-values (list Univ)) (-values (list Univ))
rest drest null)))]) rest drest null)))])
candidates)]) candidates))
;; Heuristic: often, the last case in the definition (first at ;; Heuristic: often, the last case in the definition (first at this
;; this point, we've reversed the list) is the most general of ;; point, we've reversed the list) is the most general of all, subsuming
;; all, subsuming all the others. If that's the case, just go ;; all the others. If that's the case, just go with it. Otherwise, go
;; with it. Otherwise, go the slow way. ;; the slow way.
(if (and (not (null? fun-tys-ret-any)) (cond [(and (not (null? fun-tys-ret-any))
(andmap (lambda (c) (subtype (car fun-tys-ret-any) c)) (andmap (lambda (c) (subtype (car fun-tys-ret-any) c))
fun-tys-ret-any)) fun-tys-ret-any))
;; Yep. Return early. ;; Yep. Return early.
(map list (car parts-acc)) (map list (car parts-acc))]
[else
;; No luck, do it the slow way ;; No luck, do it the slow way
(let loop ([cases fun-tys-ret-any] (define parts-res
[parts parts-acc] ;; final pass, we only need the parts to print the error message
;; accumulators (for/fold ([parts-res '()])
;; final pass, we only need the parts to print the ([c (in-list fun-tys-ret-any)]
;; error message [p (in-list parts-acc)]
[parts-acc '()])
(if (not (null? cases))
;; if a case is a supertype of another, we discard it ;; if a case is a supertype of another, we discard it
(let ([head (car cases)]) #:unless (is-subsumed-in? c (remove c fun-tys-ret-any)))
(if (is-subsumed-in? head (remove head fun-tys-ret-any))
(loop (cdr cases) (cdr parts) (cons p parts-res)))
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