DeriveGeneric: look up datacon fixities using getDataConFixityFunwip/T20994

Previously, `DeriveGeneric` would look up the fixity of a data constructor
using `getFixityEnv`, but this is subtly incorrect for data constructors
defined in external modules. This sort of situation can happen with
`StandaloneDeriving`, as noticed in #20994. In fact, the same bug has occurred
in the past in #9830, and while that bug was fixed for `deriving Read` and
`deriving Show`, the fix was never extended to `DeriveGeneric` due to an
oversight. This patch corrects that oversight.

Fixes #20994.

4 files changed, 49 insertions, 19 deletions

diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index a6969170c9..56b7e0de09 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -37,7 +37,6 @@ import GHC.Unit.Module ( moduleName, moduleNameFS
 import GHC.Iface.Env    ( newGlobalBinder )
 import GHC.Types.Name hiding ( varName )
 import GHC.Types.Name.Reader
-import GHC.Types.Fixity.Env
 import GHC.Types.SourceText
 import GHC.Types.Fixity
 import GHC.Types.Basic
@@ -77,11 +76,11 @@ For the generic representation we need to generate:
 \end{itemize}
 -}
 
-gen_Generic_binds :: GenericKind -> [Type] -> DerivInstTys
+gen_Generic_binds :: GenericKind -> (Name -> Fixity) -> [Type] -> DerivInstTys
                   -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)
-gen_Generic_binds gk inst_tys dit = do
+gen_Generic_binds gk get_fixity inst_tys dit = do
   dflags <- getDynFlags
-  repTyInsts <- tc_mkRepFamInsts gk inst_tys dit
+  repTyInsts <- tc_mkRepFamInsts gk get_fixity inst_tys dit
   let (binds, sigs) = mkBindsRep dflags gk dit
   return (binds, sigs, repTyInsts)
 
@@ -390,13 +389,14 @@ mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
 --       type Rep_D a b = ...representation type for D ...
 --------------------------------------------------------------------------------
 
-tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1
-                 -> [Type]        -- The type(s) to which Generic(1) is applied
-                                  -- in the generated instance
-                 -> DerivInstTys  -- Information about the last type argument,
-                                  -- including the data type's TyCon
-                 -> TcM FamInst   -- Generated representation0 coercion
-tc_mkRepFamInsts gk inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) =
+tc_mkRepFamInsts :: GenericKind      -- Gen0 or Gen1
+                 -> (Name -> Fixity) -- Get the Fixity for a data constructor Name
+                 -> [Type]           -- The type(s) to which Generic(1) is applied
+                                     -- in the generated instance
+                 -> DerivInstTys     -- Information about the last type argument,
+                                     -- including the data type's TyCon
+                 -> TcM FamInst      -- Generated representation0 coercion
+tc_mkRepFamInsts gk get_fixity inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) =
        -- Consider the example input tycon `D`, where data D a b = D_ a
        -- Also consider `R:DInt`, where { data family D x y :: * -> *
        --                               ; data instance D Int a b = D_ a }
@@ -426,7 +426,7 @@ tc_mkRepFamInsts gk inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) =
              where all_tyvars = tyConTyVars tycon
 
        -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
-     ; repTy <- tc_mkRepTy gk_ dit arg_ki
+     ; repTy <- tc_mkRepTy gk_ get_fixity dit arg_ki
 
        -- `rep_name` is a name we generate for the synonym
      ; mod <- getModule
@@ -526,6 +526,8 @@ argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
 
 tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
                GenericKind_
+               -- Get the Fixity for a data constructor Name
+            -> (Name -> Fixity)
                -- Information about the last type argument to Generic(1)
             -> DerivInstTys
                -- The kind of the representation type's argument
@@ -533,7 +535,7 @@ tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
             -> Kind
                -- Generated representation0 type
             -> TcM Type
