From a0009b5e5d908320e44df34efc8eb6aa6d3ac973 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 17 Dec 2013 01:31:32 -0500 Subject: [PATCH] Fix base env types that are too conservative 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 --- .../typed-racket/base-env/base-env.rkt | 28 +++++++++---------- .../unit-tests/typecheck-tests.rkt | 18 ++++++++++++ 2 files changed, 32 insertions(+), 14 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt index 042039c2..97ab0238 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt @@ -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)))] diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index b0537ae3..f719a68d 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -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"