summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc/Deriv
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2021-11-10 17:45:02 -0500
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-11-15 10:17:57 -0500
commitaa3729722bc1aa601c89788c590460ce719bfaed (patch)
tree3d89ac01d33496b09e826f2189236f841406f001 /compiler/GHC/Tc/Deriv
parentc60652929ebd2510e52c05a2f61d52e2bf1846ad (diff)
downloadhaskell-aa3729722bc1aa601c89788c590460ce719bfaed.tar.gz
Refactoring: Consolidate some arguments with DerivInstTys
Various functions in GHC.Tc.Deriv.* were passing around `TyCon`s and `[Type]`s that ultimately come from the same `DerivInstTys`. This patch moves the definition of `DerivInstTys` to `GHC.Tc.Deriv.Generate` so that all of these `TyCon` and `[Type]` arguments can be consolidated into a single `DerivInstTys`. Not only does this make the code easier to read (in my opinion), this will also be important in a subsequent commit where we need to add another field to `DerivInstTys` that will also be used from `GHC.Tc.Deriv.Generate` and friends.
Diffstat (limited to 'compiler/GHC/Tc/Deriv')
-rw-r--r--compiler/GHC/Tc/Deriv/Functor.hs21
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs75
-rw-r--r--compiler/GHC/Tc/Deriv/Generics.hs41
-rw-r--r--compiler/GHC/Tc/Deriv/Utils.hs113
4 files changed, 127 insertions, 123 deletions
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index bc22c6f7c9..204c8ce88d 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -149,10 +149,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 -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Functor_binds :: SrcSpan -> DerivInstTys -> (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 (DerivInstTys{dit_rep_tc = tycon})
| Phantom <- last (tyConRoles tycon)
= (unitBag fmap_bind, emptyBag)
where
@@ -163,7 +163,8 @@ gen_Functor_binds loc tycon _
coerce_Expr]
fmap_match_ctxt = mkPrefixFunRhs fmap_name
-gen_Functor_binds loc tycon tycon_args
+gen_Functor_binds loc (DerivInstTys{ dit_rep_tc = tycon
+ , dit_rep_tc_args = tycon_args })
= (listToBag [fmap_bind, replace_bind], emptyBag)
where
data_cons = getPossibleDataCons tycon tycon_args
@@ -783,10 +784,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 -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (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 (DerivInstTys{dit_rep_tc = tycon})
| Phantom <- last (tyConRoles tycon)
= (unitBag foldMap_bind, emptyBag)
where
@@ -797,7 +798,8 @@ gen_Foldable_binds loc tycon _
mempty_Expr]
foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
-gen_Foldable_binds loc tycon tycon_args
+gen_Foldable_binds loc (DerivInstTys{ dit_rep_tc = tycon
+ , dit_rep_tc_args = tycon_args })
| null data_cons -- There's no real point producing anything but
-- foldMap for a type with no constructors.
= (unitBag foldMap_bind, emptyBag)
@@ -1016,10 +1018,10 @@ removes all such types from consideration.
See Note [Generated code for DeriveFoldable and DeriveTraversable].
-}
-gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (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 (DerivInstTys{dit_rep_tc = tycon})
| Phantom <- last (tyConRoles tycon)
= (unitBag traverse_bind, emptyBag)
where
@@ -1031,7 +1033,8 @@ gen_Traversable_binds loc tycon _
(nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
traverse_match_ctxt = mkPrefixFunRhs traverse_name
-gen_Traversable_binds loc tycon tycon_args
+gen_Traversable_binds loc (DerivInstTys{ dit_rep_tc = tycon
+ , dit_rep_tc_args = tycon_args })
= (unitBag traverse_bind, emptyBag)
where
data_cons = getPossibleDataCons tycon tycon_args
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index b63b7696b1..79843eb77f 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -36,7 +36,8 @@ module GHC.Tc.Deriv.Generate (
ordOpTbl, boxConTbl, litConTbl,
mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,
- getPossibleDataCons, tyConInstArgTys
+ getPossibleDataCons, tyConInstArgTys,
+ DerivInstTys(..)
) where
import GHC.Prelude
@@ -212,8 +213,9 @@ for the instance decl, which it probably wasn't, so the decls
produced don't get through the typechecker.
-}
-gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Eq_binds loc tycon tycon_args = do
+gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Eq_binds loc (DerivInstTys{ dit_rep_tc = tycon
+ , dit_rep_tc_args = tycon_args }) = do
return (method_binds, emptyBag)
where
all_cons = getPossibleDataCons tycon tycon_args
@@ -388,8 +390,9 @@ gtResult OrdGE = true_Expr
gtResult OrdGT = true_Expr
------------
-gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Ord_binds loc tycon tycon_args = do
+gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ord_binds loc (DerivInstTys{ dit_rep_tc = tycon
+ , dit_rep_tc_args = tycon_args }) = do
return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
, emptyBag)
@@ -636,8 +639,8 @@ instance ... Enum (Foo ...) where
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
-}
-gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Enum_binds loc tycon _ = do
+gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
-- See Note [Auxiliary binders]
tag2con_RDR <- new_tag2con_rdr_name loc tycon
maxtag_RDR <- new_maxtag_rdr_name loc tycon
@@ -726,8 +729,8 @@ gen_Enum_binds loc tycon _ = do
************************************************************************
-}
-gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Bounded_binds loc tycon _
+gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = tycon})
| isEnumerationTyCon tycon
= (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
| otherwise
@@ -813,9 +816,9 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
-}
-gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Ix_binds loc tycon _ = do
+gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
-- See Note [Auxiliary binders]
tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -1015,10 +1018,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 -> [Type]
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys
-> (LHsBinds GhcPs, BagDerivStuff)
-gen_Read_binds get_fixity loc tycon _
+gen_Read_binds get_fixity loc (DerivInstTys{dit_rep_tc = tycon})
= (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
where
-----------------------------------------------------------------------
@@ -1199,10 +1202,11 @@ Example
-- the most tightly-binding operator
-}
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys
-> (LHsBinds GhcPs, BagDerivStuff)
-gen_Show_binds get_fixity loc tycon tycon_args
+gen_Show_binds get_fixity loc (DerivInstTys{ dit_rep_tc = tycon
+ , dit_rep_tc_args = tycon_args })
= (unitBag shows_prec, emptyBag)
where
data_cons = getPossibleDataCons tycon tycon_args
@@ -1370,12 +1374,10 @@ we generate
-}
gen_Data_binds :: SrcSpan
- -> TyCon -- For data families, this is the
- -- *representation* TyCon
- -> [Type]
+ -> DerivInstTys
-> TcM (LHsBinds GhcPs, -- The method bindings
BagDerivStuff) -- Auxiliary bindings
-gen_Data_binds loc rep_tc _
+gen_Data_binds loc (DerivInstTys{dit_rep_tc = 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
@@ -1636,8 +1638,10 @@ Example:
-}
-gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag)
+gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
+ , dit_rep_tc_args = tycon_args }) =
+ (listToBag [lift_bind, liftTyped_bind], emptyBag)
where
lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
(map (pats_etc mk_exp) data_cons)
@@ -2669,6 +2673,35 @@ tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_ar
where
tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon
+-- | Information about the arguments to the class in a stock- or
+-- newtype-derived instance.
+-- See @Note [DerivEnv and DerivSpecMechanism]@.
+data DerivInstTys = DerivInstTys
+ { dit_cls_tys :: [Type]
+ -- ^ Other arguments to the class except the last
+ , dit_tc :: TyCon
+ -- ^ Type constructor for which the instance is requested
+ -- (last arguments to the type class)
+ , dit_tc_args :: [Type]
+ -- ^ Arguments to the type constructor
+ , dit_rep_tc :: TyCon
+ -- ^ The representation tycon for 'dit_tc'
+ -- (for data family instances). Otherwise the same as 'dit_tc'.
+ , dit_rep_tc_args :: [Type]
+ -- ^ The representation types for 'dit_tc_args'
+ -- (for data family instances). Otherwise the same as 'dit_tc_args'.
+ }
+
+instance Outputable DerivInstTys where
+ ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args
+ , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })
+ = hang (text "DerivInstTys")
+ 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys
+ , text "dit_tc" <+> ppr tc
+ , text "dit_tc_args" <+> ppr tc_args
+ , text "dit_rep_tc" <+> ppr rep_tc
+ , text "dit_rep_tc_args" <+> ppr rep_tc_args ])
+
{-
Note [Auxiliary binders]
~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index eee7496b6f..db7bf0fc8b 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -78,12 +78,12 @@ For the generic representation we need to generate:
\end{itemize}
-}
-gen_Generic_binds :: GenericKind -> TyCon -> [Type]
- -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)
-gen_Generic_binds gk tc inst_tys = do
+gen_Generic_binds :: GenericKind -> [Type] -> DerivInstTys
+ -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)
+gen_Generic_binds gk inst_tys dit = do
dflags <- getDynFlags
- repTyInsts <- tc_mkRepFamInsts gk tc inst_tys
- let (binds, sigs) = mkBindsRep dflags gk tc
+ repTyInsts <- tc_mkRepFamInsts gk inst_tys dit
+ let (binds, sigs) = mkBindsRep dflags gk dit
return (binds, sigs, repTyInsts)
{-
@@ -148,7 +148,7 @@ following constraints are satisfied.
-}
-canDoGenerics :: TyCon -> Validity' [DeriveGenericsErrReason]
+canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
-- canDoGenerics determines if Generic/Rep can be derived.
--
-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken
@@ -156,7 +156,7 @@ canDoGenerics :: TyCon -> Validity' [DeriveGenericsErrReason]
--
-- It returns IsValid if deriving is possible. It returns (NotValid reason)
-- if not.
-canDoGenerics tc
+canDoGenerics (DerivInstTys{dit_rep_tc = tc})
= mergeErrors (
-- Check (b) from Note [Requirements for deriving Generic and Rep].
(if (not (null (tyConStupidTheta tc)))
@@ -244,9 +244,9 @@ explicitly, even though foldDataConArgs is also doing this internally.
--
-- It returns IsValid if deriving is possible. It returns (NotValid reason)
-- if not.
-canDoGenerics1 :: TyCon -> Validity' [DeriveGenericsErrReason]
-canDoGenerics1 rep_tc =
- canDoGenerics rep_tc `andValid` additionalChecks
+canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
+canDoGenerics1 dit@(DerivInstTys{dit_rep_tc = rep_tc}) =
+ canDoGenerics dit `andValid` additionalChecks
where
additionalChecks
-- check (d) from Note [Requirements for deriving Generic and Rep]
@@ -330,8 +330,8 @@ gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
-- Bindings for the Generic instance
-mkBindsRep :: DynFlags -> GenericKind -> TyCon -> (LHsBinds GhcPs, [LSig GhcPs])
-mkBindsRep dflags gk tycon = (binds, sigs)
+mkBindsRep :: DynFlags -> GenericKind -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs])
+mkBindsRep dflags gk (DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
where
binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn])
`unionBags`
@@ -392,11 +392,12 @@ mkBindsRep dflags gk tycon = (binds, sigs)
--------------------------------------------------------------------------------
tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
- -> TyCon -- The type to generate representation for
-> [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 tycon inst_tys =
+tc_mkRepFamInsts gk 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 }
@@ -437,7 +438,7 @@ tc_mkRepFamInsts gk tycon inst_tys =
where all_tyvars = tyConTyVars tycon
-- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
- ; repTy <- tc_mkRepTy gk_ tycon arg_ki
+ ; repTy <- tc_mkRepTy gk_ dit arg_ki
-- `rep_name` is a name we generate for the synonym
; mod <- getModule
@@ -542,14 +543,14 @@ argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
GenericKind_
- -- The type to generate representation for
- -> TyCon
- -- The kind of the representation type's argument
- -- See Note [Handling kinds in a Rep instance]
+ -- Information about the last type argument to Generic(1)
+ -> DerivInstTys
+ -- The kind of the representation type's argument
+ -- See Note [Handling kinds in a Rep instance]
-> Kind
-- Generated representation0 type
-> TcM Type
-tc_mkRepTy gk_ tycon k =
+tc_mkRepTy gk_ (DerivInstTys{dit_rep_tc = tycon}) k =
do
d1 <- tcLookupTyCon d1TyConName
c1 <- tcLookupTyCon c1TyConName
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
index dfd1b557a7..a65dcca956 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ b/compiler/GHC/Tc/Deriv/Utils.hs
@@ -9,7 +9,7 @@
-- | Error-checking and other utilities for @deriving@ clauses or declarations.
module GHC.Tc.Deriv.Utils (
DerivM, DerivEnv(..),
- DerivSpec(..), pprDerivSpec, DerivInstTys(..),
+ DerivSpec(..), pprDerivSpec,
DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
DerivContext(..), OriginativeDerivStatus(..),
@@ -179,35 +179,6 @@ pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
instance Outputable theta => Outputable (DerivSpec theta) where
ppr = pprDerivSpec
--- | Information about the arguments to the class in a stock- or
--- newtype-derived instance.
--- See @Note [DerivEnv and DerivSpecMechanism]@.
-data DerivInstTys = DerivInstTys
- { dit_cls_tys :: [Type]
- -- ^ Other arguments to the class except the last
- , dit_tc :: TyCon
- -- ^ Type constructor for which the instance is requested
- -- (last arguments to the type class)
- , dit_tc_args :: [Type]
- -- ^ Arguments to the type constructor
- , dit_rep_tc :: TyCon
- -- ^ The representation tycon for 'dit_tc'
- -- (for data family instances). Otherwise the same as 'dit_tc'.
- , dit_rep_tc_args :: [Type]
- -- ^ The representation types for 'dit_tc_args'
- -- (for data family instances). Otherwise the same as 'dit_tc_args'.
- }
-
-instance Outputable DerivInstTys where
- ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args
- , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })
- = hang (text "DITTyConHead")
- 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys
- , text "dit_tc" <+> ppr tc
- , text "dit_tc_args" <+> ppr tc_args
- , text "dit_rep_tc" <+> ppr rep_tc
- , text "dit_rep_tc_args" <+> ppr rep_tc_args ])
-
-- | What action to take in order to derive a class instance.
-- See @Note [DerivEnv and DerivSpecMechanism]@, as well as
-- @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
@@ -219,9 +190,8 @@ data DerivSpecMechanism
-- instance, including what type constructor the last argument is
-- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
, dsm_stock_gen_fn ::
- SrcSpan -> TyCon -- dit_rep_tc
- -> [Type] -- dit_rep_tc_args
- -> [Type] -- inst_tys
+ SrcSpan -> [Type] -- inst_tys
+ -> DerivInstTys -- dsm_stock_dit
-> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
-- ^ This function returns four things:
--
@@ -429,7 +399,7 @@ instance Outputable DerivContext where
-- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
data OriginativeDerivStatus
= CanDeriveStock -- Stock class, can derive
- (SrcSpan -> TyCon -> [Type] -> [Type]
+ (SrcSpan -> [Type] -> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
| StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it
| CanDeriveAnyClass -- See Note [Deriving any class]
@@ -565,18 +535,16 @@ is willing to support it.
hasStockDeriving
:: Class -> Maybe (SrcSpan
- -> TyCon
- -> [Type]
-> [Type]
+ -> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
hasStockDeriving clas
= assocMaybe gen_list (getUnique clas)
where
gen_list
:: [(Unique, SrcSpan
- -> TyCon
- -> [Type]
-> [Type]
+ -> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))]
gen_list = [ (eqClassKey, simpleM gen_Eq_binds)
, (ordClassKey, simpleM gen_Ord_binds)
@@ -593,27 +561,28 @@ hasStockDeriving clas
, (genClassKey, generic (gen_Generic_binds Gen0))
, (gen1ClassKey, generic (gen_Generic_binds Gen1)) ]
- simple gen_fn loc tc tc_args _
- = let (binds, deriv_stuff) = gen_fn loc tc tc_args
+ simple gen_fn loc _ dit
+ = let (binds, deriv_stuff) = gen_fn loc dit
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 tc_args _
- = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args
+ simpleM gen_fn loc _ dit
+ = do { (binds, deriv_stuff) <- gen_fn loc dit
; return (binds, [], deriv_stuff, []) }
- read_or_show gen_fn loc tc tc_args _
- = do { fix_env <- getDataConFixityFun tc
- ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args
+ read_or_show gen_fn loc _ dit
+ = do { let tc = dit_rep_tc dit
+ ; fix_env <- getDataConFixityFun tc
+ ; let (binds, deriv_stuff) = gen_fn fix_env loc dit
field_names = all_field_names tc
; return (binds, [], deriv_stuff, field_names) }
- generic gen_fn _ tc _ inst_tys
- = do { (binds, sigs, faminst) <- gen_fn tc inst_tys
- ; let field_names = all_field_names tc
+ 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)
; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) }
-- See Note [Deriving and unused record selectors]
@@ -680,13 +649,13 @@ getDataConFixityFun tc
-- family tycon (with indexes) in error messages.
checkOriginativeSideConditions
- :: DynFlags -> DerivContext -> Class -> [TcType]
- -> TyCon -> TyCon
+ :: DynFlags -> DerivContext -> Class -> DerivInstTys
-> OriginativeDerivStatus
-checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc
+checkOriginativeSideConditions dflags deriv_ctxt cls
+ dit@(DerivInstTys{dit_cls_tys = cls_tys})
-- First, check if stock deriving is possible...
| Just cond <- stockSideConditions deriv_ctxt cls
- = case (cond dflags tc rep_tc) of
+ = case cond dflags dit of
NotValid err -> StockClassError err -- Class-specific error
IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
-- All stock derivable classes are unary in the sense that
@@ -758,20 +727,16 @@ stockSideConditions deriv_ctxt cls
type Condition
= DynFlags
- -> TyCon -- ^ The data type's 'TyCon'. For data families, this is the
- -- family 'TyCon'.
-
- -> TyCon -- ^ For data families, this is the representation 'TyCon'.
- -- Otherwise, this is the same as the other 'TyCon' argument.
+ -> DerivInstTys -- ^ Information about the type arguments to the class.
-> Validity' DeriveInstanceErrReason
- -- ^ 'IsValid' if deriving an instance for this 'TyCon' is
+ -- ^ 'IsValid' if deriving an instance for this type is
-- possible. Otherwise, it's @'NotValid' err@, where @err@
-- explains what went wrong.
andCond :: Condition -> Condition -> Condition
-andCond c1 c2 dflags tc rep_tc
- = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc
+andCond c1 c2 dflags dit
+ = c1 dflags dit `andValid` c2 dflags dit
-- | Some common validity checks shared among stock derivable classes. One
-- check that absolutely must hold is that if an instance @C (T a)@ is being
@@ -801,7 +766,8 @@ cond_stdOK
-- the -XEmptyDataDeriving extension.
-> Condition
-cond_stdOK deriv_ctxt permissive dflags tc rep_tc
+cond_stdOK deriv_ctxt permissive dflags
+ dit@(DerivInstTys{dit_tc = tc, dit_rep_tc = rep_tc})
= valid_ADT `andValid` valid_misc
where
valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason
@@ -822,7 +788,7 @@ cond_stdOK deriv_ctxt permissive dflags tc rep_tc
InferContext wildcard
| null data_cons -- 1.
, not permissive
- -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`
+ -> checkFlag LangExt.EmptyDataDeriving dflags dit `orValid`
NotValid (no_cons_why rep_tc)
| not (null con_whys)
-> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys
@@ -856,14 +822,14 @@ no_cons_why :: TyCon -> DeriveInstanceErrReason
no_cons_why = DerivErrNoConstructors
cond_RepresentableOk :: Condition
-cond_RepresentableOk _ _ rep_tc =
- case canDoGenerics rep_tc of
+cond_RepresentableOk _ dit =
+ case canDoGenerics dit of
IsValid -> IsValid
NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs
cond_Representable1Ok :: Condition
-cond_Representable1Ok _ _ rep_tc =
- case canDoGenerics1 rep_tc of
+cond_Representable1Ok _ dit =
+ case canDoGenerics1 dit of
IsValid -> IsValid
NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs
@@ -872,8 +838,8 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond`
(cond_isProduct `andCond` cond_args cls)
where
orCond :: Condition -> Condition -> Condition
- orCond c1 c2 dflags tc rep_tc
- = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of
+ orCond c1 c2 dflags dit
+ = case (c1 dflags dit, c2 dflags dit) of
(IsValid, _) -> IsValid -- c1 succeeds
(_, IsValid) -> IsValid -- c21 succeeds
(NotValid x, NotValid y) -> NotValid $ DerivErrEnumOrProduct x y
@@ -885,7 +851,7 @@ cond_args :: Class -> Condition
-- by generating specialised code. For others (eg 'Data') we don't.
-- For even others (eg 'Lift'), unlifted types aren't even a special
-- consideration!
-cond_args cls _ _ rep_tc
+cond_args cls _ (DerivInstTys{dit_rep_tc = rep_tc})
= case bad_args of
[] -> IsValid
(ty:_) -> NotValid $ DerivErrDunnoHowToDeriveForType ty
@@ -908,12 +874,12 @@ cond_args cls _ _ rep_tc
cond_isEnumeration :: Condition
-cond_isEnumeration _ _ rep_tc
+cond_isEnumeration _ (DerivInstTys{dit_rep_tc = rep_tc})
| isEnumerationTyCon rep_tc = IsValid
| otherwise = NotValid $ DerivErrMustBeEnumType rep_tc
cond_isProduct :: Condition
-cond_isProduct _ _ rep_tc
+cond_isProduct _ (DerivInstTys{dit_rep_tc = rep_tc})
| Just _ <- tyConSingleDataCon_maybe rep_tc
= IsValid
| otherwise
@@ -926,7 +892,8 @@ cond_functorOK :: Bool -> Bool -> Condition
-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
-- (d) optionally: don't use function types
-- (e) no "stupid context" on data type
-cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc
+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _
+ (DerivInstTys{dit_rep_tc = rep_tc})
| null tc_tvs
= NotValid $ DerivErrMustHaveSomeParameters rep_tc
@@ -972,7 +939,7 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc
checkFlag :: LangExt.Extension -> Condition
-checkFlag flag dflags _ _
+checkFlag flag dflags _
| xopt flag dflags = IsValid
| otherwise = NotValid why
where