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

Fuse loops in promote-demote.

Browse Source
This commit is contained in:
Eric Dobson 2014-05-27 09:02:33 -07:00
parent 2b33b8d966
commit d2d9b2cce3
1 changed files with 22 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/promote-demote.rkt
View File

@ -37,29 +37,31 @@
(define (co t) (structural-recur t 'co)) (define (co t) (structural-recur t 'co))
(define (contra t) (structural-recur t 'contra)) (define (contra t) (structural-recur t 'contra))
;; arr? -> (or/c #f arr?)
;; Returns the changed arr or #f if there is no arr above it
(define (arr-change arr)
(match arr
[(arr: dom rng rest drest kws)
(cond
[(apply V-in? V (get-filters rng))
#f]
[(and drest (memq (cdr drest) V))
(make-arr (map contra dom)
(co rng)
(contra (car drest))
#f
(map contra kws))]
[else
(make-arr (map contra dom)
(co rng)
(and rest (contra rest))
(and drest (cons (contra (car drest)) (cdr drest)))
(map contra kws))])]))
(match T (match T
[(F: name) (if (memq name V) (if change Univ -Bottom) T)] [(F: name) (if (memq name V) (if change Univ -Bottom) T)]
[(Function: arrs) [(Function: arrs)
(make-Function (make-Function (filter-map arr-change arrs))]
(filter values
(for/list ([arr (in-list arrs)])
(match arr
[(arr: dom rng rest drest kws)
(cond
[(apply V-in? V (get-filters rng))
#f]
[(and drest (memq (cdr drest) V))
(make-arr (map contra dom)
(co rng)
(contra (car drest))
#f
(map contra kws))]
[else
(make-arr (map contra dom)
(co rng)
(and rest (contra rest))
(and drest (cons (contra (car drest)) (cdr drest)))
(map contra kws))])]))))]
[(? structural?) (structural-map T structural-recur)] [(? structural?) (structural-map T structural-recur)]
[(? Filter?) ((sub-f co) T)] [(? Filter?) ((sub-f co) T)]
[(? Object?) ((sub-o co) T)] [(? Object?) ((sub-o co) T)]