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

Fix base env types that are too conservative

Browse Source 
These accessors and removers required the target value
to have the same type variable as the collection, but
that's more conservative and less useful than Any.

original commit: 098f398a14b816fda66477ed516464c9c15961bb
This commit is contained in:
Asumu Takikawa 2013-12-17 01:31:32 -05:00
parent 4ebfe5617f
commit a0009b5e5d
2 changed files with 32 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -514,18 +514,18 @@
[kernel:reverse (-poly (a) (-> (-lst a) (-lst a)))]
[append (-poly (a) (->* (list) (-lst a) (-lst a)))]
[length (-poly (a) (-> (-lst a) -Index))]
[memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))]
[memv (-poly (a) (-> a (-lst a) (-opt (-lst a))))]
[memq (-poly (a) (-> Univ (-lst a) (-opt (-lst a))))]
[memv (-poly (a) (-> Univ (-lst a) (-opt (-lst a))))]
[memf (-poly (a) ((a . -> . Univ) (-lst a) . -> . (-opt (-lst a))))]
[member (-poly (a)
(cl->* (a (-lst a) . -> . (-opt (-lst a)))
(a (-lst a) (-> a a Univ)
. -> . (-opt (-lst a)))))]
(cl->* (Univ (-lst a) . -> . (-opt (-lst a)))
(Univ (-lst a) (-> a a Univ)
. -> . (-opt (-lst a)))))]
[findf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt a)))]
[assq (-poly (a b) (a (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
[assv (-poly (a b) (a (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
[assoc (-poly (a b) (a (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
[assq (-poly (a b) (Univ (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
[assv (-poly (a b) (Univ (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
[assoc (-poly (a b) (Univ (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
[assf (-poly (a b) ((a . -> . Univ) (-lst (-pair a b))
. -> . (-opt (-pair a b))))]
@ -661,9 +661,9 @@
[vector-fill! (-poly (a) (-> (-vec a) a -Void))]
[vector-argmax (-poly (a) (-> (-> a -Real) (-vec a) a))]
[vector-argmin (-poly (a) (-> (-> a -Real) (-vec a) a))]
[vector-memq (-poly (a) (-> a (-vec a) (-opt -Index)))]
[vector-memv (-poly (a) (-> a (-vec a) (-opt -Index)))]
[vector-member (-poly (a) (a (-vec a) . -> . (-opt -Index)))]
[vector-memq (-poly (a) (-> Univ (-vec a) (-opt -Index)))]
[vector-memv (-poly (a) (-> Univ (-vec a) (-opt -Index)))]
[vector-member (-poly (a) (Univ (-vec a) . -> . (-opt -Index)))]
;; [vector->values no good type here]
;; Section 4.11.1 (racket/vector)
@ -756,8 +756,8 @@
[hash-update (-poly (a b)
(cl-> [((-HT a b) a (-> b b)) (-HT a b)]
[((-HT a b) a (-> b b) (-> b)) (-HT a b)]))]
[hash-remove (-poly (a b) (cl-> [((-HT a b) a) (-HT a b)]
[(-HashTop a) -HashTop]))]
[hash-remove (-poly (a b) (cl-> [((-HT a b) Univ) (-HT a b)]
[(-HashTop Univ) -HashTop]))]
[hash-remove! (-poly (a b) (cl-> [((-HT a b) a) -Void]
[(-HashTop a) -Void]))]
[hash-map (-poly (a b c) (cl-> [((-HT a b) (a b . -> . c)) (-lst c)]
@ -855,7 +855,7 @@
[set-first (-poly (e) (-> (-set e) e))]
[set-rest (-poly (e) (-> (-set e) (-set e)))]
[set-add (-poly (e) (-> (-set e) e (-set e)))]
[set-remove (-poly (e) (-> (-set e) e (-set e)))]
[set-remove (-poly (e) (-> (-set e) Univ (-set e)))]
[set-union (-poly (e) (->* (list (-set e)) (-set e) (-set e)))]
[set-intersect (-poly (a b) (->* (list (-set a)) (-set b) (-set a)))]

18
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -1896,6 +1896,24 @@
[tc-e (remove* '(1 2) '(a b c d)) (-lst (one-of/c 'a 'b 'c 'd))]
[tc-e (remq* '(1 2) '(a b c d)) (-lst (one-of/c 'a 'b 'c 'd))]
[tc-e (remv* '(1 2) '(a b c d)) (-lst (one-of/c 'a 'b 'c 'd))]
;; test functions which do lookup with the "wrong type", where the
;; result type shouldn't be widened to include that type
[tc-e (memq 3 '(a b c)) (t:Un (-val #f) (-lst (one-of/c 'a 'b 'c)))]
[tc-e (memv 3 '(a b c)) (t:Un (-val #f) (-lst (one-of/c 'a 'b 'c)))]
[tc-e (member 3 '(a b c)) (t:Un (-val #f) (-lst (one-of/c 'a 'b 'c)))]
[tc-e (member 3 '(a b c) equal?) (t:Un (-val #f) (-lst (one-of/c 'a 'b 'c)))]
[tc-e (assq 3 '((a . 5) (b . 7))) (t:Un (-val #f) (-pair (one-of/c 'a 'b) -PosByte))]
[tc-e (assv 3 '((a . 5) (b . 7))) (t:Un (-val #f) (-pair (one-of/c 'a 'b) -PosByte))]
[tc-e (assoc 3 '((a . 5) (b . 7))) (t:Un (-val #f) (-pair (one-of/c 'a 'b) -PosByte))]
[tc-e (set-remove (set 1 2 3) 'a) (-set -PosByte)]
;; don't return HashTableTop
[tc-e (hash-remove #hash((a . 5) (b . 7)) 3) (-HT -Symbol -Integer)]
[tc-e (hash-remove #hash((a . 5) (b . 7)) 3) (-HT -Symbol -Integer)]
;; these should actually work
[tc-e (vector-memq 3 #(a b c)) (t:Un (-val #f) -Index)]
[tc-e (vector-memv 3 #(a b c)) (t:Un (-val #f) -Index)]
[tc-e (vector-member 3 #(a b c)) (t:Un (-val #f) -Index)]
)
(test-suite
"tc-literal tests"