diff options
| -rw-r--r-- | compiler/GHC/HsToCore/Usage.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Env.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Make.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Env.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv.hs | 14 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 819 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Utils.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Types/Name/Occurrence.hs | 17 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/T14682.stderr | 18 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/T18321.hs | 15 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/drv-empty-data.stderr | 89 |
12 files changed, 668 insertions, 349 deletions
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index f3b0aa44e1..567c84625e 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/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. +-} diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index 09679d0542..cace8ae046 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/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. diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 53385600ae..b43fe30bb3 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/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. - -} diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 17deae7157..e425fd9457 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -818,15 +818,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 diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index a4d2be7ac6..5140f29d00 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/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)) } } diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 08f6fab20c..01b7896853 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/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,251 @@ 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? We do so by generating a separate $con2tag_T definition for each +instance, giving each definition an Exact RdrName with a separate Unique to +avoid name clashes: + + instance Eq T where + a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b - $con2tag :: T -> Int - $con2tag = ...code.... + instance Ord T where + compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} 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.) + -- $con2tag_T{Uniq1} and $con2tag_T{Uniq2} are Exact RdrNames with + -- underyling System Names -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{Uniq1} :: T -> Int + $con2tag_T{Uniq1} = ...code.... -In the past we used the *unique* from the parent, but that's not stable across -recompilations as uniques are nondeterministic. + $con2tag_T{Uniq2} :: T -> Int + $con2tag_T{Uniq2} = ...code.... + +Note that: + +* This is /precisely/ the same mechanism that we use for + Template Haskell–generated code. + See Note [Binders in Template Haskell] in GHC.ThToHs. + There we explain why we use a 'System' flavour of the Name we generate. + +* See "Wrinkle: Reducing code duplication" for how we can avoid generating + lots of duplicated code in common situations. + +* See "Wrinkle: Why we sometimes do generated duplicate code" for why this + de-duplication mechanism isn't perfect, so we fall back to CSE + (which is very effective within a single module). + +* Note that the "_T" part of "$con2tag_T" is just for debug-printing + purposes. We could call them all "$con2tag", or even just "aux". + The Unique is enough to keep them separate. + + This is important: we might be generating an Eq instance for two + completely-distinct imported type constructors T. + +At first glance, it might appear that this plan 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. + +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} + +(Note that this pass does not cover all possible forms of code duplication. +See "Wrinkle: Why we sometimes do generate duplicate code" for situations +where genAuxBinds does not deduplicate code.) + +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 would be /not/ performing any kind of deduplication in +genAuxBinds at all and simply relying 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 simple check. + +----- +-- Wrinkle: Why we sometimes do generate duplicate code +----- + +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. +(This is the case described in "Wrinkle: Reducing code duplication".) In +situation (1), we can at least fall back on GHC's simplifier to pick up +genAuxBinds' slack. -} diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index e8f5fe6fc0..5f109fd148 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/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, []) } diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index b201ab792f..2ee0621b8b 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/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. diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr index 2bf9552ff9..e0c8b332ed 100644 --- a/testsuite/tests/deriving/should_compile/T14682.stderr +++ b/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: diff --git a/testsuite/tests/deriving/should_compile/T18321.hs b/testsuite/tests/deriving/should_compile/T18321.hs new file mode 100644 index 0000000000..5391cf602b --- /dev/null +++ b/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) diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index 8a363e72f9..f6e9d43b06 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/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, ['']) diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr index d6e4eee4b0..cb6a89b226 100644 --- a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr +++ b/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]) @@ -193,6 +193,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) |