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

fix Union-fmap bug that skipped some base arg results

Browse Source
This commit is contained in:
Andrew Kent 2017-01-07 21:17:21 -05:00
parent 81255d9a14
commit b0f707b576
2 changed files with 42 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -647,7 +647,6 @@
(cond
[(set-member? elems Univ) Univ]
[else
(set-remove! elems -Bottom)
(match (set-count elems)
[0 base]
[1 #:when (Bottom? base) (set-first elems)]
@ -715,41 +714,39 @@
(define nbits #b0)
(define ts '())
(define elems (mutable-set))
;; process a Base element
(define (process-base! numeric? bits)
;; add a Base element to the union
(define (add-base! numeric? bits)
(cond
[numeric? (set! nbits (nbits-union nbits bits))]
[else (set! bbits (bbits-union bbits bits))]))
;; process a BaseUnion element
(define (process-base-union! bbits* nbits*)
;; add a BaseUnion to the union
(define (add-base-union! bbits* nbits*)
(set! nbits (nbits-union nbits nbits*))
(set! bbits (bbits-union bbits bbits*)))
;; process a type from the 'base' field of a Union
(define (process-any-base! b)
;; add the type from a 'base' field of a Union to this union
(define (add-any-base! b)
(match b
[(Base-bits: numeric? bits) (process-base! numeric? bits)]
[(BaseUnion: bbits* nbits*) (process-base-union! bbits* nbits*)]
;; else Bottom
[_ (void)]))
;; process a list of types
(define (process! args)
(for* ([arg (in-list args)]
[arg (in-value (f arg))])
(match arg
[(Base-bits: numeric? bits) (process-base! numeric? bits)]
[(BaseUnion: bbits* nbits*) (process-base-union! bbits* nbits*)]
[(Union: m* b* ts* _)
(set! m (mask-union m m*))
(process-any-base! b*)
(set! ts (append ts* ts))
(for ([t* (in-list ts*)])
(set-add! elems t*))]
[_ (set! m (mask-union m (mask arg)))
(set! ts (cons arg ts))
(set-add! elems arg)])))
[(? Bottom?) (void)]
[(Base-bits: numeric? bits) (add-base! numeric? bits)]
[(BaseUnion: bbits* nbits*) (add-base-union! bbits* nbits*)]))
;; apply 'f' to a type and add it to the union appropriately
(define (process! arg)
(match (f arg)
[(? Bottom?) (void)]
[(Base-bits: numeric? bits) (add-base! numeric? bits)]
[(BaseUnion: bbits* nbits*) (add-base-union! bbits* nbits*)]
[(Union: m* b* ts* _)
(set! m (mask-union m m*))
(add-any-base! b*)
(set! ts (append ts* ts))
(for ([t* (in-list ts*)])
(set-add! elems t*))]
[t (set! m (mask-union m (mask t)))
(set! ts (cons t ts))
(set-add! elems t)]))
;; process the input arguments
(process-any-base! (f base-arg))
(process! args)
(process! base-arg)
(for-each process! args)
;; construct a BaseUnion (or Base or Bottom) based on the
;; Base data gathered during processing
(define bs (make-BaseUnion bbits nbits))

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

@ -50,6 +50,22 @@
[(Un (-val "one") (-val "two")) (Un (-val "one") (-val 1)) (-val "one")]
;; intersection cases
[(-v a) -String (-unsafe-intersect (-v a) -String)]
[(-v a)
(Un -String (-pair Univ Univ))
(Un (-unsafe-intersect (-v a) -String)
(-unsafe-intersect (-v a) (-pair Univ Univ)))]
[(-v a)
(Un -String -Symbol (-pair Univ Univ))
(Un (-unsafe-intersect (-v a) -String)
(-unsafe-intersect (-v a) -Symbol)
(-unsafe-intersect (-v a) (-pair Univ Univ)))]
[(-v a)
(Un -String -Symbol -Zero -One (-pair Univ Univ))
(Un (-unsafe-intersect (-v a) -String)
(-unsafe-intersect (-v a) -Symbol)
(-unsafe-intersect (-v a) -Zero)
(-unsafe-intersect (-v a) -One)
(-unsafe-intersect (-v a) (-pair Univ Univ)))]
[-String (-v a) (-unsafe-intersect (-v a) -String)]
[(-> -Number -Number) (-> -String -String) (-unsafe-intersect (-> -Number -Number)
(-> -String -String))]