summaryrefslogtreecommitdiff
path: root/compiler/hsSyn
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r--compiler/hsSyn/Convert.hs18
-rw-r--r--compiler/hsSyn/HsDecls.hs66
-rw-r--r--compiler/hsSyn/HsExtension.hs8
-rw-r--r--compiler/hsSyn/HsInstances.hs5
4 files changed, 85 insertions, 12 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 9063d1f773..71cf5a6c34 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -359,11 +359,12 @@ cvtDec (TH.RoleAnnotD tc roles)
cvtDec (TH.StandaloneDerivD ds cxt ty)
= do { cxt' <- cvtContext cxt
+ ; ds' <- traverse cvtDerivStrategy ds
; L loc ty' <- cvtType ty
; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
; returnJustL $ DerivD noExt $
DerivDecl { deriv_ext =noExt
- , deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
+ , deriv_strategy = ds'
, deriv_type = mkLHsSigWcType inst_ty'
, deriv_overlap_mode = Nothing } }
@@ -1229,14 +1230,17 @@ cvtPred = cvtType
cvtDerivClause :: TH.DerivClause
-> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause (TH.DerivClause ds ctxt)
- = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt
- ; let ds' = fmap (L loc . cvtDerivStrategy) ds
+ = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext ctxt
+ ; ds' <- traverse cvtDerivStrategy ds
; returnL $ HsDerivingClause noExt ds' ctxt' }
-cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy
-cvtDerivStrategy TH.StockStrategy = Hs.StockStrategy
-cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy
-cvtDerivStrategy TH.NewtypeStrategy = Hs.NewtypeStrategy
+cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
+cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy
+cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy
+cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy
+cvtDerivStrategy (TH.ViaStrategy ty) = do
+ ty' <- cvtType ty
+ returnL $ Hs.ViaStrategy (mkLHsSigType ty')
cvtType :: TH.Type -> CvtM (LHsType GhcPs)
cvtType = cvtTypeKind "type"
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index d389f61e86..076c590f0b 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -45,6 +45,8 @@ module HsDecls (
-- ** Standalone deriving declarations
DerivDecl(..), LDerivDecl,
+ -- ** Deriving strategies
+ DerivStrategy(..), LDerivStrategy, derivStrategyName,
-- ** @RULE@ declarations
LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..),
RuleBndr(..),LRuleBndr,
@@ -103,6 +105,7 @@ import Class
import Outputable
import Util
import SrcLoc
+import Type
import Bag
import Maybes
@@ -1143,7 +1146,7 @@ data HsDerivingClause pass
-- See Note [Deriving strategies] in TcDeriv
= HsDerivingClause
{ deriv_clause_ext :: XCHsDerivingClause pass
- , deriv_clause_strategy :: Maybe (Located DerivStrategy)
+ , deriv_clause_strategy :: Maybe (LDerivStrategy pass)
-- ^ The user-specified strategy (if any) to use when deriving
-- 'deriv_clause_tys'.
, deriv_clause_tys :: Located [LHsSigType pass]
@@ -1166,8 +1169,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
ppr (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct })
= hsep [ text "deriving"
- , ppDerivStrategy dcs
- , pp_dct dct ]
+ , pp_strat_before
+ , pp_dct dct
+ , pp_strat_after ]
where
-- This complexity is to distinguish between
-- deriving Show
@@ -1175,6 +1179,13 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
pp_dct [HsIB { hsib_body = ty }]
= ppr (parenthesizeHsType appPrec ty)
pp_dct _ = parens (interpp'SP dct)
+
+ -- @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 dcs of
+ Just (L _ via@ViaStrategy{}) -> (empty, ppr via)
+ _ -> (ppDerivStrategy dcs, empty)
ppr (XHsDerivingClause x) = ppr x
data NewOrData
@@ -1717,7 +1728,8 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
<+> ppr inst_ty
ppr (XClsInstDecl x) = ppr x
-ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc
+ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p)
+ => Maybe (LDerivStrategy p) -> SDoc
ppDerivStrategy mb =
case mb of
Nothing -> empty
@@ -1782,7 +1794,7 @@ data DerivDecl pass = DerivDecl
-- See Note [Inferring the instance context] in TcDerivInfer.
- , deriv_strategy :: Maybe (Located DerivStrategy)
+ , deriv_strategy :: Maybe (LDerivStrategy pass)
, deriv_overlap_mode :: Maybe (Located OverlapMode)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
-- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',
@@ -1811,6 +1823,50 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
{-
************************************************************************
* *
+ Deriving strategies
+* *
+************************************************************************
+-}
+
+-- | A 'Located' 'DerivStrategy'.
+type LDerivStrategy pass = Located (DerivStrategy pass)
+
+-- | Which technique the user explicitly requested when deriving an instance.
+data DerivStrategy pass
+ -- See Note [Deriving strategies] in TcDeriv
+ = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a
+ -- custom instance for the data type. This only works
+ -- for certain types that GHC knows about (e.g., 'Eq',
+ -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled,
+ -- etc.)
+ | AnyclassStrategy -- ^ @-XDeriveAnyClass@
+ | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@
+ | ViaStrategy (XViaStrategy pass)
+ -- ^ @-XDerivingVia@
+
+type instance XViaStrategy GhcPs = LHsSigType GhcPs
+type instance XViaStrategy GhcRn = LHsSigType GhcRn
+type instance XViaStrategy GhcTc = Type
+
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (DerivStrategy p) where
+ ppr StockStrategy = text "stock"
+ ppr AnyclassStrategy = text "anyclass"
+ ppr NewtypeStrategy = text "newtype"
+ ppr (ViaStrategy ty) = text "via" <+> ppr ty
+
+-- | A short description of a @DerivStrategy'@.
+derivStrategyName :: DerivStrategy a -> SDoc
+derivStrategyName = text . go
+ where
+ go StockStrategy = "stock"
+ go AnyclassStrategy = "anyclass"
+ go NewtypeStrategy = "newtype"
+ go (ViaStrategy {}) = "via"
+
+{-
+************************************************************************
+* *
\subsection[DefaultDecl]{A @default@ declaration}
* *
************************************************************************
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index 4898e36e3b..eb56d3b24e 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -385,6 +385,10 @@ type ForallXDerivDecl (c :: * -> Constraint) (x :: *) =
)
-- -------------------------------------
+-- DerivStrategy type family
+type family XViaStrategy x
+
+-- -------------------------------------
-- DefaultDecl type families
type family XCDefaultDecl x
type family XXDefaultDecl x
@@ -1100,6 +1104,10 @@ type OutputableX p = -- See Note [OutputableX]
, Outputable (XAppTypeE p)
, Outputable (XAppTypeE GhcRn)
+
+ , Outputable (XViaStrategy p)
+ , Outputable (XViaStrategy GhcRn)
+
)
-- TODO: Should OutputableX be included in OutputableBndrId?
diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs
index be72ec7939..70336d87e5 100644
--- a/compiler/hsSyn/HsInstances.hs
+++ b/compiler/hsSyn/HsInstances.hs
@@ -184,6 +184,11 @@ deriving instance Data (DerivDecl GhcPs)
deriving instance Data (DerivDecl GhcRn)
deriving instance Data (DerivDecl GhcTc)
+-- deriving instance (DataIdLR p p) => Data (DerivStrategy p)
+deriving instance Data (DerivStrategy GhcPs)
+deriving instance Data (DerivStrategy GhcRn)
+deriving instance Data (DerivStrategy GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (DefaultDecl p)
deriving instance Data (DefaultDecl GhcPs)
deriving instance Data (DefaultDecl GhcRn)
View Lorry Controller Status