diff options
Diffstat (limited to 'libraries/template-haskell/Language/Haskell')
4 files changed, 57 insertions, 13 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index dbf01f11df..b7966cefac 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -21,7 +21,7 @@ module Language.Haskell.TH.Lib ( StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ, - FamilyResultSigQ, + FamilyResultSigQ, DerivStrategyQ, -- ** Constructors lifted to 'Q' -- *** Literals @@ -79,7 +79,9 @@ module Language.Haskell.TH.Lib ( -- *** Top Level Declarations -- **** Data valD, funD, tySynD, dataD, newtypeD, - derivClause, DerivClause(..), DerivStrategy(..), + derivClause, DerivClause(..), + stockStrategy, anyclassStrategy, newtypeStrategy, + viaStrategy, DerivStrategy(..), -- **** Class classD, instanceD, instanceWithOverlapD, Overlap(..), sigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, @@ -140,6 +142,9 @@ import Language.Haskell.TH.Lib.Internal hiding , kindSig , tyVarSig + , derivClause + , standaloneDerivWithStrategyD + , Role , InjectivityAnn ) @@ -262,3 +267,17 @@ kindSig = KindSig tyVarSig :: TyVarBndr -> FamilyResultSig tyVarSig = TyVarSig + +------------------------------------------------------------------------------- +-- * Top Level Declarations + +derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ +derivClause mds p = do + p' <- cxt p + return $ DerivClause mds p' + +standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD mds ctxt ty = do + ctxt' <- ctxt + ty' <- ty + return $ StandaloneDerivD mds ctxt' ty' diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index 4496ecda25..cac8ea8643 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -57,6 +57,7 @@ type TySynEqnQ = Q TySynEqn type PatSynDirQ = Q PatSynDir type PatSynArgsQ = Q PatSynArgs type FamilyResultSigQ = Q FamilyResultSig +type DerivStrategyQ = Q DerivStrategy -- must be defined here for DsMeta to find it type Role = TH.Role @@ -533,12 +534,13 @@ roleAnnotD name roles = return $ RoleAnnotD name roles standaloneDerivD :: CxtQ -> TypeQ -> DecQ standaloneDerivD = standaloneDerivWithStrategyD Nothing -standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ -standaloneDerivWithStrategyD ds ctxtq tyq = +standaloneDerivWithStrategyD :: Maybe DerivStrategyQ -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD mdsq ctxtq tyq = do + mds <- sequenceA mdsq ctxt <- ctxtq ty <- tyq - return $ StandaloneDerivD ds ctxt ty + return $ StandaloneDerivD mds ctxt ty defaultSigD :: Name -> TypeQ -> DecQ defaultSigD n tyq = @@ -570,9 +572,22 @@ tySynEqn lhs rhs = cxt :: [PredQ] -> CxtQ cxt = sequence -derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ -derivClause ds p = do p' <- cxt p - return $ DerivClause ds p' +derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ +derivClause mds p = do mds' <- sequenceA mds + p' <- cxt p + return $ DerivClause mds' p' + +stockStrategy :: DerivStrategyQ +stockStrategy = pure StockStrategy + +anyclassStrategy :: DerivStrategyQ +anyclassStrategy = pure AnyclassStrategy + +newtypeStrategy :: DerivStrategyQ +newtypeStrategy = pure NewtypeStrategy + +viaStrategy :: TypeQ -> DerivStrategyQ +viaStrategy = fmap ViaStrategy normalC :: Name -> [BangTypeQ] -> ConQ normalC con strtys = liftM (NormalC con) $ sequence strtys diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 46f4dc0444..7edc15c696 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -388,11 +388,12 @@ ppr_dec _ (PatSynSigD name ty) = pprPatSynSig name ty ppr_deriv_strategy :: DerivStrategy -> Doc -ppr_deriv_strategy ds = text $ +ppr_deriv_strategy ds = case ds of - StockStrategy -> "stock" - AnyclassStrategy -> "anyclass" - NewtypeStrategy -> "newtype" + StockStrategy -> text "stock" + AnyclassStrategy -> text "anyclass" + NewtypeStrategy -> text "newtype" + ViaStrategy ty -> text "via" <+> pprParendType ty ppr_overlap :: Overlap -> Doc ppr_overlap o = text $ @@ -452,8 +453,16 @@ ppr_newtype maybeInst ctxt t argsDoc ksig c decs ppr_deriv_clause :: DerivClause -> Doc ppr_deriv_clause (DerivClause ds ctxt) - = text "deriving" <+> maybe empty ppr_deriv_strategy ds + = text "deriving" <+> pp_strat_before <+> ppr_cxt_preds ctxt + <+> pp_strat_after + where + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (pp_strat_before, pp_strat_after) = + case ds of + Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via) + _ -> (maybe empty ppr_deriv_strategy ds, empty) ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 3a3cf60349..95ece50bcc 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1743,6 +1743,7 @@ data DerivClause = DerivClause (Maybe DerivStrategy) Cxt data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance | AnyclassStrategy -- ^ @-XDeriveAnyClass@ | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | ViaStrategy Type -- ^ @-XDerivingVia@ deriving( Show, Eq, Ord, Data, Generic ) -- | A Pattern synonym's type. Note that a pattern synonym's *fully* |