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

better rec type intersection

Browse Source
This commit is contained in:
Andrew Kent 2016-07-05 21:55:09 -04:00
parent 8c0a5a0b3e
commit 39d6a6047a
2 changed files with 17 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
typed-racket-lib/typed-racket/infer/intersect.rkt
View File

@ -22,7 +22,7 @@
;; subtyping performs a similar check for the same
;; reason
(let intersect
([t1 t1] [t2 t2] [resolved (set)])
([t1 t1] [t2 t2] [resolved '()])
(match*/no-order
(t1 t2)
;; already a subtype
@ -62,10 +62,15 @@
;; resolve resolvable types if we haven't already done so
[((? needs-resolving? t1) t2)
#:no-order
#:when (not (or (set-member? resolved (cons t1 t2))
(set-member? resolved (cons t2 t1))))
(intersect (resolve t1) t2 (set-add resolved (cons t1 t2)))]
#:when (not (member (cons t1 t2) resolved))
(intersect (resolve t1) t2 (cons (cons t1 t2) resolved))]
;; if we're intersecting two recursive types, intersect their body
;; and have their recursive references point back to the result
[((? Mu?) (? Mu?))
(define name (gensym))
(make-Mu name (intersect (Mu-body name t1) (Mu-body name t2) resolved))]
;; t2 and t1 have a complex relationship, so we build an intersection
;; (note: intersection checks for overlap)
[(t1 t2) (-unsafe-intersect t1 t2)])))

8
typed-racket-test/unit-tests/remove-intersect-tests.rkt
View File

@ -52,7 +52,13 @@
[(-v a) -String (-unsafe-intersect (-v a) -String)]
[-String (-v a) (-unsafe-intersect (-v a) -String)]
[(-> -Number -Number) (-> -String -String) (-unsafe-intersect (-> -Number -Number)
(-> -String -String))]))
(-> -String -String))]
[(-mu x (Un (Un -Number -String) (-pair -Number x)))
(-mu x (Un (Un -Number -Symbol) (-pair -Number x)))
(-mu x (Un -Number (-pair -Number x)))]
[(make-Listof (-mu x (Un -String (-HT -String x))))
(make-Listof (make-HashtableTop))
(make-Listof (-HT -String (-mu x (Un -String (-HT -String x)))))]))
(define-syntax (remo-tests stx)
(syntax-case stx ()