Change CaseAlt and LambdaExpr to FunRhs in deriving Foldable and Traversable (#20496)

5 files changed, 70 insertions, 3 deletions

diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index b862641e01..bc22c6f7c9 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -807,12 +807,15 @@ gen_Foldable_binds loc tycon tycon_args
   where
     data_cons = getPossibleDataCons tycon tycon_args
 
+    foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR
+
     foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns
     eqns = map foldr_eqn data_cons
     foldr_eqn con
       = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
       where
         parts = sequence $ foldDataConArgs ft_foldr con
+    foldr_match_ctxt = mkPrefixFunRhs foldr_name
 
     foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
 
@@ -826,6 +829,7 @@ gen_Foldable_binds loc tycon tycon_args
       = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
       where
         parts = sequence $ foldDataConArgs ft_foldMap con
+    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
 
     -- Given a list of NullM results, produce Nothing if any of
     -- them is NotNull, and otherwise produce a list of Maybes
@@ -881,7 +885,7 @@ gen_Foldable_binds loc tycon tycon_args
                 -> DataCon
                 -> [Maybe (LHsExpr GhcPs)]
                 -> m (LMatch GhcPs (LHsExpr GhcPs))
-    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
+    match_foldr z = mkSimpleConMatch2 foldr_match_ctxt $ \_ xs -> return (mkFoldr xs)
       where
         -- g1 v1 (g2 v2 (.. z))
         mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
@@ -911,7 +915,7 @@ gen_Foldable_binds loc tycon tycon_args
                   -> DataCon
                   -> [Maybe (LHsExpr GhcPs)]
                   -> m (LMatch GhcPs (LHsExpr GhcPs))
-    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
+    match_foldMap = mkSimpleConMatch2 foldMap_match_ctxt $ \_ xs -> return (mkFoldMap xs)
       where
         -- mappend v1 (mappend v2 ..)
         mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
@@ -1042,6 +1046,7 @@ gen_Traversable_binds loc tycon tycon_args
       = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
       where
         parts = sequence $ foldDataConArgs ft_trav con
+    traverse_match_ctxt = mkPrefixFunRhs traverse_name
 
     -- Yields 'Just' an expression if we're folding over a type that mentions
     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
@@ -1072,7 +1077,7 @@ gen_Traversable_binds loc tycon tycon_args
                   -> DataCon
                   -> [Maybe (LHsExpr GhcPs)]
                   -> m (LMatch GhcPs (LHsExpr GhcPs))
-    match_for_con = mkSimpleConMatch2 CaseAlt $
+    match_for_con = mkSimpleConMatch2 traverse_match_ctxt $
                                              \con xs -> return (mkApCon con xs)
       where
         -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py
index 20b4181004..efeaa94b89 100644
--- a/testsuite/driver/testlib.py
+++ b/testsuite/driver/testlib.py
@@ -805,6 +805,12 @@ def grep_errmsg(needle):
         return "".join(filter(lambda l: re.search(needle, l), str.splitlines(True)))
     return normalise_errmsg_fun(norm)
 
+def multiline_grep_errmsg(needle):
+    def norm(s):
+        match = re.search(needle, s)
+        return "" if match is None else match.group(0)
+    return normalise_errmsg_fun(norm)
+
 def normalise_whitespace_fun(f):
     return lambda name, opts: _normalise_whitespace_fun(name, opts, f)
 
diff --git a/testsuite/tests/deriving/should_compile/T20496.hs b/testsuite/tests/deriving/should_compile/T20496.hs
new file mode 100644
index 0000000000..dc05ea9d22
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T20496.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DeriveFoldable, DeriveTraversable, EmptyDataDecls, RoleAnnotations #-}
+module T20496 where
+
+data T b = MkT b
+  deriving (Functor, Foldable, Traversable)
+
+data Trixie a
+  deriving (Functor, Foldable, Traversable)
+
+type role UhOh nominal
+data UhOh a
+  deriving (Functor, Foldable, Traversable)
+
+type role UhOh2 representational
+data UhOh2 a
+  deriving (Functor, Foldable, Traversable)
diff --git a/testsuite/tests/deriving/should_compile/T20496.stderr b/testsuite/tests/deriving/should_compile/T20496.stderr
new file mode 100644
index 0000000000..42257bc926
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T20496.stderr
@@ -0,0 +1,36 @@
+rnd
+  instance Functor UhOh2 where
+    fmap _ z = case z of {}
+    (<$) _ z = case z of {}
+  
+  instance Foldable UhOh2 where foldMap _ z = mempty
+  
+  instance Traversable UhOh2 where traverse _ z = pure (case z of {})
+  
+  instance Functor UhOh where
+    fmap _ z = case z of {}
+    (<$) _ z = case z of {}
+  
+  instance Foldable UhOh where foldMap _ z = mempty
+  
+  instance Traversable UhOh where traverse _ z = pure (case z of {})
+  
+  instance Functor Trixie where fmap _ = GHC.Prim.coerce
+  
+  instance Foldable Trixie where foldMap _ _ = mempty
+  
+  instance Traversable Trixie where
+    traverse _ z = pure (GHC.Prim.coerce z)
+  
+  instance Functor T where
+    fmap f (MkT a1) = MkT (f a1)
+    (<$) z (MkT a1) = MkT z
+  
+  instance Foldable T where
+    foldr f z (MkT a1) = f a1 z
+    foldMap f (MkT a1) = f a1
+    null (MkT _) = False
+  
+  instance Traversable T where
+    traverse f (MkT a1) = fmap (\ b1 -> MkT b1) (f a1)
+
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 97c3865f4b..87908020f6 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -128,3 +128,7 @@ test('T17880', normal, compile, [''])
 test('T18055', normal, compile, [''])
 test('T18321', normal, compile, [''])
 test('T18914', normal, compile, [''])
+# We need to find derived instances in the Tc trace dump.
+# They are printed in tcDeriv beginning with "rnd" line
+# and are indented with spaces.
+test('T20496', multiline_grep_errmsg(r"rnd\n( .*\n)*"), compile, ['-ddump-tc-trace'])