[Git][ghc/ghc][wip/T18321-take-two] Revamp the treatment of auxiliary bindings for derived instances
Ryan Scott
gitlab at gitlab.haskell.org
Sun Jun 21 16:23:22 UTC 2020
Ryan Scott pushed to branch wip/T18321-take-two at Glasgow Haskell Compiler / GHC
Commits:
f479858d by Ryan Scott at 2020-06-21T12:23:04-04:00
Revamp the treatment of auxiliary bindings for derived instances
This started as a simple fix for #18321 that organically grew into a
much more sweeping refactor of how auxiliary bindings for derived
instances are handled. I have rewritten `Note [Auxiliary binders]`
in `GHC.Tc.Deriv.Generate` to explain all of the moving parts, but
the highlights are:
* Previously, the OccName of each auxiliary binding would be given
a suffix containing a hash of its package name, module name, and
parent data type to avoid name clashes. This was needlessly
complicated, so we take the more direct approach of generating
`Exact` `RdrName`s for each auxiliary binding with the same
`OccName`, but using an underlying `System` `Name` with a fresh
`Unique` for each binding. Unlike hashes, allocating new `Unique`s
does not require any cleverness and avoid name clashes all the
same...
* ...speaking of which, in order to convince the renamer that multiple
auxiliary bindings with the same `OccName` (but different
`Unique`s) are kosher, we now use `rnLocalValBindsLHS` instead of
`rnTopBindsLHS` to rename auxiliary bindings. Again, see
`Note [Auxiliary binders]` for the full story.
* I have removed the `DerivHsBind` constructor for
`DerivStuff`—which was only used for `Data.Data`-related
auxiliary bindings—and refactored `gen_Data_binds` to use
`DerivAuxBind` instead. This brings the treatment of
`Data.Data`-related auxiliary bindings in line with every other
form of auxiliary binding.
Fixes #18321.
- - - - -
12 changed files:
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Env.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Types/Name/Occurrence.hs
- testsuite/tests/deriving/should_compile/T14682.stderr
- + testsuite/tests/deriving/should_compile/T18321.hs
- testsuite/tests/deriving/should_compile/all.T
- testsuite/tests/deriving/should_compile/drv-empty-data.stderr
Changes:
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -377,3 +377,19 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
from generating many of these usages (at least in
one-shot mode), but that's even more bogus!
-}
+
+{-
+Note [Internal used_names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Most of the used_names are External Names, but we can have System
+Names too. Two examples:
+
+* Names arising from Language.Haskell.TH.newName.
+ See Note [Binders in Template Haskell] in GHC.ThToHs (and #5362).
+* The names of auxiliary bindings in derived instances.
+ See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
+
+Such Names are always for locally-defined things, for which we don't gather
+usage info, so we can just ignore them in ent_map. Moreover, they are always
+System Names, hence the assert, just as a double check.
+-}
=====================================
compiler/GHC/Iface/Env.hs
=====================================
@@ -54,7 +54,7 @@ See Also: Note [The Name Cache] in GHC.Types.Name.Cache
newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
-- Used for source code and interface files, to make the
-- Name for a thing, given its Module and OccName
--- See Note [The Name Cache]
+-- See Note [The Name Cache] in GHC.Types.Name.Cache
--
-- The cache may already already have a binding for this thing,
-- because we may have seen an occurrence before, but now is the
@@ -79,7 +79,7 @@ allocateGlobalBinder
:: NameCache
-> Module -> OccName -> SrcSpan
-> (NameCache, Name)
--- See Note [The Name Cache]
+-- See Note [The Name Cache] in GHC.Types.Name.Cache
allocateGlobalBinder name_supply mod occ loc
= case lookupOrigNameCache (nsNames name_supply) mod occ of
-- A hit in the cache! We are at the binding site of the name.
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -364,16 +364,6 @@ That is, in Y,
In the result of mkIfaceExports, the names are grouped by defining module,
so we may need to split up a single Avail into multiple ones.
-
-Note [Internal used_names]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Most of the used_names are External Names, but we can have Internal
-Names too: see Note [Binders in Template Haskell] in "GHC.ThToHs", and
-#5362 for an example. Such Names are always
- - Such Names are always for locally-defined things, for which we
- don't gather usage info, so we can just ignore them in ent_map
- - They are always System Names, hence the assert, just as a double check.
-
-}
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -814,15 +814,17 @@ the encloseing instance decl, if any.
Note [Looking up Exact RdrNames]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Exact RdrNames are generated by Template Haskell. See Note [Binders
-in Template Haskell] in Convert.
+Exact RdrNames are generated by:
+
+* Template Haskell (See Note [Binders in Template Haskell] in GHC.ThToHs)
+* Derived instances (See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate)
For data types and classes have Exact system Names in the binding
positions for constructors, TyCons etc. For example
[d| data T = MkT Int |]
-when we splice in and Convert to HsSyn RdrName, we'll get
+when we splice in and convert to HsSyn RdrName, we'll get
data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...
-These System names are generated by Convert.thRdrName
+These System names are generated by GHC.ThToHs.thRdrName
But, constructors and the like need External Names, not System Names!
So we do the following
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -38,11 +38,10 @@ import GHC.Tc.Gen.HsType
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( pprTyVars )
-import GHC.Rename.Names ( extendGlobalRdrEnvRn )
import GHC.Rename.Bind
import GHC.Rename.Env
import GHC.Rename.Module ( addTcgDUs )
-import GHC.Types.Avail
+import GHC.Rename.Utils
import GHC.Core.Unify( tcUnifyTy )
import GHC.Core.Class
@@ -294,11 +293,12 @@ renameDeriv inst_infos bagBinds
; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs)
- ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
- ; let bndrs = collectHsValBinders rn_aux_lhs
- ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
- ; setEnvs envs $
- do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
+ -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename
+ -- auxiliary bindings as if they were defined locally.
+ -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
+ ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyFsEnv aux_val_binds
+ ; bindLocalNames bndrs $
+ do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs
; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
; return (listToBag rn_inst_infos, rn_aux,
dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -46,8 +46,6 @@ import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Core.DataCon
import GHC.Types.Name
-import GHC.Utils.Fingerprint
-import GHC.Utils.Encoding
import GHC.Driver.Session
import GHC.Builtin.Utils
@@ -82,22 +80,77 @@ import Data.List ( find, partition, intersperse )
type BagDerivStuff = Bag DerivStuff
+-- | A declarative description of an auxiliary binding that should be
+-- generated. See @Note [Auxiliary binders]@ for a more detailed description
+-- of how these are used.
data AuxBindSpec
- = DerivCon2Tag TyCon -- The con2Tag for given TyCon
- | DerivTag2Con TyCon -- ...ditto tag2Con
- | DerivMaxTag TyCon -- ...and maxTag
- deriving( Eq )
+ -- DerivCon2Tag, DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord,
+ -- Enum, and Ix instances.
-- All these generate ZERO-BASED tag operations
-- I.e first constructor has tag 0
+ -- | @$con2tag@: Computes the tag for a given constructor
+ = DerivCon2Tag
+ TyCon -- The type constructor of the data type to which the
+ -- constructors belong
+ RdrName -- The to-be-generated $con2tag binding's RdrName
+
+ -- | @$tag2con@: Given a tag, computes the corresponding data constructor
+ | DerivTag2Con
+ TyCon -- The type constructor of the data type to which the
+ -- constructors belong
+ RdrName -- The to-be-generated $tag2con binding's RdrName
+
+ -- | @$maxtag@: The maximum possible tag value among a data type's
+ -- constructors
+ | DerivMaxTag
+ TyCon -- The type constructor of the data type to which the
+ -- constructors belong
+ RdrName -- The to-be-generated $maxtag binding's RdrName
+
+ -- DerivDataDataType and DerivDataConstr are only used in derived Data
+ -- instances
+
+ -- | @$t@: The @DataType@ representation for a @Data@ instance
+ | DerivDataDataType
+ TyCon -- The type constructor of the data type to be represented
+ RdrName -- The to-be-generated $t binding's RdrName
+ [RdrName] -- The RdrNames of the to-be-generated $c bindings for each
+ -- data constructor. These are only used on the RHS of the
+ -- to-be-generated $t binding.
+
+ -- | @$c@: The @Constr@ representation for a @Data@ instance
+ | DerivDataConstr
+ DataCon -- The data constructor to be represented
+ RdrName -- The to-be-generated $c binding's RdrName
+ RdrName -- The RdrName of the to-be-generated $t binding for the parent
+ -- data type. This is only used on the RHS of the
+ -- to-be-generated $c binding.
+
+-- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec'
+-- describes.
+auxBindSpecRdrName :: AuxBindSpec -> RdrName
+auxBindSpecRdrName (DerivCon2Tag _ con2tag_RDR) = con2tag_RDR
+auxBindSpecRdrName (DerivTag2Con _ tag2con_RDR) = tag2con_RDR
+auxBindSpecRdrName (DerivMaxTag _ maxtag_RDR) = maxtag_RDR
+auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR
+auxBindSpecRdrName (DerivDataConstr _ dataC_RDR _) = dataC_RDR
+
data DerivStuff -- Please add this auxiliary stuff
= DerivAuxBind AuxBindSpec
+ -- ^ A new, top-level auxiliary binding. Used for deriving 'Eq', 'Ord',
+ -- 'Enum', 'Ix', and 'Data'. See Note [Auxiliary binders].
-- Generics and DeriveAnyClass
| DerivFamInst FamInst -- New type family instances
-
- -- New top-level auxiliary bindings
- | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB
+ -- ^ A new type family instance. Used for:
+ --
+ -- * @DeriveGeneric@, which generates instances of @Rep(1)@
+ --
+ -- * @DeriveAnyClass@, which can fill in associated type family defaults
+ --
+ -- * @GeneralizedNewtypeDeriving@, which generates instances of associated
+ -- type families for newtypes
{-
@@ -161,8 +214,10 @@ produced don't get through the typechecker.
gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Eq_binds loc tycon = do
- dflags <- getDynFlags
- return (method_binds dflags, aux_binds)
+ -- See Note [Auxiliary binders]
+ con2tag_RDR <- new_con2tag_rdr_name loc tycon
+
+ return (method_binds con2tag_RDR, aux_binds con2tag_RDR)
where
all_cons = tyConDataCons tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
@@ -176,7 +231,7 @@ gen_Eq_binds loc tycon = do
no_tag_match_cons = null tag_match_cons
- fall_through_eqn dflags
+ fall_through_eqn con2tag_RDR
| no_tag_match_cons -- All constructors have arguments
= case pat_match_cons of
[] -> [] -- No constructors; no fall-though case
@@ -188,16 +243,18 @@ gen_Eq_binds loc tycon = do
| otherwise -- One or more tag_match cons; add fall-through of
-- extract tags compare for equality
= [([a_Pat, b_Pat],
- untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
+ untag_Expr con2tag_RDR [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
(genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
- aux_binds | no_tag_match_cons = emptyBag
- | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+ aux_binds con2tag_RDR
+ | no_tag_match_cons = emptyBag
+ | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR
- method_binds dflags = unitBag (eq_bind dflags)
- eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr)
- (map pats_etc pat_match_cons
- ++ fall_through_eqn dflags)
+ method_binds con2tag_RDR = unitBag (eq_bind con2tag_RDR)
+ eq_bind con2tag_RDR
+ = mkFunBindEC 2 loc eq_RDR (const true_Expr)
+ (map pats_etc pat_match_cons
+ ++ fall_through_eqn con2tag_RDR)
------------------------------------------------------------------
pats_etc data_con
@@ -341,21 +398,25 @@ gtResult OrdGT = true_Expr
------------
gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ord_binds loc tycon = do
- dflags <- getDynFlags
+ -- See Note [Auxiliary binders]
+ con2tag_RDR <- new_con2tag_rdr_name loc tycon
+
return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
, emptyBag)
- else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
- , aux_binds)
+ else ( unitBag (mkOrdOp con2tag_RDR OrdCompare)
+ `unionBags` other_ops con2tag_RDR
+ , aux_binds con2tag_RDR)
where
- aux_binds | single_con_type = emptyBag
- | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+ aux_binds con2tag_RDR
+ | single_con_type = emptyBag
+ | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR
-- Note [Game plan for deriving Ord]
- other_ops dflags
+ other_ops con2tag_RDR
| (last_tag - first_tag) <= 2 -- 1-3 constructors
|| null non_nullary_cons -- Or it's an enumeration
- = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE]
+ = listToBag [mkOrdOp con2tag_RDR OrdLT, lE, gT, gE]
| otherwise
= emptyBag
@@ -381,39 +442,40 @@ gen_Ord_binds loc tycon = do
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
- mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs
+ mkOrdOp :: RdrName -> OrdOp -> LHsBind GhcPs
-- Returns a binding op a b = ... compares a and b according to op ....
- mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]
- (mkOrdOpRhs dflags op)
+ mkOrdOp con2tag_RDR op
+ = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]
+ (mkOrdOpRhs con2tag_RDR op)
- mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs
- mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op
+ mkOrdOpRhs :: RdrName -> OrdOp -> LHsExpr GhcPs
+ mkOrdOpRhs con2tag_RDR op -- RHS for comparing 'a' and 'b' according to op
| nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases
= nlHsCase (nlHsVar a_RDR) $
- map (mkOrdOpAlt dflags op) tycon_data_cons
+ map (mkOrdOpAlt con2tag_RDR op) tycon_data_cons
-- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
-- C2 x -> case b of C2 x -> ....comopare x.... }
| null non_nullary_cons -- All nullary, so go straight to comparing tags
- = mkTagCmp dflags op
+ = mkTagCmp con2tag_RDR op
| otherwise -- Mixed nullary and non-nullary
= nlHsCase (nlHsVar a_RDR) $
- (map (mkOrdOpAlt dflags op) non_nullary_cons
- ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)])
+ (map (mkOrdOpAlt con2tag_RDR op) non_nullary_cons
+ ++ [mkHsCaseAlt nlWildPat (mkTagCmp con2tag_RDR op)])
- mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon
- -> LMatch GhcPs (LHsExpr GhcPs)
+ mkOrdOpAlt :: RdrName -> OrdOp -> DataCon
+ -> LMatch GhcPs (LHsExpr GhcPs)
-- Make the alternative (Ki a1 a2 .. av ->
- mkOrdOpAlt dflags op data_con
+ mkOrdOpAlt con2tag_RDR op data_con
= mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
- (mkInnerRhs dflags op data_con)
+ (mkInnerRhs con2tag_RDR op data_con)
where
as_needed = take (dataConSourceArity data_con) as_RDRs
data_con_RDR = getRdrName data_con
- mkInnerRhs dflags op data_con
+ mkInnerRhs con2tag_RDR op data_con
| single_con_type
= nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
@@ -436,14 +498,14 @@ gen_Ord_binds loc tycon = do
, mkHsCaseAlt nlWildPat (gtResult op) ]
| tag > last_tag `div` 2 -- lower range is larger
- = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
+ = untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $
nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
(gtResult op) $ -- Definitely GT
nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
, mkHsCaseAlt nlWildPat (ltResult op) ]
| otherwise -- upper range is larger
- = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
+ = untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $
nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
(ltResult op) $ -- Definitely LT
nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
@@ -462,11 +524,11 @@ gen_Ord_binds loc tycon = do
data_con_RDR = getRdrName data_con
bs_needed = take (dataConSourceArity data_con) bs_RDRs
- mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs
+ mkTagCmp :: RdrName -> OrdOp -> LHsExpr GhcPs
-- Both constructors known to be nullary
-- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
- mkTagCmp dflags op =
- untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
+ mkTagCmp con2tag_RDR op =
+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
unliftedOrdOp intPrimTy op ah_RDR bh_RDR
mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
@@ -586,78 +648,86 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Enum_binds loc tycon = do
- dflags <- getDynFlags
- return (method_binds dflags, aux_binds)
+ -- See Note [Auxiliary binders]
+ con2tag_RDR <- new_con2tag_rdr_name loc tycon
+ tag2con_RDR <- new_tag2con_rdr_name loc tycon
+ maxtag_RDR <- new_maxtag_rdr_name loc tycon
+
+ return ( method_binds con2tag_RDR tag2con_RDR maxtag_RDR
+ , aux_binds con2tag_RDR tag2con_RDR maxtag_RDR )
where
- method_binds dflags = listToBag
- [ succ_enum dflags
- , pred_enum dflags
- , to_enum dflags
- , enum_from dflags -- [0 ..]
- , enum_from_then dflags -- [0, 1 ..]
- , from_enum dflags
+ method_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag
+ [ succ_enum con2tag_RDR tag2con_RDR maxtag_RDR
+ , pred_enum con2tag_RDR tag2con_RDR
+ , to_enum tag2con_RDR maxtag_RDR
+ , enum_from con2tag_RDR tag2con_RDR maxtag_RDR -- [0 ..]
+ , enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR -- [0, 1 ..]
+ , from_enum con2tag_RDR
+ ]
+ aux_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind
+ [ DerivCon2Tag tycon con2tag_RDR
+ , DerivTag2Con tycon tag2con_RDR
+ , DerivMaxTag tycon maxtag_RDR
]
- aux_binds = listToBag $ map DerivAuxBind
- [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
occ_nm = getOccString tycon
- succ_enum dflags
+ succ_enum con2tag_RDR tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $
- untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
- nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),
+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
+ nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR,
nlHsVarApps intDataCon_RDR [ah_RDR]])
(illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
- (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
+ (nlHsApp (nlHsVar tag2con_RDR)
(nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
nlHsIntLit 1]))
- pred_enum dflags
+ pred_enum con2tag_RDR tag2con_RDR
= mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $
- untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
nlHsVarApps intDataCon_RDR [ah_RDR]])
(illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
- (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
+ (nlHsApp (nlHsVar tag2con_RDR)
(nlHsApps plus_RDR
[ nlHsVarApps intDataCon_RDR [ah_RDR]
, nlHsLit (HsInt noExtField
(mkIntegralLit (-1 :: Int)))]))
- to_enum dflags
+ to_enum tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $
nlHsIf (nlHsApps and_RDR
[nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
nlHsApps le_RDR [ nlHsVar a_RDR
- , nlHsVar (maxtag_RDR dflags tycon)]])
- (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])
- (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
+ , nlHsVar maxtag_RDR]])
+ (nlHsVarApps tag2con_RDR [a_RDR])
+ (illegal_toEnum_tag occ_nm maxtag_RDR)
- enum_from dflags
+ enum_from con2tag_RDR tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $
- untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
nlHsApps map_RDR
- [nlHsVar (tag2con_RDR dflags tycon),
+ [nlHsVar tag2con_RDR,
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
- (nlHsVar (maxtag_RDR dflags tycon)))]
+ (nlHsVar maxtag_RDR))]
- enum_from_then dflags
+ enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
- untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
- nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
+ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
nlHsPar (enum_from_then_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVarApps intDataCon_RDR [bh_RDR])
(nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
nlHsVarApps intDataCon_RDR [bh_RDR]])
(nlHsIntLit 0)
- (nlHsVar (maxtag_RDR dflags tycon))
+ (nlHsVar maxtag_RDR)
))
- from_enum dflags
+ from_enum con2tag_RDR
= mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $
- untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR])
{-
@@ -758,35 +828,40 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ix_binds loc tycon = do
- dflags <- getDynFlags
+ -- See Note [Auxiliary binders]
+ con2tag_RDR <- new_con2tag_rdr_name loc tycon
+ tag2con_RDR <- new_tag2con_rdr_name loc tycon
+
return $ if isEnumerationTyCon tycon
- then (enum_ixes dflags, listToBag $ map DerivAuxBind
- [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
- else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
+ then (enum_ixes con2tag_RDR tag2con_RDR, listToBag $ map DerivAuxBind
+ [ DerivCon2Tag tycon con2tag_RDR
+ , DerivTag2Con tycon tag2con_RDR
+ ])
+ else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon con2tag_RDR)))
where
--------------------------------------------------------------
- enum_ixes dflags = listToBag
- [ enum_range dflags
- , enum_index dflags
- , enum_inRange dflags
+ enum_ixes con2tag_RDR tag2con_RDR = listToBag
+ [ enum_range con2tag_RDR tag2con_RDR
+ , enum_index con2tag_RDR
+ , enum_inRange con2tag_RDR
]
- enum_range dflags
+ enum_range con2tag_RDR tag2con_RDR
= mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
- untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
- untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
- nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
+ untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $
+ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVarApps intDataCon_RDR [bh_RDR]))
- enum_index dflags
+ enum_index con2tag_RDR
= mkSimpleGeneratedFunBind loc unsafeIndex_RDR
[noLoc (AsPat noExtField (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] (
- untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
- untag_Expr dflags tycon [(d_RDR, dh_RDR)] (
+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] (
+ untag_Expr con2tag_RDR [(d_RDR, dh_RDR)] (
let
rhs = nlHsVarApps intDataCon_RDR [c_RDR]
in
@@ -797,11 +872,11 @@ gen_Ix_binds loc tycon = do
)
-- This produces something like `(ch >= ah) && (ch <= bh)`
- enum_inRange dflags
+ enum_inRange con2tag_RDR
= mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
- untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
- untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
- untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
+ untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] (
+ untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] (
+ untag_Expr con2tag_RDR [(c_RDR, ch_RDR)] (
-- This used to use `if`, which interacts badly with RebindableSyntax.
-- See #11396.
nlHsApps and_RDR
@@ -1313,66 +1388,24 @@ gen_Data_binds :: SrcSpan
-> TcM (LHsBinds GhcPs, -- The method bindings
BagDerivStuff) -- Auxiliary bindings
gen_Data_binds loc rep_tc
- = do { dflags <- getDynFlags
-
- -- Make unique names for the data type and constructor
- -- auxiliary bindings. Start with the name of the TyCon/DataCon
- -- but that might not be unique: see #12245.
- ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
- ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
- (tyConDataCons rep_tc)
- ; let dt_rdr = mkRdrUnqual dt_occ
- dc_rdrs = map mkRdrUnqual dc_occs
-
- -- OK, now do the work
- ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
-
-gen_data :: DynFlags -> RdrName -> [RdrName]
- -> SrcSpan -> TyCon
- -> (LHsBinds GhcPs, -- The method bindings
- BagDerivStuff) -- Auxiliary bindings
-gen_data dflags data_type_name constr_names loc rep_tc
- = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
- `unionBags` gcast_binds,
- -- Auxiliary definitions: the data type and constructors
- listToBag ( genDataTyCon
- : zipWith genDataDataCon data_cons constr_names ) )
+ = do { -- See Note [Auxiliary binders]
+ dataT_RDR <- new_dataT_rdr_name loc rep_tc
+ ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
+
+ ; pure ( listToBag [ gfoldl_bind, gunfold_bind
+ , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]
+ `unionBags` gcast_binds
+ -- Auxiliary definitions: the data type and constructors
+ , listToBag $ map DerivAuxBind
+ ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs
+ : zipWith (\data_con dataC_RDR ->
+ DerivDataConstr data_con dataC_RDR dataT_RDR)
+ data_cons dataC_RDRs )
+ ) }
where
data_cons = tyConDataCons rep_tc
n_cons = length data_cons
one_constr = n_cons == 1
- genDataTyCon :: DerivStuff
- genDataTyCon -- $dT
- = DerivHsBind (mkHsVarBind loc data_type_name rhs,
- L loc (TypeSig noExtField [L loc data_type_name] sig_ty))
-
- sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
- ctx = initDefaultSDocContext dflags
- rhs = nlHsVar mkDataType_RDR
- `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr rep_tc)))
- `nlHsApp` nlList (map nlHsVar constr_names)
-
- genDataDataCon :: DataCon -> RdrName -> DerivStuff
- genDataDataCon dc constr_name -- $cT1 etc
- = DerivHsBind (mkHsVarBind loc constr_name rhs,
- L loc (TypeSig noExtField [L loc constr_name] sig_ty))
- where
- sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
- rhs = nlHsApps mkConstr_RDR constr_args
-
- constr_args
- = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
- nlHsVar (data_type_name) -- DataType
- , nlHsLit (mkHsString (occNameString dc_occ)) -- String name
- , nlList labels -- Field labels
- , nlHsVar fixity ] -- Fixity
-
- labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
- (dataConFieldLabels dc)
- dc_occ = getOccName dc
- is_infix = isDataSymOcc dc_occ
- fixity | is_infix = infix_RDR
- | otherwise = prefix_RDR
------------ gfoldl
gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
@@ -1420,16 +1453,18 @@ gen_data dflags data_type_name constr_names loc rep_tc
tag = dataConTag dc
------------ toConstr
- toCon_bind = mkFunBindEC 1 loc toConstr_RDR id
- (zipWith to_con_eqn data_cons constr_names)
+ toCon_bind dataC_RDRs
+ = mkFunBindEC 1 loc toConstr_RDR id
+ (zipWith to_con_eqn data_cons dataC_RDRs)
to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
------------ dataTypeOf
- dataTypeOf_bind = mkSimpleGeneratedFunBind
- loc
- dataTypeOf_RDR
- [nlWildPat]
- (nlHsVar data_type_name)
+ dataTypeOf_bind dataT_RDR
+ = mkSimpleGeneratedFunBind
+ loc
+ dataTypeOf_RDR
+ [nlWildPat]
+ (nlHsVar dataT_RDR)
------------ gcast1/2
-- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
@@ -1944,7 +1979,7 @@ mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
{-
************************************************************************
* *
-\subsection{Generating extra binds (@con2tag@ and @tag2con@)}
+\subsection{Generating extra binds (@con2tag@, @tag2con@, etc.)}
* *
************************************************************************
@@ -1960,80 +1995,142 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
fiddling around.
-}
-genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
- -> (LHsBind GhcPs, LSig GhcPs)
-genAuxBindSpec dflags loc (DerivCon2Tag tycon)
- = (mkFunBindSE 0 loc rdr_name eqns,
- L loc (TypeSig noExtField [L loc rdr_name] sig_ty))
+-- | Generate the full code for an auxiliary binding.
+-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
+genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec
+ -> (LHsBind GhcPs, LSig GhcPs)
+genAuxBindSpecOriginal dflags loc spec
+ = (gen_bind spec,
+ L loc (TypeSig noExtField [L loc (auxBindSpecRdrName spec)]
+ (genAuxBindSpecSig loc spec)))
where
- rdr_name = con2tag_RDR dflags tycon
+ gen_bind :: AuxBindSpec -> LHsBind GhcPs
+ gen_bind (DerivCon2Tag tycon con2tag_RDR)
+ = mkFunBindSE 0 loc con2tag_RDR eqns
+ where
+ lots_of_constructors = tyConFamilySize tycon > 8
+ -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
+ -- but we don't do vectored returns any more.
- sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
- mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
- mkParentType tycon `mkVisFunTyMany` intPrimTy
+ eqns | lots_of_constructors = [get_tag_eqn]
+ | otherwise = map mk_eqn (tyConDataCons tycon)
- lots_of_constructors = tyConFamilySize tycon > 8
- -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
- -- but we don't do vectored returns any more.
+ get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
- eqns | lots_of_constructors = [get_tag_eqn]
- | otherwise = map mk_eqn (tyConDataCons tycon)
+ mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
+ mk_eqn con = ([nlWildConPat con],
+ nlHsLit (HsIntPrim NoSourceText
+ (toInteger ((dataConTag con) - fIRST_TAG))))
- get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
+ gen_bind (DerivTag2Con _ tag2con_RDR)
+ = mkFunBindSE 0 loc tag2con_RDR
+ [([nlConVarPat intDataCon_RDR [a_RDR]],
+ nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)]
- mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
- mk_eqn con = ([nlWildConPat con],
- nlHsLit (HsIntPrim NoSourceText
- (toInteger ((dataConTag con) - fIRST_TAG))))
+ gen_bind (DerivMaxTag tycon maxtag_RDR)
+ = mkHsVarBind loc maxtag_RDR rhs
+ where
+ rhs = nlHsApp (nlHsVar intDataCon_RDR)
+ (nlHsLit (HsIntPrim NoSourceText max_tag))
+ max_tag = case (tyConDataCons tycon) of
+ data_cons -> toInteger ((length data_cons) - fIRST_TAG)
-genAuxBindSpec dflags loc (DerivTag2Con tycon)
- = (mkFunBindSE 0 loc rdr_name
- [([nlConVarPat intDataCon_RDR [a_RDR]],
- nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
- L loc (TypeSig noExtField [L loc rdr_name] sig_ty))
- where
- sig_ty = mkLHsSigWcType $ L loc $
- XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
- intTy `mkVisFunTyMany` mkParentType tycon
+ gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs)
+ = mkHsVarBind loc dataT_RDR rhs
+ where
+ ctx = initDefaultSDocContext dflags
+ rhs = nlHsVar mkDataType_RDR
+ `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr tycon)))
+ `nlHsApp` nlList (map nlHsVar dataC_RDRs)
+
+ gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)
+ = mkHsVarBind loc dataC_RDR rhs
+ where
+ rhs = nlHsApps mkConstr_RDR constr_args
- rdr_name = tag2con_RDR dflags tycon
+ constr_args
+ = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
+ nlHsVar dataT_RDR -- DataType
+ , nlHsLit (mkHsString (occNameString dc_occ)) -- String name
+ , nlList labels -- Field labels
+ , nlHsVar fixity ] -- Fixity
+
+ labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
+ (dataConFieldLabels dc)
+ dc_occ = getOccName dc
+ is_infix = isDataSymOcc dc_occ
+ fixity | is_infix = infix_RDR
+ | otherwise = prefix_RDR
-genAuxBindSpec dflags loc (DerivMaxTag tycon)
- = (mkHsVarBind loc rdr_name rhs,
- L loc (TypeSig noExtField [L loc rdr_name] sig_ty))
+-- | Generate the code for an auxiliary binding that is a duplicate of another
+-- auxiliary binding.
+-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
+genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec
+ -> (LHsBind GhcPs, LSig GhcPs)
+genAuxBindSpecDup loc original_rdr_name dup_spec
+ = (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name),
+ L loc (TypeSig noExtField [L loc dup_rdr_name]
+ (genAuxBindSpecSig loc dup_spec)))
where
- rdr_name = maxtag_RDR dflags tycon
- sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
- rhs = nlHsApp (nlHsVar intDataCon_RDR)
- (nlHsLit (HsIntPrim NoSourceText max_tag))
- max_tag = case (tyConDataCons tycon) of
- data_cons -> toInteger ((length data_cons) - fIRST_TAG)
+ dup_rdr_name = auxBindSpecRdrName dup_spec
+
+-- | Generate the type signature of an auxiliary binding.
+-- See @Note [Auxiliary binders]@.
+genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
+genAuxBindSpecSig loc spec = case spec of
+ DerivCon2Tag tycon _
+ -> mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
+ mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
+ mkParentType tycon `mkVisFunTyMany` intPrimTy
+ DerivTag2Con tycon _
+ -> mkLHsSigWcType $ L loc $
+ XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
+ intTy `mkVisFunTyMany` mkParentType tycon
+ DerivMaxTag _ _
+ -> mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
+ DerivDataDataType _ _ _
+ -> mkLHsSigWcType (nlHsTyVar dataType_RDR)
+ DerivDataConstr _ _ _
+ -> mkLHsSigWcType (nlHsTyVar constr_RDR)
type SeparateBagsDerivStuff =
- -- AuxBinds and SYB bindings
+ -- DerivAuxBinds
( Bag (LHsBind GhcPs, LSig GhcPs)
- -- Extra family instances (used by Generic and DeriveAnyClass)
- , Bag (FamInst) )
+ -- Extra family instances (used by DeriveGeneric, DeriveAnyClass, and
+ -- GeneralizedNewtypeDeriving)
+ , Bag FamInst )
+
+-- | Take a 'BagDerivStuff' and partition it into 'SeparateBagsDerivStuff'.
+-- Also generate the code for auxiliary bindings based on the declarative
+-- descriptions in the supplied 'AuxBindSpec's. See @Note [Auxiliary binders]@.
genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
-genAuxBinds dflags loc b = genAuxBinds' b2 where
+genAuxBinds dflags loc b = (gen_aux_bind_specs b1, b2) where
(b1,b2) = partitionBagWith splitDerivAuxBind b
splitDerivAuxBind (DerivAuxBind x) = Left x
- splitDerivAuxBind x = Right x
-
- rm_dups = foldr dup_check emptyBag
- dup_check a b = if anyBag (== a) b then b else consBag a b
-
- genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
- genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
- , emptyBag )
- f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
- f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
- f (DerivHsBind b) = add1 b
- f (DerivFamInst t) = add2 t
-
- add1 x (a,b) = (x `consBag` a,b)
- add2 x (a,b) = (a,x `consBag` b)
+ splitDerivAuxBind (DerivFamInst t) = Right t
+
+ gen_aux_bind_specs = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
+
+ -- Perform a CSE-like pass over the generated auxiliary bindings to avoid
+ -- code duplication, as described in
+ -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication).
+ -- The OccEnv remembers the first occurrence of each sort of auxiliary
+ -- binding and maps it to the unique RdrName for that binding.
+ gen_aux_bind_spec :: AuxBindSpec
+ -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
+ -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
+ gen_aux_bind_spec spec (original_rdr_name_env, spec_bag) =
+ case lookupOccEnv original_rdr_name_env spec_occ of
+ Nothing
+ -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name
+ , genAuxBindSpecOriginal dflags loc spec `consBag` spec_bag )
+ Just original_rdr_name
+ -> ( original_rdr_name_env
+ , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag )
+ where
+ spec_rdr_name = auxBindSpecRdrName spec
+ spec_occ = rdrNameOcc spec_rdr_name
mkParentType :: TyCon -> Type
-- Turn the representation tycon of a family into
@@ -2268,13 +2365,12 @@ eq_Expr ty a b
where
(_, _, prim_eq, _, _) = primOrdOps "Eq" ty
-untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)]
- -> LHsExpr GhcPs -> LHsExpr GhcPs
-untag_Expr _ _ [] expr = expr
-untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr
- = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon)
- [untag_this])) {-of-}
- [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)]
+untag_Expr :: RdrName -> [(RdrName, RdrName)]
+ -> LHsExpr GhcPs -> LHsExpr GhcPs
+untag_Expr _ [] expr = expr
+untag_Expr con2tag_RDR ((untag_this, put_tag_here) : more) expr
+ = nlHsCase (nlHsPar (nlHsVarApps con2tag_RDR [untag_this])) {-of-}
+ [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr con2tag_RDR more expr)]
enum_from_to_Expr
:: LHsExpr GhcPs -> LHsExpr GhcPs
@@ -2386,54 +2482,244 @@ minusInt_RDR, tagToEnum_RDR :: RdrName
minusInt_RDR = getRdrName (primOpId IntSubOp )
tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
-con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
--- Generates Orig s RdrName, for the binding positions
-con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc
-tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc
-maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc
-
-mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
-mk_tc_deriv_name dflags tycon occ_fun =
- mkAuxBinderName dflags (tyConName tycon) occ_fun
-
-mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName
--- ^ Make a top-level binder name for an auxiliary binding for a parent name
--- See Note [Auxiliary binders]
-mkAuxBinderName dflags parent occ_fun
- = mkRdrUnqual (occ_fun stable_parent_occ)
- where
- stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
- stable_string
- | hasPprDebug dflags = parent_stable
- | otherwise = parent_stable_hash
- parent_stable = nameStableString parent
- parent_stable_hash =
- let Fingerprint high low = fingerprintString parent_stable
- in toBase62 high ++ toBase62Padded low
- -- See Note [Base 62 encoding 128-bit integers] in GHC.Utils.Encoding
- parent_occ = nameOccName parent
+new_con2tag_rdr_name, new_tag2con_rdr_name, new_maxtag_rdr_name
+ :: SrcSpan -> TyCon -> TcM RdrName
+-- Generates Exact RdrNames, for the binding positions
+new_con2tag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkCon2TagOcc
+new_tag2con_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkTag2ConOcc
+new_maxtag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkMaxTagOcc
+
+new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
+new_dataT_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkDataTOcc
+
+new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName
+new_dataC_rdr_name dflags dc = new_dc_deriv_rdr_name dflags dc mkDataCOcc
+
+new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
+new_tc_deriv_rdr_name loc tycon occ_fun
+ = newAuxBinderRdrName loc (tyConName tycon) occ_fun
+
+new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
+new_dc_deriv_rdr_name loc dc occ_fun
+ = newAuxBinderRdrName loc (dataConName dc) occ_fun
+
+-- | Generate the name for an auxiliary binding, giving it a fresh 'Unique'.
+-- Returns an 'Exact' 'RdrName' with an underlying 'System' 'Name'.
+-- See @Note [Auxiliary binders]@.
+newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
+newAuxBinderRdrName loc parent occ_fun = do
+ uniq <- newUnique
+ pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc
{-
Note [Auxiliary binders]
~~~~~~~~~~~~~~~~~~~~~~~~
-We often want to make a top-level auxiliary binding. E.g. for comparison we have
+We often want to make top-level auxiliary bindings in derived instances.
+For example, derived Eq instances sometimes generate code like this:
+
+ data T = ...
+ deriving instance Eq T
+
+ ==>
+
+ instance Eq T where
+ a == b = $con2tag_T a == $con2tag_T b
+
+ $con2tag_T :: T -> Int
+ $con2tag_T = ...code....
+
+Note that multiple instances of the same type might need to use the same sort
+of auxiliary binding. For example, $con2tag is used not only in derived Eq
+instances, but also in derived Ord instances:
+
+ deriving instance Ord T
+
+ ==>
instance Ord T where
- compare a b = $con2tag a `compare` $con2tag b
+ compare a b = $con2tag_T a `compare` $con2tag_T b
+
+ $con2tag_T :: T -> Int
+ $con2tag_T = ...code....
+
+How do we ensure that the two usages of $con2tag_T do not conflict with each
+other? Two possibilities are:
+
+1. Generate a single $con2tag_T definition and use it in both the Eq and Ord
+ instances:
- $con2tag :: T -> Int
- $con2tag = ...code....
+ instance Eq T where
+ a == b = $con2tag_T a == $con2tag_T b
-Of course these top-level bindings should all have distinct name, and we are
-generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
-because with standalone deriving two imported TyCons might both be called T!
-(See #7947.)
+ instance Ord T where
+ compare a b = $con2tag_T a `compare` $con2tag_T b
-So we use package name, module name and the name of the parent
-(T in this example) as part of the OccName we generate for the new binding.
-To make the symbol names short we take a base62 hash of the full name.
+ $con2tag_T :: T -> Int
+ $con2tag_T = ...code....
-In the past we used the *unique* from the parent, but that's not stable across
-recompilations as uniques are nondeterministic.
+2. Generate a separate $con2tag_T definition for each instance, giving each a
+ separate Unique to avoid name clashes:
+
+ instance Eq T where
+ a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b
+
+ instance Ord T where
+ compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b
+
+ $con2tag_T{Uniq1} :: T -> Int
+ $con2tag_T{Uniq1} = ...code....
+
+ $con2tag_T{Uniq2} :: T -> Int
+ $con2tag_T{Uniq2} = ...code....
+
+Previous versions of GHC implemented (1), as it leads to less code duplication.
+In order to implement (1) properly, however, one must devise a globally unique
+OccName for each sort of auxiliary binding to prevent them from clashing with
+the auxiliary bindings in other derived instances. Even after various bugfixes
+(see #7947, #12245, and #18321), GHC still never quite implemented it right.
+Due in part to this complexity, GHC now implements (2) instead, which does not
+require worrying about unique OccNames at all. (We will revisit the topic of
+reducing code duplication with (2) later in the
+"Wrinkle: Reducing code duplication" section.)
+
+At first glance, it might appear that (2) is infeasible, as it would require
+generating multiple top-level declarations with the same OccName. But what if
+auxiliary bindings /weren't/ top-level? Conceptually, we could imagine that
+auxiliary bindings are /local/ to the instance declarations in which they are
+used. Using some hypothetical Haskell syntax, it might look like this:
+
+ let {
+ $con2tag_T{Uniq1} :: T -> Int
+ $con2tag_T{Uniq1} = ...code....
+
+ $con2tag_T{Uniq2} :: T -> Int
+ $con2tag_T{Uniq2} = ...code....
+ } in {
+ instance Eq T where
+ a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b
+
+ instance Ord T where
+ compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b
+ }
+
+Making auxiliary bindings local is key to making this work, since GHC will
+not reject local bindings with duplicate names provided that:
+
+* Each binding has a distinct unique, and
+* Each binding has an Exact RdrName with a System Name.
+
+In fact, this is the same trick that Template Haskell uses to avoid errors for
+locally bound names created by Language.Haskell.TH.newName.
+See Note [Binders in Template Haskell] in GHC.ThToHs.
+
+Even though the hypothetical Haskell syntax above does not exist, we can
+accomplish the same end result through some sleight of hand in renameDeriv:
+we rename auxiliary bindings with rnLocalValBindsLHS. (If we had used
+rnTopBindsLHS instead, then GHC would spuriously reject auxiliary bindings
+with the same OccName as duplicates.) Luckily, no special treatment is needed
+to typecheck them; we can typecheck them as normal top-level bindings
+(using tcTopBinds) without danger.
+
+-----
+-- Wrinkle: Reducing code duplication
+-----
+
+While the approach of generating copies of each sort of auxiliary binder per
+derived instance is simpler, it can lead to code bloat if done naïvely.
+Consider this example:
+
+ data T = ...
+ deriving instance Eq T
+ deriving instance Ord T
+
+ ==>
+
+ instance Eq T where
+ a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b
+
+ instance Ord T where
+ compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b
+
+ $con2tag_T{Uniq1} :: T -> Int
+ $con2tag_T{Uniq1} = ...code....
+
+ $con2tag_T{Uniq2} :: T -> Int
+ $con2tag_T{Uniq2} = ...code....
+
+$con2tag_T{Uniq1} and $con2tag_T{Uniq2} are blatant duplicates of each other,
+which is not ideal. Surely GHC can do better than that at the very least! And
+indeed it does. Within the genAuxBinds function, GHC performs a small CSE-like
+pass to define duplicate auxiliary binders in terms of the original one. On
+the example above, that would look like this:
+
+ $con2tag_T{Uniq1} :: T -> Int
+ $con2tag_T{Uniq1} = ...code....
+
+ $con2tag_T{Uniq2} :: T -> Int
+ $con2tag_T{Uniq2} = $con2tag_T{Uniq1}
+
+Before explaining how this works, it is worth noting that deduplicating
+auxiliary binders is difficult in the general case. Here are two particular
+examples where GHC cannot easily remove duplicate copies of an auxiliary
+binding:
+
+1. When derived instances are contained in different modules, as in the
+ following example:
+
+ module A where
+ data T = ...
+ module B where
+ import A
+ deriving instance Eq T
+ module C where
+ import B
+ deriving instance Enum T
+
+ The derived Eq and Enum instances for T make use of $con2tag_T, and since
+ they are defined in separate modules, each module must produce its own copy
+ of $con2tag_T.
+
+2. When derived instances are separated by TH splices (#18321), as in the
+ following example:
+
+ module M where
+
+ data T = ...
+ deriving instance Eq T
+ $(pure [])
+ deriving instance Enum T
+
+ Due to the way that GHC typechecks TyClGroups, genAuxBinds will run twice
+ in this program: once for all the declarations before the TH splice, and
+ once again for all the declarations after the TH splice. As a result,
+ $con2tag_T will be generated twice, since genAuxBinds will be unable to
+ recognize the presence of duplicates.
+
+These situations are much rarer, so we do not spend any effort to deduplicate
+auxiliary bindings there. Instead, we focus on the common case of multiple
+derived instances within the same module, not separated by any TH splices.
+
+To start, genAuxBinds is given a list of AuxBindSpecs, which describe the sort
+of auxiliary bindings that must be generates along with their RdrNames. As
+genAuxBinds processes this list, it marks the first occurrence of each sort of
+auxiliary binding as the "original". For example, if genAuxBinds sees a
+DerivCon2Tag for the first time (with the RdrName $con2tag_T{Uniq1}), then it
+will generate the full code for a $con2tag binding:
+
+ $con2tag_T{Uniq1} :: T -> Int
+ $con2tag_T{Uniq1} = ...code....
+
+Later, if genAuxBinds sees any additional DerivCon2Tag values, it will treat
+them as duplicates. For example, if genAuxBinds later sees a DerivCon2Tag with
+the RdrName $con2tag_T{Uniq2}, it will generate this code, which is much more
+compact:
+
+ $con2tag_T{Uniq2} :: T -> Int
+ $con2tag_T{Uniq2} = $con2tag_T{Uniq1}
+
+An alternative approach is to avoid any kind of deduplication in genAuxBinds at
+all and simply rely on GHC's simplifier to perform this kind of CSE. But this
+is a more expensive analysis in general, while genAuxBinds can accomplish the
+same result with a trivial check.
-}
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -591,6 +591,10 @@ hasStockDeriving clas
= let (binds, deriv_stuff) = gen_fn loc tc
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
; return (binds, deriv_stuff, []) }
=====================================
compiler/GHC/Types/Name/Occurrence.hs
=====================================
@@ -608,7 +608,7 @@ mkDataConWrapperOcc, mkWorkerOcc,
mkGenR, mkGen1R,
mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
- mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
+ mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkDataTOcc, mkDataCOcc,
mkTyConRepOcc
:: OccName -> OccName
@@ -629,10 +629,13 @@ mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes
mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions
mkEqPredCoOcc = mk_simple_deriv tcName "$co"
--- Used in derived instances
+-- Used in derived instances for the names of auxilary bindings.
+-- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
+mkDataTOcc = mk_simple_deriv varName "$t"
+mkDataCOcc = mk_simple_deriv varName "$c"
-- TyConRepName stuff; see Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable
mkTyConRepOcc occ = mk_simple_deriv varName prefix occ
@@ -697,16 +700,6 @@ mkDFunOcc info_str is_boot set
prefix | is_boot = "$fx"
| otherwise = "$f"
-mkDataTOcc, mkDataCOcc
- :: OccName -- ^ TyCon or data con string
- -> OccSet -- ^ avoid these Occs
- -> OccName -- ^ E.g. @$f3OrdMaybe@
--- data T = MkT ... deriving( Data ) needs definitions for
--- $tT :: Data.Generics.Basics.DataType
--- $cMkT :: Data.Generics.Basics.Constr
-mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ)
-mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ)
-
{-
Sometimes we need to pick an OccName that has not already been used,
given a set of in-use OccNames.
=====================================
testsuite/tests/deriving/should_compile/T14682.stderr
=====================================
@@ -23,8 +23,8 @@ Derived class instances:
Data.Data.gfoldl k z (T14682.Foo a1 a2)
= ((z (\ a1 a2 -> T14682.Foo a1 a2) `k` a1) `k` a2)
Data.Data.gunfold k z _ = k (k (z (\ a1 a2 -> T14682.Foo a1 a2)))
- Data.Data.toConstr (T14682.Foo _ _) = T14682.$cFoo
- Data.Data.dataTypeOf _ = T14682.$tFoo
+ Data.Data.toConstr (T14682.Foo _ _) = $cFoo
+ Data.Data.dataTypeOf _ = $tFoo
instance GHC.Classes.Eq T14682.Foo where
(GHC.Classes.==) (T14682.Foo a1 a2) (T14682.Foo b1 b2)
@@ -71,14 +71,12 @@ Derived class instances:
= (GHC.Ix.inRange (a1, b1) c1
GHC.Classes.&& GHC.Ix.inRange (a2, b2) c2)
- T14682.$con2tag_B4iUvrAY4wB3YczpMJQUOX ::
- T14682.Foo -> GHC.Prim.Int#
- T14682.$con2tag_B4iUvrAY4wB3YczpMJQUOX (T14682.Foo _ _) = 0#
- T14682.$tFoo :: Data.Data.DataType
- T14682.$cFoo :: Data.Data.Constr
- T14682.$tFoo = Data.Data.mkDataType "Foo" [T14682.$cFoo]
- T14682.$cFoo
- = Data.Data.mkConstr T14682.$tFoo "Foo" [] Data.Data.Prefix
+ $tFoo :: Data.Data.DataType
+ $cFoo :: Data.Data.Constr
+ $con2tag_Foo :: T14682.Foo -> GHC.Prim.Int#
+ $con2tag_Foo (T14682.Foo _ _) = 0#
+ $tFoo = Data.Data.mkDataType "Foo" [$cFoo]
+ $cFoo = Data.Data.mkConstr $tFoo "Foo" [] Data.Data.Prefix
Derived type family instances:
=====================================
testsuite/tests/deriving/should_compile/T18321.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T18321 where
+
+import Data.Ix
+
+data T = MkT deriving (Eq, Ord, Ix)
+$(return [])
+deriving instance Enum T
+
+data S a = MkS
+deriving instance Enum (S Int)
+$(return [])
+deriving instance Enum (S Bool)
=====================================
testsuite/tests/deriving/should_compile/all.T
=====================================
@@ -124,3 +124,4 @@ test('T17339', normal, compile,
['-ddump-simpl -dsuppress-idinfo -dno-typeable-binds'])
test('T17880', normal, compile, [''])
test('T18055', normal, compile, [''])
+test('T18321', normal, compile, [''])
=====================================
testsuite/tests/deriving/should_compile/drv-empty-data.stderr
=====================================
@@ -20,7 +20,7 @@ Derived class instances:
Data.Data.gfoldl _ _ z = case z of
Data.Data.gunfold k z c = case Data.Data.constrIndex c of
Data.Data.toConstr z = case z of
- Data.Data.dataTypeOf _ = DrvEmptyData.$tVoid
+ Data.Data.dataTypeOf _ = $tVoid
Data.Data.dataCast1 f = Data.Typeable.gcast1 f
instance GHC.Base.Functor DrvEmptyData.Void where
@@ -48,8 +48,8 @@ Derived class instances:
Language.Haskell.TH.Syntax.lift z = GHC.Base.pure (case z of)
Language.Haskell.TH.Syntax.liftTyped z = GHC.Base.pure (case z of)
- DrvEmptyData.$tVoid :: Data.Data.DataType
- DrvEmptyData.$tVoid = Data.Data.mkDataType "Void" []
+ $tVoid :: Data.Data.DataType
+ $tVoid = Data.Data.mkDataType "Void" []
Derived type family instances:
type GHC.Generics.Rep (DrvEmptyData.Void a) = GHC.Generics.D1
@@ -64,124 +64,124 @@ Derived type family instances:
==================== Filling in method body ====================
-GHC.Read.Read [DrvEmptyData.Void a[ssk:2]]
+GHC.Read.Read [DrvEmptyData.Void a[ssk:1]]
GHC.Read.readsPrec = GHC.Read.$dmreadsPrec
- @(DrvEmptyData.Void a[ssk:2])
+ @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-GHC.Show.Show [DrvEmptyData.Void a[ssk:2]]
- GHC.Show.show = GHC.Show.$dmshow @(DrvEmptyData.Void a[ssk:2])
+GHC.Show.Show [DrvEmptyData.Void a[ssk:1]]
+ GHC.Show.show = GHC.Show.$dmshow @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-GHC.Show.Show [DrvEmptyData.Void a[ssk:2]]
+GHC.Show.Show [DrvEmptyData.Void a[ssk:1]]
GHC.Show.showList = GHC.Show.$dmshowList
- @(DrvEmptyData.Void a[ssk:2])
+ @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
- GHC.Classes.< = GHC.Classes.$dm< @(DrvEmptyData.Void a[ssk:2])
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]]
+ GHC.Classes.< = GHC.Classes.$dm< @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
- GHC.Classes.<= = GHC.Classes.$dm<= @(DrvEmptyData.Void a[ssk:2])
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]]
+ GHC.Classes.<= = GHC.Classes.$dm<= @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
- GHC.Classes.> = GHC.Classes.$dm> @(DrvEmptyData.Void a[ssk:2])
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]]
+ GHC.Classes.> = GHC.Classes.$dm> @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
- GHC.Classes.>= = GHC.Classes.$dm>= @(DrvEmptyData.Void a[ssk:2])
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]]
+ GHC.Classes.>= = GHC.Classes.$dm>= @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
- GHC.Classes.max = GHC.Classes.$dmmax @(DrvEmptyData.Void a[ssk:2])
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]]
+ GHC.Classes.max = GHC.Classes.$dmmax @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-GHC.Classes.Ord [DrvEmptyData.Void a[ssk:2]]
- GHC.Classes.min = GHC.Classes.$dmmin @(DrvEmptyData.Void a[ssk:2])
+GHC.Classes.Ord [DrvEmptyData.Void a[ssk:1]]
+ GHC.Classes.min = GHC.Classes.$dmmin @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-GHC.Classes.Eq [DrvEmptyData.Void a[ssk:2]]
- GHC.Classes./= = GHC.Classes.$dm/= @(DrvEmptyData.Void a[ssk:2])
+GHC.Classes.Eq [DrvEmptyData.Void a[ssk:1]]
+ GHC.Classes./= = GHC.Classes.$dm/= @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+Data.Data.Data [DrvEmptyData.Void a[ssk:1]]
Data.Data.dataCast2 = Data.Data.$dmdataCast2
- @(DrvEmptyData.Void a[ssk:2])
+ @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
- Data.Data.gmapT = Data.Data.$dmgmapT @(DrvEmptyData.Void a[ssk:2])
+Data.Data.Data [DrvEmptyData.Void a[ssk:1]]
+ Data.Data.gmapT = Data.Data.$dmgmapT @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+Data.Data.Data [DrvEmptyData.Void a[ssk:1]]
Data.Data.gmapQl = Data.Data.$dmgmapQl
- @(DrvEmptyData.Void a[ssk:2])
+ @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+Data.Data.Data [DrvEmptyData.Void a[ssk:1]]
Data.Data.gmapQr = Data.Data.$dmgmapQr
- @(DrvEmptyData.Void a[ssk:2])
+ @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
- Data.Data.gmapQ = Data.Data.$dmgmapQ @(DrvEmptyData.Void a[ssk:2])
+Data.Data.Data [DrvEmptyData.Void a[ssk:1]]
+ Data.Data.gmapQ = Data.Data.$dmgmapQ @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+Data.Data.Data [DrvEmptyData.Void a[ssk:1]]
Data.Data.gmapQi = Data.Data.$dmgmapQi
- @(DrvEmptyData.Void a[ssk:2])
+ @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
- Data.Data.gmapM = Data.Data.$dmgmapM @(DrvEmptyData.Void a[ssk:2])
+Data.Data.Data [DrvEmptyData.Void a[ssk:1]]
+ Data.Data.gmapM = Data.Data.$dmgmapM @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+Data.Data.Data [DrvEmptyData.Void a[ssk:1]]
Data.Data.gmapMp = Data.Data.$dmgmapMp
- @(DrvEmptyData.Void a[ssk:2])
+ @(DrvEmptyData.Void a[ssk:1])
==================== Filling in method body ====================
-Data.Data.Data [DrvEmptyData.Void a[ssk:2]]
+Data.Data.Data [DrvEmptyData.Void a[ssk:1]]
Data.Data.gmapMo = Data.Data.$dmgmapMo
- @(DrvEmptyData.Void a[ssk:2])
+ @(DrvEmptyData.Void a[ssk:1])
@@ -191,6 +191,13 @@ Data.Foldable.Foldable [DrvEmptyData.Void]
+==================== Filling in method body ====================
+Data.Foldable.Foldable [DrvEmptyData.Void]
+ Data.Foldable.foldMap' = Data.Foldable.$dmfoldMap'
+ @(DrvEmptyData.Void)
+
+
+
==================== Filling in method body ====================
Data.Foldable.Foldable [DrvEmptyData.Void]
Data.Foldable.foldr = Data.Foldable.$dmfoldr @(DrvEmptyData.Void)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f479858d15b91e4c182a4e68b97b7c60a403eff0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f479858d15b91e4c182a4e68b97b7c60a403eff0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200621/30aa89fd/attachment-0001.html>
More information about the ghc-commits
mailing list