From 7f9784775fb41b790a53d32ca816692682a57ce1 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 9 Apr 2020 15:35:36 -0500
Subject: [PATCH] fixes a bug in case->, closes #3098

also use the contract equivalence predicate instead of
two calls to contract stronger
---
 .../tests/racket/contract/case-arrow.rkt          | 15 ++++++++++++++-
 .../racket/contract/private/case-arrow.rkt        | 12 ++++++------
 2 files changed, 20 insertions(+), 7 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/case-arrow.rkt b/pkgs/racket-test/tests/racket/contract/case-arrow.rkt
index 66bca58ac3..146b534672 100644
--- a/pkgs/racket-test/tests/racket/contract/case-arrow.rkt
+++ b/pkgs/racket-test/tests/racket/contract/case-arrow.rkt
@@ -182,6 +182,19 @@
                  [(x) 1])
                'pos 'neg)
      1))
+
+  (test/spec-passed/result
+   'contract->case->16
+   '((contract
+      (case-> (-> #f any)
+              (-> #t #f any/c))
+      (case-lambda
+        [(x) x]
+        [(y z) z])
+      'pos
+      'neg)
+     #f)
+   #f)
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;                                                        ;;
@@ -192,4 +205,4 @@
   (test/well-formed '(case-> (-> integer? integer?)))
   (test/well-formed '(case-> (-> integer? integer?) (-> integer? integer? integer?)))
   (test/well-formed '(case-> (-> integer? integer?) (-> integer? integer? any)))
-  (test/well-formed '(case-> (-> integer? any) (-> integer? integer? any))))
\ No newline at end of file
+  (test/well-formed '(case-> (-> integer? any) (-> integer? integer? any))))
diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt
index 63009c9d88..e5739da75c 100644
--- a/racket/collects/racket/contract/private/case-arrow.rkt
+++ b/racket/collects/racket/contract/private/case-arrow.rkt
@@ -191,8 +191,8 @@
                        "expected no keywords, got keyword ~a" (car kwds))))
 
 ;; dom-ctcs : (listof (listof contract))
-;; rst-ctcs : (listof contract)
-;; rng-ctcs : (listof (listof contract))
+;; rst-ctcs : (listof (or/c #f contract))
+;; rng-ctcs : (listof (or/c #f (listof contract)))
 ;; specs : (listof (list boolean exact-positive-integer)) 
 ;;     indicates the required arities of the input functions
 ;; mctc? : was created with case->m or object-contract
@@ -334,7 +334,7 @@
              #:when x)
     (append acc x)))
 
-;; Takes a list of (listof projection), and returns one of the
+;; Takes a list of (or/c #f (listof projection)), and returns one of the
 ;; lists if all the lists contain the same projections. If the list is
 ;; null, it returns #f.
 (define (same-range-contracts rng-ctcss)
@@ -342,11 +342,11 @@
     [(null? rng-ctcss) #f]
     [else
      (define fst (car rng-ctcss))
-     (and (for/and ([ps (in-list (cdr rng-ctcss))])
+     (and fst
+          (for/and ([ps (in-list (cdr rng-ctcss))])
             (and ps
                  (= (length fst) (length ps))
                  (for/and ([c (in-list ps)]
                            [fst-c (in-list fst)])
-                   (and (contract-struct-stronger? c fst-c)
-                        (contract-struct-stronger? fst-c c)))))
+                   (contract-struct-equivalent? c fst-c))))
           fst)]))