diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-06-04 21:20:02 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2018-06-04 22:37:19 -0400 |
commit | 8ed8b037fee9611b1c4ef49adb6cf50bbd929a27 (patch) | |
tree | ff3907f0412085a78e694597c1bdba700740403f /compiler/hsSyn | |
parent | 85309a3cda367425cca727dfa45e5e6c63b47391 (diff) | |
download | haskell-8ed8b037fee9611b1c4ef49adb6cf50bbd929a27.tar.gz |
Introduce DerivingVia
This implements the `DerivingVia` proposal put forth in
https://github.com/ghc-proposals/ghc-proposals/pull/120.
This introduces the `DerivingVia` deriving strategy. This is a
generalization of `GeneralizedNewtypeDeriving` that permits the user
to specify the type to `coerce` from.
The major change in this patch is the introduction of the
`ViaStrategy` constructor to `DerivStrategy`, which takes a type
as a field. As a result, `DerivStrategy` is no longer a simple
enumeration type, but rather something that must be renamed and
typechecked. The process by which this is done is explained more
thoroughly in section 3 of this paper
( https://www.kosmikus.org/DerivingVia/deriving-via-paper.pdf ),
although I have inlined the relevant parts into Notes where possible.
There are some knock-on changes as well. I took the opportunity to
do some refactoring of code in `TcDeriv`, especially the
`mkNewTypeEqn` function, since it was bundling all of the logic for
(1) deriving instances for newtypes and
(2) `GeneralizedNewtypeDeriving`
into one huge broth. `DerivingVia` reuses much of part (2), so that
was factored out as much as possible.
Bumps the Haddock submodule.
Test Plan: ./validate
Reviewers: simonpj, bgamari, goldfire, alanz
Subscribers: alanz, goldfire, rwbarton, thomie, mpickering, carter
GHC Trac Issues: #15178
Differential Revision: https://phabricator.haskell.org/D4684
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r-- | compiler/hsSyn/Convert.hs | 18 | ||||
-rw-r--r-- | compiler/hsSyn/HsDecls.hs | 66 | ||||
-rw-r--r-- | compiler/hsSyn/HsExtension.hs | 8 | ||||
-rw-r--r-- | compiler/hsSyn/HsInstances.hs | 5 |
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) |