-tc_mkRepTy gk_ dit@(DerivInstTys{dit_rep_tc = tycon}) k =
+tc_mkRepTy gk_ get_fixity dit@(DerivInstTys{dit_rep_tc = tycon}) k =
   do
     d1      <- tcLookupTyCon d1TyConName
     c1      <- tcLookupTyCon c1TyConName
@@ -573,8 +575,6 @@ tc_mkRepTy gk_ dit@(DerivInstTys{dit_rep_tc = tycon}) k =
     pDStr      <- tcLookupPromDataCon decidedStrictDataConName
     pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName
 
-    fix_env <- getFixityEnv
-
     let mkSum' a b = mkTyConApp plus  [k,a,b]
         mkProd a b = mkTyConApp times [k,a,b]
         mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a
@@ -631,7 +631,7 @@ tc_mkRepTy gk_ dit@(DerivInstTys{dit_rep_tc = tycon}) k =
         ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
         ctFix c
             | dataConIsInfix c
-            = case lookupFixity fix_env (dataConName c) of
+            = case get_fixity (dataConName c) of
                    Fixity _ n InfixL -> buildFix n pLA
                    Fixity _ n InfixR -> buildFix n pRA
                    Fixity _ n InfixN -> buildFix n pNA
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
index 1737ae2e50..2036e98300 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ b/compiler/GHC/Tc/Deriv/Utils.hs
@@ -584,8 +584,10 @@ hasStockDeriving clas
            ; return (binds, [], deriv_stuff, field_names) }
 
     generic gen_fn _ inst_tys dit
-      = do { (binds, sigs, faminst) <- gen_fn inst_tys dit
-           ; let field_names = all_field_names (dit_rep_tc dit)
+      = do { let tc = dit_rep_tc dit
+           ; fix_env <- getDataConFixityFun tc
+           ; (binds, sigs, faminst) <- gen_fn fix_env inst_tys dit
+           ; let field_names = all_field_names tc
            ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) }
 
     -- See Note [Deriving and unused record selectors]
@@ -626,7 +628,7 @@ getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
 -- If the TyCon is locally defined, we want the local fixity env;
 -- but if it is imported (which happens for standalone deriving)
 -- we need to get the fixity env from the interface file
--- c.f. GHC.Rename.Env.lookupFixity, and #9830
+-- c.f. GHC.Rename.Env.lookupFixity, #9830, and #20994
 getDataConFixityFun tc
   = do { this_mod <- getModule
        ; if nameIsLocalOrFrom this_mod name
diff --git a/testsuite/tests/deriving/should_compile/T20994.hs b/testsuite/tests/deriving/should_compile/T20994.hs
new file mode 100644
index 0000000000..807f16a9b6
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T20994.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T20994 where
+
+import Data.Kind (Constraint, Type)
+import GHC.Generics
+
+type (++) :: [a] -> [a] -> [a]
+type family xs ++ ys where
+  '[]    ++ ys = ys
+  (x:xs) ++ ys = x:(xs ++ ys)
+
+type GetConFixities :: (Type -> Type) -> [FixityI]
+type family GetConFixities rep where
+  GetConFixities (D1 (MetaData _ _ _ _) f) = GetConFixities f
+  GetConFixities (C1 (MetaCons _ fix _) _) = '[fix]
+  GetConFixities (f :+: g)                 = GetConFixities f ++ GetConFixities g
+  GetConFixities V1                        = '[]
+
+type Dict :: Constraint -> Type
+data Dict c where
+  Dict :: c => Dict c
+
+-- Check that (:) is `infixr 5` according to its Rep instance.
+test :: Dict (GetConFixities (Rep [a]) ~ [PrefixI, InfixI RightAssociative 5])
+test = Dict
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 4a80c84cc1..a33cb364c3 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -136,3 +136,4 @@ test('T20496', multiline_grep_errmsg(r"rnd\n( .*\n)*"), compile, ['-ddump-tc-tra
 test('T20375', normal, compile, [''])
 test('T20387', normal, compile, [''])
 test('T20501', normal, compile, [''])
+test('T20994', normal, compile, [''])