Fixes type of member and assoc, plus some tests for them. See github bug #223: “(member) has wrong type, exploiting the hole causes segfault”.

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))))]
 

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)

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)

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))

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"))

typed-racket-test/unit-tests/typecheck-tests.rkt

@@ -2374,6 +2374,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)