diff --git a/typed-racket-lib/typed-racket/base-env/base-env.rkt b/typed-racket-lib/typed-racket/base-env/base-env.rkt index 3168cad5..83478480 100644 --- a/typed-racket-lib/typed-racket/base-env/base-env.rkt +++ b/typed-racket-lib/typed-racket/base-env/base-env.rkt @@ -632,15 +632,18 @@ [memq (-poly (a) (-> Univ (-lst a) (-opt (-ne-lst a))))] [memv (-poly (a) (-> Univ (-lst a) (-opt (-ne-lst a))))] [memf (-poly (a) ((a . -> . Univ) (-lst a) . -> . (-opt (-ne-lst a))))] -[member (-poly (a) +[member (-poly (a b) (cl->* (Univ (-lst a) . -> . (-opt (-ne-lst a))) - (Univ (-lst a) (-> a a Univ) + (b (-lst a) (-> b a Univ) . -> . (-opt (-ne-lst a)))))] [findf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt a)))] [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))))] +[assoc (-poly (a b c) + (cl->* (Univ (-lst (-pair a b)) . -> . (-opt (-pair a b))) + (c (-lst (-pair a b)) (-> c a Univ) + . -> . (-opt (-pair a b)))))] [assf (-poly (a b) ((a . -> . Univ) (-lst (-pair a b)) . -> . (-opt (-pair a b))))] diff --git a/typed-racket-test/fail/assoc-with-is-equal-argument.rkt b/typed-racket-test/fail/assoc-with-is-equal-argument.rkt new file mode 100644 index 00000000..92d9f0fe --- /dev/null +++ b/typed-racket-test/fail/assoc-with-is-equal-argument.rkt @@ -0,0 +1,9 @@ +#lang typed/racket + +(: equal-string-length (→ String String Boolean)) +(define (equal-string-length s1 s2) + (= (string-length s1) (string-length s2))) + +(assoc 123 + '(("bb" . 1) ("c" . 2) ("ddd" . 3)) + equal-string-length) diff --git a/typed-racket-test/fail/member-with-is-equal-argument.rkt b/typed-racket-test/fail/member-with-is-equal-argument.rkt new file mode 100644 index 00000000..807023e2 --- /dev/null +++ b/typed-racket-test/fail/member-with-is-equal-argument.rkt @@ -0,0 +1,9 @@ +#lang typed/racket + +(: equal-string-length (→ String String Boolean)) +(define (equal-string-length s1 s2) + (= (string-length s1) (string-length s2))) + +(member 123 + '("bb" "c" "ddd") + equal-string-length) diff --git a/typed-racket-test/succeed/assoc-with-is-equal-argument.rkt b/typed-racket-test/succeed/assoc-with-is-equal-argument.rkt new file mode 100644 index 00000000..ff8eacc3 --- /dev/null +++ b/typed-racket-test/succeed/assoc-with-is-equal-argument.rkt @@ -0,0 +1,28 @@ +#lang typed/racket + +(require typed/rackunit) + +;; Test that (assoc v lst is-equal?) always passes v as the first argument to +;; is-equal? . If this is not the case, the type for the is-equal? argument +;; should be (→ (U a c) (U a c) Any) instead of (→ c a Any). +(let ([needle : Integer + ;; Use a random needle to prevent some optimizations (but not all) + (floor (inexact->exact (* (random) 200)))]) + (assoc needle + (ann (map (λ ([x : Integer]) (cons x (format "~a" x))) (range 1000)) + (Listof (Pairof Integer String))) + (λ ([x : Integer] [y : Integer]) + ;; Check the needle is always the first argument + (check-equal? x needle) + ;; Check y = needle implies x = needle + (check-true (or (not (= y needle)) (= x needle))) + (= x y)))) + +;; Test that the third is-equal? argument is taken into account. If it is taken +;; into account, it will return '("c" . 2). If it isn't, it will return +;; '("x" . 4) instead. +(check-equal? (assoc "x" + '(("bb" . 1) ("c" . 2) ("ddd" . 3) ("x" . 4)) + (lambda ([s1 : String] [s2 : String]) + (= (string-length s1) (string-length s2)))) + '("c" . 2)) diff --git a/typed-racket-test/succeed/member-with-is-equal-argument.rkt b/typed-racket-test/succeed/member-with-is-equal-argument.rkt new file mode 100644 index 00000000..97a28902 --- /dev/null +++ b/typed-racket-test/succeed/member-with-is-equal-argument.rkt @@ -0,0 +1,30 @@ +#lang typed/racket + +(require typed/rackunit) + +;; Test that (member v lst is-equal?) always passes v as the first argument to +;; is-equal? . If this is not the case, the type for the is-equal? argument +;; should be (→ (U a b) (U a b) Any) instead of (→ b a Any). + +(let ([needle : Integer + ;; Use a random needle to prevent some optimizations (but not all) + (floor (inexact->exact (* (random) 200)))]) + (member needle + (range 1000) + (λ ([x : Integer] [y : Integer]) + ;; Check the needle is always the first argument + (check-equal? x needle) + ;; Check y = needle implies x = needle + (check-true (or (not (= y needle)) (= x needle))) + (= x y)))) + +;; Test that the third is-equal? argument is taken into account. If it is taken +;; into account, it will return '("c" "ddd" "x"). If it isn't, it will return +;; '("x") instead. +(check-equal? (member "x" + '("bb" "c" "ddd" "x") + (lambda ([s1 : String] [s2 : String]) + (= (string-length s1) (string-length s2)))) + '("c" "ddd" "x")) + +(check-equal? (member "x" '("bb" "c" "ddd" "x")) '("x")) diff --git a/typed-racket-test/unit-tests/typecheck-tests.rkt b/typed-racket-test/unit-tests/typecheck-tests.rkt index b927cdcf..408901a0 100644 --- a/typed-racket-test/unit-tests/typecheck-tests.rkt +++ b/typed-racket-test/unit-tests/typecheck-tests.rkt @@ -2380,6 +2380,31 @@ [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)] + ;; Allow needle to be a subtype of the first argument of is-equal? + ;; The result type shouldn't be widened to include that type though. + [tc-e (member 3 + '(a b c) + (lambda: ([s1 : (U Number Symbol String)] [s2 : Symbol]) + (= (string-length (format "~a" s1)) + (string-length (symbol->string s2))))) + (t:Un (-val #f) + (-pair (one-of/c 'a 'b 'c) (-lst (one-of/c 'a 'b 'c))))] + [tc-e (assoc 3 + '((a . #(a)) (b . #(b)) (c . #(c))) + (lambda: ([s1 : (U Number Symbol String)] [s2 : Symbol]) + (= (string-length (format "~a" s1)) + (string-length (symbol->string s2))))) + (t:Un (-val #f) (-pair (one-of/c 'a 'b 'c) (-vec* -Symbol)))] + ;; Reject `member` when needle not included in is-equal?'s argument type: + [tc-err (member (ann 123 Number) + '("bb" "c" "ddd") + (lambda ([s1 : String] [s2 : String]) + (= (string-length s1) (string-length s2))))] + ;; Reject `assoc` when needle not included in is-equal?'s argument type: + [tc-err (assoc (ann 123 Number) + '(("bb" . 123) ("c" . 123) ("ddd" . 123)) + (lambda ([s1 : String] [s2 : String]) + (= (string-length s1) (string-length s2))))] ;; tests for struct type types [tc-e (let-values ([(_1 _2 _3 _4 _5 _6 parent _7)