Commit 8ed8b037 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent 85309a3c
......@@ -45,8 +45,6 @@ module BasicTypes(
TopLevelFlag(..), isTopLevel, isNotTopLevel,
DerivStrategy(..),
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
......@@ -542,31 +540,6 @@ instance Outputable Origin where
ppr FromSource = text "FromSource"
ppr Generated = text "Generated"
{-
************************************************************************
* *
Deriving strategies
* *
************************************************************************
-}
-- | Which technique the user explicitly requested when deriving an instance.
data DerivStrategy
-- 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@
deriving (Eq, Data)
instance Outputable DerivStrategy where
ppr StockStrategy = text "stock"
ppr AnyclassStrategy = text "anyclass"
ppr NewtypeStrategy = text "newtype"
{-
************************************************************************
* *
......
......@@ -2131,19 +2131,34 @@ repInst :: Core (Maybe TH.Overlap) ->
repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
[o, cxt, ty, ds]
repDerivStrategy :: Maybe (Located DerivStrategy)
-> DsM (Core (Maybe TH.DerivStrategy))
repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
-> DsM (Core (Maybe TH.DerivStrategyQ))
repDerivStrategy mds =
case mds of
Nothing -> nothing
Just (L _ ds) ->
case ds of
StockStrategy -> just =<< dataCon stockStrategyDataConName
AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName
NewtypeStrategy -> just =<< dataCon newtypeStrategyDataConName
StockStrategy -> just =<< repStockStrategy
AnyclassStrategy -> just =<< repAnyclassStrategy
NewtypeStrategy -> just =<< repNewtypeStrategy
ViaStrategy ty -> do ty' <- repLTy (hsSigType ty)
via_strat <- repViaStrategy ty'
just via_strat
where
nothing = coreNothing derivStrategyTyConName
just = coreJust derivStrategyTyConName
nothing = coreNothing derivStrategyQTyConName
just = coreJust derivStrategyQTyConName
repStockStrategy :: DsM (Core TH.DerivStrategyQ)
repStockStrategy = rep2 stockStrategyName []
repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)
repAnyclassStrategy = rep2 anyclassStrategyName []
repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)
repNewtypeStrategy = rep2 newtypeStrategyName []
repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)
repViaStrategy (MkC t) = rep2 viaStrategyName [t]
repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
repOverlap mb =
......@@ -2167,7 +2182,7 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
= rep2 classDName [cxt, cls, tvs, fds, ds]
repDeriv :: Core (Maybe TH.DerivStrategy)
repDeriv :: Core (Maybe TH.DerivStrategyQ)
-> Core TH.CxtQ -> Core TH.TypeQ
-> DsM (Core TH.DecQ)
repDeriv (MkC ds) (MkC cxt) (MkC ty)
......
......@@ -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"
......
......@@ -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',
......@@ -1808,6 +1820,50 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
, ppr ty ]
ppr (XDerivDecl x) = ppr x
{-
************************************************************************
* *
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"
{-
************************************************************************
* *
......
......@@ -384,6 +384,10 @@ type ForallXDerivDecl (c :: * -> Constraint) (x :: *) =
, c (XXDerivDecl x)
)
-- -------------------------------------
-- DerivStrategy type family
type family XViaStrategy x
-- -------------------------------------
-- DefaultDecl type families
type family XCDefaultDecl 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?
......
......@@ -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)
......
......@@ -4113,6 +4113,7 @@ xFlagsDeps = [
flagSpec "DeriveLift" LangExt.DeriveLift,
flagSpec "DeriveTraversable" LangExt.DeriveTraversable,
flagSpec "DerivingStrategies" LangExt.DerivingStrategies,
flagSpec "DerivingVia" LangExt.DerivingVia,
flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields,
flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse,
flagSpec "BlockArguments" LangExt.BlockArguments,
......@@ -4321,6 +4322,8 @@ impliedXFlags
, (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off!
, (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)
, (LangExt.GADTs, turnOn, LangExt.GADTSyntax)
, (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds)
, (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds)
......
......@@ -286,6 +286,7 @@ data AnnKeywordId
| AnnVal -- ^ e.g. INTEGER
| AnnValStr -- ^ String value, will need quotes when output
| AnnVbar -- ^ '|'
| AnnVia -- ^ 'via'
| AnnWhere
| Annlarrowtail -- ^ '-<'
| AnnlarrowtailU -- ^ '-<', unicode variant
......
......@@ -632,6 +632,7 @@ data Token
| ITstatic
| ITstock
| ITanyclass
| ITvia
-- Backpack tokens
| ITunit
......@@ -829,6 +830,7 @@ reservedWordsFM = listToUFM $
( "static", ITstatic, 0 ),
( "stock", ITstock, 0 ),
( "anyclass", ITanyclass, 0 ),
( "via", ITvia, 0 ),
( "group", ITgroup, xbit TransformComprehensionsBit),
( "by", ITby, xbit TransformComprehensionsBit),
( "using", ITusing, xbit TransformComprehensionsBit),
......
......@@ -88,9 +88,9 @@ import GhcPrelude
import qualified GHC.LanguageExtensions as LangExt
}
%expect 229 -- shift/reduce conflicts
%expect 233 -- shift/reduce conflicts
{- Last updated: 14 Apr 2018
{- Last updated: 04 June 2018
If you modify this parser and add a conflict, please update this comment.
You can learn more about the conflicts by passing 'happy' the -i flag:
......@@ -121,7 +121,7 @@ follows. Shift parses as if the 'module' keyword follows.
-------------------------------------------------------------------------------
state 56 contains 2 shift/reduce conflicts.
state 57 contains 2 shift/reduce conflicts.
*** strict_mark -> unpackedness .
strict_mark -> unpackedness . strictness
......@@ -130,7 +130,7 @@ state 56 contains 2 shift/reduce conflicts.
-------------------------------------------------------------------------------
state 60 contains 1 shift/reduce conflict.
state 61 contains 1 shift/reduce conflict.
context -> btype .
*** type -> btype .
......@@ -140,7 +140,7 @@ state 60 contains 1 shift/reduce conflict.
-------------------------------------------------------------------------------
state 61 contains 45 shift/reduce conflicts.
state 62 contains 46 shift/reduce conflicts.
*** btype -> tyapps .
tyapps -> tyapps . tyapp
......@@ -158,7 +158,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
state 142 contains 14 shift/reduce conflicts.
state 143 contains 14 shift/reduce conflicts.
exp -> infixexp . '::' sigtype
exp -> infixexp . '-<' exp
......@@ -183,7 +183,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
state 147 contains 67 shift/reduce conflicts.
state 148 contains 68 shift/reduce conflicts.
*** exp10 -> fexp .
fexp -> fexp . aexp
......@@ -201,7 +201,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
state 203 contains 27 shift/reduce conflicts.
state 204 contains 28 shift/reduce conflicts.
aexp2 -> TH_TY_QUOTE . tyvar
aexp2 -> TH_TY_QUOTE . gtycon
......@@ -220,7 +220,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
state 307 contains 1 shift/reduce conflicts.
state 308 contains 1 shift/reduce conflicts.
rule -> STRING . rule_activation rule_forall infixexp '=' exp
......@@ -238,18 +238,18 @@ a rule instructing how to rewrite the expression '[0] f'.
-------------------------------------------------------------------------------
state 317 contains 1 shift/reduce conflict.
state 318 contains 1 shift/reduce conflict.
*** type -> btype .
type -> btype . '->' ctype
Conflict: '->'
Same as state 60 but without contexts.
Same as state 61 but without contexts.
-------------------------------------------------------------------------------
state 359 contains 1 shift/reduce conflicts.
state 362 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(' commas . ')'
......@@ -264,7 +264,7 @@ if -XTupleSections is not specified.
-------------------------------------------------------------------------------
state 415 contains 1 shift/reduce conflicts.
state 418 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(#' commas . '#)'
......@@ -272,21 +272,21 @@ state 415 contains 1 shift/reduce conflicts.
Conflict: '#)' (empty tup_tail reduces)
Same as State 357 for unboxed tuples.
Same as State 362 for unboxed tuples.
-------------------------------------------------------------------------------
state 426 contains 67 shift/reduce conflicts.
state 429 contains 68 shift/reduce conflicts.
*** exp10 -> '-' fexp .
fexp -> fexp . aexp
fexp -> fexp . TYPEAPP atype
Same as 147 but with a unary minus.
Same as 148 but with a unary minus.
-------------------------------------------------------------------------------
state 490 contains 1 shift/reduce conflict.
state 493 contains 1 shift/reduce conflict.
oqtycon -> '(' qtyconsym . ')'
*** qtyconop -> qtyconsym .
......@@ -300,7 +300,7 @@ parenthesized infix type expression of length 1.
-------------------------------------------------------------------------------
state 691 contains 1 shift/reduce conflicts.
state 694 contains 1 shift/reduce conflicts.
*** aexp2 -> ipvar .
dbind -> ipvar . '=' exp
......@@ -315,7 +315,7 @@ sensible meaning, namely the lhs of an implicit binding.
-------------------------------------------------------------------------------
state 767 contains 1 shift/reduce conflicts.
state 771 contains 1 shift/reduce conflicts.
rule -> STRING rule_activation . rule_forall infixexp '=' exp
......@@ -332,7 +332,7 @@ doesn't include 'forall'.
-------------------------------------------------------------------------------
state 1015 contains 1 shift/reduce conflicts.
state 1019 contains 1 shift/reduce conflicts.
transformqual -> 'then' 'group' . 'using' exp
transformqual -> 'then' 'group' . 'by' exp 'using' exp
......@@ -342,7 +342,7 @@ state 1015 contains 1 shift/reduce conflicts.
-------------------------------------------------------------------------------
state 1393 contains 1 shift/reduce conflict.
state 1404 contains 1 shift/reduce conflict.
*** atype -> tyvar .
tv_bndr -> '(' tyvar . '::' kind ')'
......@@ -484,6 +484,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
'static' { L _ ITstatic } -- for static pointers extension
'stock' { L _ ITstock } -- for DerivingStrategies extension
'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension
'via' { L _ ITvia } -- for DerivingStrategies extension
'unit' { L _ ITunit }
'signature' { L _ ITsignature }
......@@ -1150,13 +1151,30 @@ overlap_pragma :: { Maybe (Located OverlapMode) }
[mo $1,mc $2] }
| {- empty -} { Nothing }
deriv_strategy :: { Maybe (Located DerivStrategy) }
deriv_strategy_no_via :: { LDerivStrategy GhcPs }
: 'stock' {% ams (sL1 $1 StockStrategy)
[mj AnnStock $1] }
| 'anyclass' {% ams (sL1 $1 AnyclassStrategy)
[mj AnnAnyclass $1] }
| 'newtype' {% ams (sL1 $1 NewtypeStrategy)
[mj AnnNewtype $1] }
deriv_strategy_via :: { LDerivStrategy GhcPs }
: 'via' tyapp {% splitTildeApps [$2] >>= \tys -> let
ty :: LHsType GhcPs
ty = sL1 $1 $ mkHsAppsTy tys
in ams (sLL $1 $> (ViaStrategy (mkLHsSigType ty)))
[mj AnnVia $1] }
deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
: 'stock' {% ajs (Just (sL1 $1 StockStrategy))
[mj AnnStock $1] }
| 'anyclass' {% ajs (Just (sL1 $1 AnyclassStrategy))
[mj AnnAnyclass $1] }
| 'newtype' {% ajs (Just (sL1 $1 NewtypeStrategy))
[mj AnnNewtype $1] }
| deriv_strategy_via { Just $1 }
| {- empty -} { Nothing }
-- Injective type families
......@@ -1363,7 +1381,7 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl GhcPs }
: 'deriving' deriv_strategy 'instance' overlap_pragma inst_type
: 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type
{% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $5) }
; ams (sLL $1 (hsSigType $>)
......@@ -2204,21 +2222,27 @@ derivings :: { HsDeriving GhcPs }
-- The outer Located is just to allow the caller to
-- know the rightmost extremity of the 'deriving' clause
deriving :: { LHsDerivingClause GhcPs }
: 'deriving' deriv_strategy qtycondoc
: 'deriving' deriv_clause_types
{% let { full_loc = comb2 $1 $> }
in ams (L full_loc $ HsDerivingClause noExt $2 $ L full_loc
[mkLHsSigType $3])
in ams (L full_loc $ HsDerivingClause noExt Nothing $2)
[mj AnnDeriving $1] }
| 'deriving' deriv_strategy '(' ')'
| 'deriving' deriv_strategy_no_via deriv_clause_types
{% let { full_loc = comb2 $1 $> }
in ams (L full_loc $ HsDerivingClause noExt $2 $ L full_loc [])
[mj AnnDeriving $1,mop $3,mcp $4] }
in ams (L full_loc $ HsDerivingClause noExt (Just $2) $3)
[mj AnnDeriving $1] }
| 'deriving' deriv_strategy '(' deriv_types ')'
| 'deriving' deriv_clause_types deriv_strategy_via
{% let { full_loc = comb2 $1 $> }
in ams (L full_loc $ HsDerivingClause noExt $2 $ L full_loc $4)
[mj AnnDeriving $1,mop $3,mcp $5] }
in ams (L full_loc $ HsDerivingClause noExt (Just $3) $2)
[mj AnnDeriving $1] }
deriv_clause_types :: { Located [LHsSigType GhcPs] }
: qtycondoc { sL1 $1 [mkLHsSigType $1] }
| '(' ')' {% ams (sLL $1 $> [])
[mop $1,mcp $2] }
| '(' deriv_types ')' {% ams (sLL $1 $> $2)
[mop $1,mcp $3] }
-- Glasgow extension: allow partial
-- applications in derivings
......@@ -3329,6 +3353,7 @@ special_id
| 'group' { sL1 $1 (fsLit "group") }
| 'stock' { sL1 $1 (fsLit "stock") }
| 'anyclass' { sL1 $1 (fsLit "anyclass") }
| 'via' { sL1 $1 (fsLit "via") }
| 'unit' { sL1 $1 (fsLit "unit") }
| 'dependency' { sL1 $1 (fsLit "dependency") }
| 'signature' { sL1 $1 (fsLit "signature") }
......
......@@ -129,8 +129,8 @@ templateHaskellNames = [
overlappableDataConName, overlappingDataConName, overlapsDataConName,
incoherentDataConName,
-- DerivStrategy
stockStrategyDataConName, anyclassStrategyDataConName,
newtypeStrategyDataConName,
stockStrategyName, anyclassStrategyName,
newtypeStrategyName, viaStrategyName,
-- TExp
tExpDataConName,
-- RuleBndr
......@@ -156,7 +156,7 @@ templateHaskellNames = [
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,
overlapTyConName, derivClauseQTyConName, derivStrategyTyConName,
overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
......@@ -185,8 +185,7 @@ liftClassName = thCls (fsLit "Lift") liftClassKey
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
tExpTyConName, injAnnTyConName, overlapTyConName,
derivStrategyTyConName :: Name
tExpTyConName, injAnnTyConName, overlapTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
......@@ -202,7 +201,6 @@ predTyConName = thTc (fsLit "Pred") predTyConKey
tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey