diff options
Diffstat (limited to 'compiler/GHC/Tc/Deriv')
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Functor.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 127 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Generics.hs | 48 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Infer.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Utils.hs | 178 |
5 files changed, 198 insertions, 166 deletions
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs index 1f781398ca..b3e9fb775c 100644 --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -149,7 +149,7 @@ is a similar algorithm for generating `p <$ x` (for some constant `p`): $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) -} -gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) +gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) -- When the argument is phantom, we can use fmap _ = coerce -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon}) @@ -784,7 +784,7 @@ could surprise users if they switch to other types, but Ryan Scott seems to think it's okay to do it for now. -} -gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) +gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) -- When the parameter is phantom, we can use foldMap _ _ = mempty -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon}) @@ -1018,7 +1018,7 @@ removes all such types from consideration. See Note [Generated code for DeriveFoldable and DeriveTraversable]. -} -gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) +gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) -- When the argument is phantom, we can use traverse = pure . coerce -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon}) diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 7c03f52bd0..d61ad20707 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -19,7 +19,7 @@ -- -- This is where we do all the grimy bindings' generation. module GHC.Tc.Deriv.Generate ( - BagDerivStuff, DerivStuff(..), + AuxBindSpec(..), gen_Eq_binds, gen_Ord_binds, @@ -31,6 +31,7 @@ module GHC.Tc.Deriv.Generate ( gen_Data_binds, gen_Lift_binds, gen_Newtype_binds, + gen_Newtype_fam_insts, mkCoerceClassMethEqn, genAuxBinds, ordOpTbl, boxConTbl, litConTbl, @@ -87,8 +88,6 @@ import Data.List ( find, partition, intersperse ) import GHC.Data.Maybe ( expectJust ) import GHC.Unit.Module -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. @@ -138,23 +137,6 @@ 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 - -- ^ 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 - - {- ************************************************************************ * * @@ -214,7 +196,7 @@ for the instance decl, which it probably wasn't, so the decls produced don't get through the typechecker. -} -gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon , dit_rep_tc_args = tycon_args }) = do return (method_binds, emptyBag) @@ -391,7 +373,7 @@ gtResult OrdGE = true_Expr gtResult OrdGT = true_Expr ------------ -gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon , dit_rep_tc_args = tycon_args }) = do return $ if null tycon_data_cons -- No data-cons => invoke bale-out case @@ -640,7 +622,7 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. -} -gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do -- See Note [Auxiliary binders] tag2con_RDR <- new_tag2con_rdr_name loc tycon @@ -657,7 +639,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..] , from_enum ] - aux_binds tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind + aux_binds tag2con_RDR maxtag_RDR = listToBag [ DerivTag2Con tycon tag2con_RDR , DerivMaxTag tycon maxtag_RDR ] @@ -730,7 +712,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do ************************************************************************ -} -gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) +gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = tycon}) | isEnumerationTyCon tycon = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) @@ -817,14 +799,14 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). -} -gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff) +gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do -- See Note [Auxiliary binders] tag2con_RDR <- new_tag2con_rdr_name loc tycon return $ if isEnumerationTyCon tycon - then (enum_ixes tag2con_RDR, listToBag $ map DerivAuxBind + then (enum_ixes tag2con_RDR, listToBag [ DerivTag2Con tycon tag2con_RDR ]) else (single_con_ixes, emptyBag) @@ -1020,7 +1002,7 @@ we want to be able to parse (Left 3) just fine. -} gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys - -> (LHsBinds GhcPs, BagDerivStuff) + -> (LHsBinds GhcPs, Bag AuxBindSpec) gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) @@ -1204,7 +1186,7 @@ Example -} gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys - -> (LHsBinds GhcPs, BagDerivStuff) + -> (LHsBinds GhcPs, Bag AuxBindSpec) gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon , dit_rep_tc_args = tycon_args }) @@ -1377,7 +1359,7 @@ we generate gen_Data_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, -- The method bindings - BagDerivStuff) -- Auxiliary bindings + Bag AuxBindSpec) -- Auxiliary bindings gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc}) = do { -- See Note [Auxiliary binders] dataT_RDR <- new_dataT_rdr_name loc rep_tc @@ -1387,7 +1369,7 @@ gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc}) , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ] `unionBags` gcast_binds -- Auxiliary definitions: the data type and constructors - , listToBag $ map DerivAuxBind + , listToBag ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs : zipWith (\data_con dataC_RDR -> DerivDataConstr data_con dataC_RDR dataT_RDR) @@ -1642,7 +1624,7 @@ lifting warning in derived code. (See #20688) -} -gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff) +gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec) gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon , dit_rep_tc_args = tycon_args }) = (listToBag [lift_bind, liftTyped_bind], emptyBag) @@ -1971,17 +1953,18 @@ gen_Newtype_binds :: SrcSpan -- newtype itself) -> [Type] -- instance head parameters (incl. newtype) -> Type -- the representation type - -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff) + -> (LHsBinds GhcPs, [LSig GhcPs]) -- See Note [Newtype-deriving instances] gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty - = do let ats = classATs cls - (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls) - atf_insts <- assert (all (not . isDataFamilyTyCon) ats) $ - mapM mk_atf_inst ats - return ( listToBag binds - , sigs - , listToBag $ map DerivFamInst atf_insts ) + = (listToBag binds, sigs) where + (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls) + + -- Same as inst_tys, but with the last argument type replaced by the + -- representation type. + underlying_inst_tys :: [Type] + underlying_inst_tys = changeLast inst_tys rhs_ty + locn = noAnnSrcSpan loc' loca = noAnnSrcSpan loc' -- For each class method, generate its derived binding and instance @@ -2051,6 +2034,33 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty -- Filter out any inferred arguments, since they can't be -- applied with visible type application. +gen_Newtype_fam_insts :: SrcSpan + -> Class -- the class being derived + -> [TyVar] -- the tvs in the instance head (this includes + -- the tvs from both the class types and the + -- newtype itself) + -> [Type] -- instance head parameters (incl. newtype) + -> Type -- the representation type + -> TcM [FamInst] +-- See Note [GND and associated type families] in GHC.Tc.Deriv +gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty + = assert (all (not . isDataFamilyTyCon) ats) $ + mapM mk_atf_inst ats + where + -- Same as inst_tys, but with the last argument type replaced by the + -- representation type. + underlying_inst_tys :: [Type] + underlying_inst_tys = changeLast inst_tys rhs_ty + + ats = classATs cls + locn = noAnnSrcSpan loc' + cls_tvs = classTyVars cls + in_scope = mkInScopeSet $ mkVarSet inst_tvs + lhs_env = zipTyEnv cls_tvs inst_tys + lhs_subst = mkTvSubst in_scope lhs_env + rhs_env = zipTyEnv cls_tvs underlying_inst_tys + rhs_subst = mkTvSubst in_scope rhs_env + mk_atf_inst :: TyCon -> TcM FamInst mk_atf_inst fam_tc = do rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc)) @@ -2061,12 +2071,6 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) newFamInst SynFamilyInst axiom where - cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs - lhs_env = zipTyEnv cls_tvs inst_tys - lhs_subst = mkTvSubst in_scope lhs_env - rhs_env = zipTyEnv cls_tvs underlying_inst_tys - rhs_subst = mkTvSubst in_scope rhs_env fam_tvs = tyConTyVars fam_tc rep_lhs_tys = substTyVars lhs_subst fam_tvs rep_rhs_tys = substTyVars rhs_subst fam_tvs @@ -2076,11 +2080,6 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty rep_tvs' = scopedSort rep_tvs rep_cvs' = scopedSort rep_cvs - -- Same as inst_tys, but with the last argument type replaced by the - -- representation type. - underlying_inst_tys :: [Type] - underlying_inst_tys = changeLast inst_tys rhs_ty - nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty) where @@ -2216,25 +2215,13 @@ genAuxBindSpecSig loc spec = case spec of where mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType -type SeparateBagsDerivStuff = - -- DerivAuxBinds - ( Bag (LHsBind GhcPs, LSig GhcPs) - - -- 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 = (gen_aux_bind_specs b1, b2) where - (b1,b2) = partitionBagWith splitDerivAuxBind b - splitDerivAuxBind (DerivAuxBind x) = Left x - splitDerivAuxBind (DerivFamInst t) = Right t - - gen_aux_bind_specs = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) - +-- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary +-- bindings based on the declarative descriptions in the supplied +-- 'AuxBindSpec's. See @Note [Auxiliary binders]@. +genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec + -> Bag (LHsBind GhcPs, LSig GhcPs) +genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) + where -- Perform a CSE-like pass over the generated auxiliary bindings to avoid -- code duplication, as described in -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication). diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index 65a7329729..dde32082e6 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -12,10 +12,11 @@ -- | The deriving code for the Generic class module GHC.Tc.Deriv.Generics - (canDoGenerics + ( canDoGenerics , canDoGenerics1 , GenericKind(..) , gen_Generic_binds + , gen_Generic_fam_inst , get_gen1_constrained_tys ) where @@ -76,13 +77,11 @@ For the generic representation we need to generate: \end{itemize} -} -gen_Generic_binds :: GenericKind -> (Name -> Fixity) -> [Type] -> DerivInstTys - -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst) -gen_Generic_binds gk get_fixity inst_tys dit = do +gen_Generic_binds :: GenericKind -> SrcSpan -> DerivInstTys + -> TcM (LHsBinds GhcPs, [LSig GhcPs]) +gen_Generic_binds gk loc dit = do dflags <- getDynFlags - repTyInsts <- tc_mkRepFamInsts gk get_fixity inst_tys dit - let (binds, sigs) = mkBindsRep dflags gk dit - return (binds, sigs, repTyInsts) + return $ mkBindsRep dflags gk loc dit {- ************************************************************************ @@ -332,8 +331,8 @@ gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ) -- Bindings for the Generic instance -mkBindsRep :: DynFlags -> GenericKind -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs]) -mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs) +mkBindsRep :: DynFlags -> GenericKind -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs]) +mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs) where binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn]) `unionBags` @@ -369,7 +368,6 @@ mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs) from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] - loc = srcLocSpan (getSrcLoc tycon) loc' = noAnnSrcSpan loc loc'' = noAnnSrcSpan loc datacons = tyConDataCons tycon @@ -388,14 +386,17 @@ mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs) -- type Rep_D a b = ...representation type for D ... -------------------------------------------------------------------------------- -tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 - -> (Name -> Fixity) -- Get the Fixity for a data constructor Name - -> [Type] -- The type(s) to which Generic(1) is applied - -- in the generated instance - -> DerivInstTys -- Information about the last type argument, - -- including the data type's TyCon - -> TcM FamInst -- Generated representation0 coercion -tc_mkRepFamInsts gk get_fixity inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) = +gen_Generic_fam_inst :: GenericKind -- Gen0 or Gen1 + -> (Name -> Fixity) -- Get the Fixity for a data constructor Name + -> SrcSpan -- The current source location + -> DerivInstTys -- Information about the type(s) to which + -- Generic(1) is applied in the generated + -- instance, including the data type's TyCon + -> TcM FamInst -- Generated representation0 coercion +gen_Generic_fam_inst gk get_fixity loc + dit@(DerivInstTys{ dit_cls_tys = cls_tys + , dit_tc = tc, dit_tc_args = tc_args + , dit_rep_tc = tycon }) = -- Consider the example input tycon `D`, where data D a b = D_ a -- Also consider `R:DInt`, where { data family D x y :: * -> * -- ; data instance D Int a b = D_ a } @@ -413,17 +414,18 @@ tc_mkRepFamInsts gk get_fixity inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) = -- instance Generic1 (Bar x :: k -> *) -- then: -- `arg_k` = k, `inst_ty` = Bar x :: k -> * - (arg_ki, inst_ty) = case (gk, inst_tys) of - (Gen0, [inst_t]) -> (liftedTypeKind, inst_t) - (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t) - _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys) + arg_ki = case (gk, cls_tys) of + (Gen0, []) -> liftedTypeKind + (Gen1, [arg_k]) -> arg_k + _ -> pprPanic "gen_Generic_fam_insts" (ppr cls_tys) + inst_ty = mkTyConApp tc tc_args + inst_tys = cls_tys ++ [inst_ty] -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * ; repTy <- tc_mkRepTy gk get_fixity dit arg_ki -- `rep_name` is a name we generate for the synonym ; mod <- getModule - ; loc <- getSrcSpanM ; let tc_occ = nameOccName (tyConName tycon) rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ ; rep_name <- newGlobalBinder mod rep_occ loc diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index ccc44df2b4..3b2d3f80dd 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -665,13 +665,14 @@ simplifyInstanceContexts infer_specs | otherwise = do { -- Extend the inst info from the explicit instance decls -- with the current set of solutions, and simplify each RHS - inst_specs <- zipWithM newDerivClsInst current_solns infer_specs + inst_specs <- zipWithM (\soln -> newDerivClsInst . setDerivSpecTheta soln) + current_solns infer_specs ; new_solns <- checkNoErrs $ extendLocalInstEnv inst_specs $ mapM gen_soln infer_specs ; if (current_solns `eqSolution` new_solns) then - return [ spec { ds_theta = soln } + return [ setDerivSpecTheta soln spec | (spec, soln) <- zip infer_specs current_solns ] else iterate_deriv (n+1) new_solns } diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index 8a5b376767..5fe1f6b185 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -10,10 +10,10 @@ -- | Error-checking and other utilities for @deriving@ clauses or declarations. module GHC.Tc.Deriv.Utils ( DerivM, DerivEnv(..), - DerivSpec(..), pprDerivSpec, + DerivSpec(..), pprDerivSpec, setDerivSpecTheta, DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia, - DerivContext(..), OriginativeDerivStatus(..), + DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..), isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin, PredOrigin(..), ThetaOrigin(..), mkPredOrigin, mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, @@ -28,6 +28,7 @@ import GHC.Data.Bag import GHC.Types.Basic import GHC.Core.Class import GHC.Core.DataCon +import GHC.Core.FamInstEnv import GHC.Driver.Session import GHC.Utils.Error import GHC.Types.Fixity.Env (lookupFixity) @@ -179,6 +180,10 @@ pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, instance Outputable theta => Outputable (DerivSpec theta) where ppr = pprDerivSpec +-- | Set the 'ds_theta' in a 'DerivSpec'. +setDerivSpecTheta :: theta' -> DerivSpec theta -> DerivSpec theta' +setDerivSpecTheta theta ds = ds{ds_theta = theta} + -- | What action to take in order to derive a class instance. -- See @Note [DerivEnv and DerivSpecMechanism]@, as well as -- @Note [Deriving strategies]@ in "GHC.Tc.Deriv". @@ -189,28 +194,9 @@ data DerivSpecMechanism -- ^ Information about the arguments to the class in the derived -- instance, including what type constructor the last argument is -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. - , dsm_stock_gen_fn :: - SrcSpan -> [Type] -- inst_tys - -> DerivInstTys -- dsm_stock_dit - -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]) - -- ^ This function returns four things: - -- - -- 1. @LHsBinds GhcPs@: The derived instance's function bindings - -- (e.g., @compare (T x) (T y) = compare x y@) - -- - -- 2. @[LSig GhcPs]@: A list of instance specific signatures/pragmas. - -- Most likely INLINE pragmas for class methods. - -- - -- 3. @BagDerivStuff@: Auxiliary bindings needed to support the derived - -- instance. As examples, derived 'Generic' instances require - -- associated type family instances, and derived 'Eq' and 'Ord' - -- instances require top-level @con2tag@ functions. - -- See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate". - -- - -- 4. @[Name]@: A list of Names for which @-Wunused-binds@ should be - -- suppressed. This is used to suppress unused warnings for record - -- selectors when deriving 'Read', 'Show', or 'Generic'. - -- See @Note [Deriving and unused record selectors]@. + , dsm_stock_gen_fns :: StockGenFns + -- ^ How to generate the instance bindings and associated type family + -- instances. } -- | @GeneralizedNewtypeDeriving@ @@ -401,13 +387,61 @@ instance Outputable DerivContext where -- -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". data OriginativeDerivStatus - = CanDeriveStock -- Stock class, can derive - (SrcSpan -> [Type] -> DerivInstTys - -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) + = CanDeriveStock StockGenFns -- Stock class, can derive | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it | CanDeriveAnyClass -- See Note [Deriving any class] | NonDerivableClass -- Cannot derive with either stock or anyclass +-- | Describes how to generate instance bindings ('stock_gen_binds') and +-- associated type family instances ('stock_gen_fam_insts') for a particular +-- stock-derived instance. +data StockGenFns = StockGenFns + { stock_gen_binds :: + SrcSpan -> DerivInstTys + -> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name]) + -- ^ Describes how to generate instance bindings for a stock-derived + -- instance. + -- + -- This function takes two arguments: + -- + -- 1. 'SrcSpan': the source location where the instance is being derived. + -- This will eventually be instantiated with the 'ds_loc' field of a + -- 'DerivSpec'. + -- + -- 2. 'DerivInstTys': information about the argument types to which a + -- class is applied in a derived instance. This will eventually be + -- instantiated with the 'dsm_stock_dit' field of a + -- 'DerivSpecMechanism'. + -- + -- This function returns four things: + -- + -- 1. @'LHsBinds' 'GhcPs'@: The derived instance's function bindings + -- (e.g., @compare (T x) (T y) = compare x y@) + -- + -- 2. @['LSig' 'GhcPs']@: A list of instance specific signatures/pragmas. + -- Most likely @INLINE@ pragmas for class methods. + -- + -- 3. @'Bag' 'AuxBindSpec'@: Auxiliary bindings needed to support the + -- derived instance. As examples, derived 'Eq' and 'Ord' instances + -- sometimes require top-level @con2tag@ functions. + -- See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate". + -- + -- 4. @['Name']@: A list of Names for which @-Wunused-binds@ should be + -- suppressed. This is used to suppress unused warnings for record + -- selectors when deriving 'Read', 'Show', or 'Generic'. + -- See @Note [Deriving and unused record selectors]@. + , stock_gen_fam_insts :: + SrcSpan -> DerivInstTys + -> TcM [FamInst] + -- ^ Describes how to generate associated type family instances for a + -- stock-derived instance. This function takes the same arguments as the + -- 'stock_gen_binds' function but returns a list of 'FamInst's instead. + -- Generating type family instances is done separately from + -- 'stock_gen_binds' since the type family instances must be generated + -- before the instance bindings can be typechecked. See + -- @Note [Staging of tcDeriving]@ in "GHC.Tc.Deriv". + } + -- A stock class is one either defined in the Haskell report or for which GHC -- otherwise knows how to generate code for (possibly requiring the use of a -- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) @@ -542,58 +576,65 @@ is willing to support it. -} hasStockDeriving - :: Class -> Maybe (SrcSpan - -> [Type] - -> DerivInstTys - -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) + :: Class -> Maybe StockGenFns hasStockDeriving clas = assocMaybe gen_list (getUnique clas) where - gen_list - :: [(Unique, SrcSpan - -> [Type] - -> DerivInstTys - -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))] - gen_list = [ (eqClassKey, simpleM gen_Eq_binds) - , (ordClassKey, simpleM gen_Ord_binds) - , (enumClassKey, simpleM gen_Enum_binds) - , (boundedClassKey, simple gen_Bounded_binds) - , (ixClassKey, simpleM gen_Ix_binds) - , (showClassKey, read_or_show gen_Show_binds) - , (readClassKey, read_or_show gen_Read_binds) - , (dataClassKey, simpleM gen_Data_binds) - , (functorClassKey, simple gen_Functor_binds) - , (foldableClassKey, simple gen_Foldable_binds) - , (traversableClassKey, simple gen_Traversable_binds) - , (liftClassKey, simple gen_Lift_binds) - , (genClassKey, generic (gen_Generic_binds Gen0)) - , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] - - simple gen_fn loc _ dit - = let (binds, deriv_stuff) = gen_fn loc dit - in return (binds, [], deriv_stuff, []) + gen_list :: [(Unique, StockGenFns)] + gen_list = + [ (eqClassKey, mk (simple_bindsM gen_Eq_binds) no_fam_insts) + , (ordClassKey, mk (simple_bindsM gen_Ord_binds) no_fam_insts) + , (enumClassKey, mk (simple_bindsM gen_Enum_binds) no_fam_insts) + , (boundedClassKey, mk (simple_binds gen_Bounded_binds) no_fam_insts) + , (ixClassKey, mk (simple_bindsM gen_Ix_binds) no_fam_insts) + , (showClassKey, mk (read_or_show_binds gen_Show_binds) no_fam_insts) + , (readClassKey, mk (read_or_show_binds gen_Read_binds) no_fam_insts) + , (dataClassKey, mk (simple_bindsM gen_Data_binds) no_fam_insts) + , (functorClassKey, mk (simple_binds gen_Functor_binds) no_fam_insts) + , (foldableClassKey, mk (simple_binds gen_Foldable_binds) no_fam_insts) + , (traversableClassKey, mk (simple_binds gen_Traversable_binds) no_fam_insts) + , (liftClassKey, mk (simple_binds gen_Lift_binds) no_fam_insts) + , (genClassKey, mk (generic_binds Gen0) (generic_fam_inst Gen0)) + , (gen1ClassKey, mk (generic_binds Gen1) (generic_fam_inst Gen1)) + ] + + mk gen_binds_fn gen_fam_insts_fn = StockGenFns + { stock_gen_binds = gen_binds_fn + , stock_gen_fam_insts = gen_fam_insts_fn + } + + simple_binds gen_fn loc dit + = let (binds, aux_specs) = gen_fn loc dit + in return (binds, [], aux_specs, []) -- 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 _ dit - = do { (binds, deriv_stuff) <- gen_fn loc dit - ; return (binds, [], deriv_stuff, []) } + simple_bindsM gen_fn loc dit + = do { (binds, aux_specs) <- gen_fn loc dit + ; return (binds, [], aux_specs, []) } - read_or_show gen_fn loc _ dit + read_or_show_binds gen_fn loc dit = do { let tc = dit_rep_tc dit ; fix_env <- getDataConFixityFun tc - ; let (binds, deriv_stuff) = gen_fn fix_env loc dit - field_names = all_field_names tc - ; return (binds, [], deriv_stuff, field_names) } + ; let (binds, aux_specs) = gen_fn fix_env loc dit + field_names = all_field_names tc + ; return (binds, [], aux_specs, field_names) } - generic gen_fn _ inst_tys dit + generic_binds gk loc dit = do { let tc = dit_rep_tc dit - ; fix_env <- getDataConFixityFun tc - ; (binds, sigs, faminst) <- gen_fn fix_env inst_tys dit + ; (binds, sigs) <- gen_Generic_binds gk loc dit ; let field_names = all_field_names tc - ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) } + ; return (binds, sigs, emptyBag, field_names) } + + generic_fam_inst gk loc dit + = do { let tc = dit_rep_tc dit + ; fix_env <- getDataConFixityFun tc + ; faminst <- gen_Generic_fam_inst gk fix_env loc dit + ; return [faminst] } + + no_fam_insts _ _ = pure [] -- See Note [Deriving and unused record selectors] all_field_names = map flSelector . concatMap dataConFieldLabels @@ -983,9 +1024,10 @@ non_coercible_class cls ------------------------------------------------------------------ -newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst -newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode - , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) +newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst +newDerivClsInst (DS { ds_name = dfun_name, ds_overlap = overlap_mode + , ds_tvs = tvs, ds_theta = theta + , ds_cls = clas, ds_tys = tys }) = newClsInst overlap_mode dfun_name tvs theta clas tys extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a |