suzanne.soy/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.
This commit is contained in:
Asumu Takikawa 2013-12-17 01:31:32 -05:00
parent 7060bdd0f8
commit 098f398a14
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)))] [kernel:reverse (-poly (a) (-> (-lst a) (-lst a)))]
[append (-poly (a) (->* (list) (-lst a) (-lst a)))] [append (-poly (a) (->* (list) (-lst a) (-lst a)))]
[length (-poly (a) (-> (-lst a) -Index))] [length (-poly (a) (-> (-lst a) -Index))]
[memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))] [memq (-poly (a) (-> Univ (-lst a) (-opt (-lst a))))]
[memv (-poly (a) (-> a (-lst a) (-opt (-lst a))))] [memv (-poly (a) (-> Univ (-lst a) (-opt (-lst a))))]
[memf (-poly (a) ((a . -> . Univ) (-lst a) . -> . (-opt (-lst a))))] [memf (-poly (a) ((a . -> . Univ) (-lst a) . -> . (-opt (-lst a))))]
[member (-poly (a) [member (-poly (a)
(cl->* (a (-lst a) . -> . (-opt (-lst a))) (cl->* (Univ (-lst a) . -> . (-opt (-lst a)))
(a (-lst a) (-> a a Univ) (Univ (-lst a) (-> a a Univ)
. -> . (-opt (-lst a)))))] . -> . (-opt (-lst a)))))]
[findf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt a)))] [findf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt a)))]
[assq (-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) (a (-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) (a (-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)) [assf (-poly (a b) ((a . -> . Univ) (-lst (-pair a b))
. -> . (-opt (-pair a b))))] . -> . (-opt (-pair a b))))]
@ -661,9 +661,9 @@
[vector-fill! (-poly (a) (-> (-vec a) a -Void))] [vector-fill! (-poly (a) (-> (-vec a) a -Void))]
[vector-argmax (-poly (a) (-> (-> a -Real) (-vec a) a))] [vector-argmax (-poly (a) (-> (-> a -Real) (-vec a) a))]
[vector-argmin (-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-memq (-poly (a) (-> Univ (-vec a) (-opt -Index)))]
[vector-memv (-poly (a) (-> a (-vec a) (-opt -Index)))] [vector-memv (-poly (a) (-> Univ (-vec a) (-opt -Index)))]
[vector-member (-poly (a) (a (-vec a) . -> . (-opt -Index)))] [vector-member (-poly (a) (Univ (-vec a) . -> . (-opt -Index)))]
;; [vector->values no good type here] ;; [vector->values no good type here]
;; Section 4.11.1 (racket/vector) ;; Section 4.11.1 (racket/vector)
@ -756,8 +756,8 @@
[hash-update (-poly (a b) [hash-update (-poly (a b)
(cl-> [((-HT a b) a (-> b b)) (-HT a b)] (cl-> [((-HT a b) a (-> b b)) (-HT a b)]
[((-HT a b) a (-> b 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)] [hash-remove (-poly (a b) (cl-> [((-HT a b) Univ) (-HT a b)]
[(-HashTop a) -HashTop]))] [(-HashTop Univ) -HashTop]))]
[hash-remove! (-poly (a b) (cl-> [((-HT a b) a) -Void] [hash-remove! (-poly (a b) (cl-> [((-HT a b) a) -Void]
[(-HashTop a) -Void]))] [(-HashTop a) -Void]))]
[hash-map (-poly (a b c) (cl-> [((-HT a b) (a b . -> . c)) (-lst c)] [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-first (-poly (e) (-> (-set e) e))]
[set-rest (-poly (e) (-> (-set e) (-set e)))] [set-rest (-poly (e) (-> (-set e) (-set e)))]
[set-add (-poly (e) (-> (-set e) 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-union (-poly (e) (->* (list (-set e)) (-set e) (-set e)))]
[set-intersect (-poly (a b) (->* (list (-set a)) (-set b) (-set a)))] [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 (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 (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))] [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 (test-suite
"tc-literal tests" "tc-literal tests"