Pass tc_args to gen_fn

3 files changed, 33 insertions, 32 deletions

diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index 3ccfb83cf7..cb00d85be9 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -151,10 +151,10 @@ is a similar algorithm for generating `p <$ x` (for some constant `p`):
   $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y)))
 -}
 
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
 -- When the argument is phantom, we can use  fmap _ = coerce
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Functor_binds loc tycon
+gen_Functor_binds loc tycon _
   | Phantom <- last (tyConRoles tycon)
   = (unitBag fmap_bind, emptyBag)
   where
@@ -165,7 +165,7 @@ gen_Functor_binds loc tycon
                                coerce_Expr]
     fmap_match_ctxt = mkPrefixFunRhs fmap_name
 
-gen_Functor_binds loc tycon
+gen_Functor_binds loc tycon _
   = (listToBag [fmap_bind, replace_bind], emptyBag)
   where
     data_cons = tyConDataCons tycon
@@ -787,10 +787,10 @@ could surprise users if they switch to other types, but Ryan Scott seems to
 think it's okay to do it for now.
 -}
 
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
 -- When the parameter is phantom, we can use foldMap _ _ = mempty
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Foldable_binds loc tycon
+gen_Foldable_binds loc tycon _
   | Phantom <- last (tyConRoles tycon)
   = (unitBag foldMap_bind, emptyBag)
   where
@@ -801,7 +801,7 @@ gen_Foldable_binds loc tycon
                                   mempty_Expr]
     foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
 
-gen_Foldable_binds loc tycon
+gen_Foldable_binds loc tycon _
   | null data_cons  -- There's no real point producing anything but
                     -- foldMap for a type with no constructors.
   = (unitBag foldMap_bind, emptyBag)
@@ -1016,10 +1016,10 @@ removes all such types from consideration.
 See Note [Generated code for DeriveFoldable and DeriveTraversable].
 -}
 
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
 -- When the argument is phantom, we can use traverse = pure . coerce
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Traversable_binds loc tycon
+gen_Traversable_binds loc tycon _
   | Phantom <- last (tyConRoles tycon)
   = (unitBag traverse_bind, emptyBag)
   where
@@ -1031,7 +1031,7 @@ gen_Traversable_binds loc tycon
                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
     traverse_match_ctxt = mkPrefixFunRhs traverse_name
 
-gen_Traversable_binds loc tycon
+gen_Traversable_binds loc tycon _
   = (unitBag traverse_bind, emptyBag)
   where
     data_cons = tyConDataCons tycon
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 650bc16714..993c8fd11d 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -212,8 +212,8 @@ for the instance decl, which it probably wasn't, so the decls
 produced don't get through the typechecker.
 -}
 
-gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Eq_binds loc tycon = do
+gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Eq_binds loc tycon _ = do
     -- See Note [Auxiliary binders]
     con2tag_RDR <- new_con2tag_rdr_name loc tycon
 
@@ -396,8 +396,8 @@ gtResult OrdGE      = true_Expr
 gtResult OrdGT      = true_Expr
 
 ------------
-gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Ord_binds loc tycon = do
+gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ord_binds loc tycon _ = do
     -- See Note [Auxiliary binders]
     con2tag_RDR <- new_con2tag_rdr_name loc tycon
 
@@ -646,8 +646,8 @@ instance ... Enum (Foo ...) where
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 -}
 
-gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Enum_binds loc tycon = do
+gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Enum_binds loc tycon _ = do
     -- See Note [Auxiliary binders]
     con2tag_RDR <- new_con2tag_rdr_name loc tycon
     tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -738,8 +738,8 @@ gen_Enum_binds loc tycon = do
 ************************************************************************
 -}
 
-gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Bounded_binds loc tycon
+gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Bounded_binds loc tycon _
   | isEnumerationTyCon tycon
   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
   | otherwise
@@ -825,9 +825,9 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
 (p.~147).
 -}
 
-gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
 
-gen_Ix_binds loc tycon = do
+gen_Ix_binds loc tycon _ = do
     -- See Note [Auxiliary binders]
     con2tag_RDR <- new_con2tag_rdr_name loc tycon
     tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -1028,10 +1028,10 @@ These instances are also useful for Read (Either Int Emp), where
 we want to be able to parse (Left 3) just fine.
 -}
 
-gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
                -> (LHsBinds GhcPs, BagDerivStuff)
 
-gen_Read_binds get_fixity loc tycon
+gen_Read_binds get_fixity loc tycon _
   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
   where
     -----------------------------------------------------------------------
@@ -1212,10 +1212,10 @@ Example
                     -- the most tightly-binding operator
 -}
 
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
                -> (LHsBinds GhcPs, BagDerivStuff)
 
-gen_Show_binds get_fixity loc tycon
+gen_Show_binds get_fixity loc tycon _
   = (unitBag shows_prec, emptyBag)
   where
     data_cons = tyConDataCons tycon
@@ -1385,9 +1385,10 @@ we generate
 gen_Data_binds :: SrcSpan
                -> TyCon                 -- For data families, this is the
                                         --  *representation* TyCon
+               -> [Type]
                -> TcM (LHsBinds GhcPs,  -- The method bindings
                        BagDerivStuff)   -- Auxiliary bindings
-gen_Data_binds loc rep_tc
+gen_Data_binds loc rep_tc _
   = do { -- See Note [Auxiliary binders]
          dataT_RDR  <- new_dataT_rdr_name loc rep_tc
        ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
@@ -1616,8 +1617,8 @@ Example:
 -}
 
 
-gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
+gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Lift_binds loc tycon _ = (listToBag [lift_bind, liftTyped_bind], emptyBag)
   where
     lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
                                  (map (pats_etc mk_exp) data_cons)
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
index 2b28607ae3..471aedf690 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ b/compiler/GHC/Tc/Deriv/Utils.hs
@@ -590,21 +590,21 @@ hasStockDeriving clas
                , (genClassKey,         generic (gen_Generic_binds Gen0))
                , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]
 
-    simple gen_fn loc tc _ _
-      = let (binds, deriv_stuff) = gen_fn loc tc
+    simple gen_fn loc tc tc_args _
+      = let (binds, deriv_stuff) = gen_fn loc tc tc_args
         in return (binds, deriv_stuff, [])
 
     -- Like `simple`, but monadic. The only monadic thing that these functions
     -- do is allocate new Uniques, which are used for generating the names of
     -- auxiliary bindings.
     -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
-    simpleM gen_fn loc tc _ _
-      = do { (binds, deriv_stuff) <- gen_fn loc tc
+    simpleM gen_fn loc tc tc_args _
+      = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args
            ; return (binds, deriv_stuff, []) }
 
-    read_or_show gen_fn loc tc _ _
+    read_or_show gen_fn loc tc tc_args _
       = do { fix_env <- getDataConFixityFun tc
-           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc
+           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args
                  field_names          = all_field_names tc
            ; return (binds, deriv_stuff, field_names) }