Commit 9e862765 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Implement deriving strategies

Allows users to explicitly request which approach to `deriving` to use
via keywords, e.g.,

```
newtype Foo = Foo Bar
  deriving Eq
  deriving stock    Ord
  deriving newtype Show
```

Fixes #10598. Updates haddock submodule.

Test Plan: ./validate

Reviewers: hvr, kosmikus, goldfire, alanz, bgamari, simonpj, austin,
erikd, simonmar

Reviewed By: alanz, bgamari, simonpj

Subscribers: thomie, mpickering, oerjan

Differential Revision: https://phabricator.haskell.org/D2280

GHC Trac Issues: #10598
parent b3d55e20
......@@ -41,6 +41,8 @@ module BasicTypes(
TopLevelFlag(..), isTopLevel, isNotTopLevel,
DerivStrategy(..),
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
......@@ -476,6 +478,30 @@ 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
= DerivStock -- ^ 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.)
| DerivAnyclass -- ^ @-XDeriveAnyClass@
| DerivNewtype -- ^ @-XGeneralizedNewtypeDeriving@
deriving (Eq, Data)
instance Outputable DerivStrategy where
ppr DerivStock = text "stock"
ppr DerivAnyclass = text "anyclass"
ppr DerivNewtype = text "newtype"
{-
************************************************************************
* *
......
......@@ -455,11 +455,13 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
, deriv_type = ty }))
= do { dec <- addSimpleTyVarBinds tvs $
do { cxt' <- repLContext cxt
; strat' <- repDerivStrategy strat
; inst_ty' <- repLTy inst_ty
; repDeriv cxt' inst_ty' }
; repDeriv strat' cxt' inst_ty' }
; return (loc, dec) }
where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
......@@ -668,22 +670,22 @@ repBangTy ty = do
_ -> (NoSrcUnpack, NoSrcStrict, ty)
-------------------------------------------------------
-- Deriving clause
-- Deriving clauses
-------------------------------------------------------
repDerivs :: HsDeriving Name -> DsM (Core TH.CxtQ)
repDerivs deriv = do
let clauses = case deriv of
Nothing -> []
Just (L _ ctxt) -> ctxt
tys <- repList typeQTyConName
(rep_deriv . hsSigType)
clauses
:: DsM (Core [TH.PredQ])
repCtxt tys
repDerivs :: HsDeriving Name -> DsM (Core [TH.DerivClauseQ])
repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses
repDerivClause :: LHsDerivingClause Name
-> DsM (Core TH.DerivClauseQ)
repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct }))
= do MkC dcs' <- repDerivStrategy dcs
MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
rep2 derivClauseName [dcs',dct']
where
rep_deriv :: LHsType Name -> DsM (Core TH.TypeQ)
rep_deriv (L _ ty) = repTy ty
rep_deriv_ty :: LHsType Name -> DsM (Core TH.TypeQ)
rep_deriv_ty (L _ ty) = repTy ty
-------------------------------------------------------
-- Signatures in a class decl, or a group of bindings
......@@ -1982,7 +1984,7 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
-> Core [TH.ConQ] -> Core TH.CxtQ -> DsM (Core TH.DecQ)
-> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
= rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
......@@ -1991,7 +1993,7 @@ repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
-> Core TH.ConQ -> Core TH.CxtQ -> DsM (Core TH.DecQ)
-> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
(MkC derivs)
= rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
......@@ -2009,6 +2011,20 @@ 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 mds =
case mds of
Nothing -> nothing
Just (L _ ds) ->
case ds of
DerivStock -> just =<< dataCon stockDataConName
DerivAnyclass -> just =<< dataCon anyclassDataConName
DerivNewtype -> just =<< dataCon newtypeDataConName
where
nothing = coreNothing derivStrategyTyConName
just = coreJust derivStrategyTyConName
repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
repOverlap mb =
case mb of
......@@ -2031,8 +2047,11 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
= rep2 classDName [cxt, cls, tvs, fds, ds]
repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ)
repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty]
repDeriv :: Core (Maybe TH.DerivStrategy)
-> Core TH.CxtQ -> Core TH.TypeQ
-> DsM (Core TH.DecQ)
repDeriv (MkC ds) (MkC cxt) (MkC ty)
= rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
-> Core TH.Phases -> DsM (Core TH.DecQ)
......
......@@ -339,12 +339,14 @@ cvtDec (TH.RoleAnnotD tc roles)
; let roles' = map (noLoc . cvtRole) roles
; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
cvtDec (TH.StandaloneDerivD cxt ty)
cvtDec (TH.StandaloneDerivD ds cxt ty)
= do { cxt' <- cvtContext cxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
; returnJustL $ DerivD $
DerivDecl { deriv_type = mkLHsSigType inst_ty', deriv_overlap_mode = Nothing } }
DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
, deriv_type = mkLHsSigType inst_ty'
, deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
......@@ -560,12 +562,9 @@ cvt_id_arg (i, str, ty)
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
cvtDerivs :: TH.Cxt -> CvtM (HsDeriving RdrName)
cvtDerivs [] = return Nothing
cvtDerivs cs = fmap (Just . mkSigTypes) (cvtContext cs)
where
mkSigTypes :: Located (HsContext RdrName) -> Located [LHsSigType RdrName]
mkSigTypes = fmap (map mkLHsSigType)
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving RdrName)
cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
; returnL cs' }
cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
......@@ -1127,6 +1126,18 @@ cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
cvtPred = cvtType
cvtDerivClause :: TH.DerivClause
-> CvtM (LHsDerivingClause RdrName)
cvtDerivClause (TH.DerivClause ds ctxt)
= do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt
; let ds' = fmap (L loc . cvtDerivStrategy) ds
; returnL $ HsDerivingClause ds' ctxt' }
cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy
cvtDerivStrategy TH.Stock = Hs.DerivStock
cvtDerivStrategy TH.Anyclass = Hs.DerivAnyclass
cvtDerivStrategy TH.Newtype = Hs.DerivNewtype
cvtType :: TH.Type -> CvtM (LHsType RdrName)
cvtType = cvtTypeKind "type"
......
......@@ -19,6 +19,7 @@
module HsDecls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
HsDerivingClause(..), LHsDerivingClause,
-- ** Class or type declarations
TyClDecl(..), LTyClDecl,
......@@ -1027,23 +1028,47 @@ data HsDataDefn name -- The payload of a data type defn
deriving instance (DataId id) => Data (HsDataDefn id)
-- | Haskell Deriving clause
type HsDeriving name = Maybe (Located [LHsSigType name])
-- ^ The optional 'deriving' clause of a data declaration
type HsDeriving name = Located [LHsDerivingClause name]
-- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is
-- plural because one can specify multiple deriving clauses using the
-- @-XDerivingStrategies@ language extension.
--
-- @Nothing@ => not specified,
-- @Just []@ => derive exactly what is asked
--
-- It's a 'LHsSigType' because, with Generalised Newtype
-- Deriving, we can mention type variables that aren't
-- bound by the date type. e.g.
-- data T b = ... deriving( C [a] )
-- should producd a derived instance for (C [a] (T b))
--
-- The payload of the Maybe is Located so that we have a
-- place to hang the API annotations:
-- - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnDeriving',
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- The list of 'LHsDerivingClause's corresponds to exactly what the user
-- requested to derive, in order. If no deriving clauses were specified,
-- the list is empty.
type LHsDerivingClause name = Located (HsDerivingClause name)
-- | A single @deriving@ clause of a data declaration.
--
-- - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock',
-- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
data HsDerivingClause name
-- See Note [Deriving strategies] in TcDeriv
= HsDerivingClause
{ deriv_clause_strategy :: Maybe (Located DerivStrategy)
-- ^ The user-specified strategy (if any) to use when deriving
-- 'deriv_clause_tys'.
, deriv_clause_tys :: Located [LHsSigType name]
-- ^ The types to derive.
--
-- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,
-- we can mention type variables that aren't bound by the datatype, e.g.
--
-- > data T b = ... deriving (C [a])
--
-- should produce a derived instance for @C [a] (T b)@.
}
deriving instance (DataId id) => Data (HsDerivingClause id)
instance (OutputableBndrId name) => Outputable (HsDerivingClause name) where
ppr (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct })
= hsep [ text "deriving"
, ppDerivStrategy dcs
, parens (interpp'SP dct) ]
data NewOrData
= NewType -- ^ @newtype Blah ...@
......@@ -1159,15 +1184,12 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
| otherwise
= hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
2 (pp_condecls condecls $$ pp_derivings)
2 (pp_condecls condecls $$ pp_derivings derivings)
where
pp_sig = case mb_sig of
Nothing -> empty
Just kind -> dcolon <+> ppr kind
pp_derivings = case derivings of
Nothing -> empty
Just (L _ ds) -> hsep [ text "deriving"
, parens (interpp'SP ds)]
pp_derivings (L _ ds) = vcat (map ppr ds)
instance (OutputableBndrId name) => Outputable (HsDataDefn name) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
......@@ -1455,6 +1477,12 @@ instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where
top_matter = text "instance" <+> ppOverlapPragma mbOverlap
<+> ppr inst_ty
ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc
ppDerivStrategy mb =
case mb of
Nothing -> empty
Just (L _ ds) -> ppr ds
ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
ppOverlapPragma mb =
case mb of
......@@ -1496,19 +1524,26 @@ type LDerivDecl name = Located (DerivDecl name)
-- | Deriving Declaration
data DerivDecl name = DerivDecl
{ deriv_type :: LHsSigType name
, deriv_strategy :: Maybe (Located DerivStrategy)
, deriv_overlap_mode :: Maybe (Located OverlapMode)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-- 'ApiAnnotation.AnnClose',
-- 'ApiAnnotation.AnnDeriving',
-- 'ApiAnnotation.AnnInstance'
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
-- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',
-- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
}
deriving instance (DataId name) => Data (DerivDecl name)
instance (OutputableBndrId name) => Outputable (DerivDecl name) where
ppr (DerivDecl ty o)
= hsep [text "deriving instance", ppOverlapPragma o, ppr ty]
ppr (DerivDecl { deriv_type = ty
, deriv_strategy = ds
, deriv_overlap_mode = o })
= hsep [ text "deriving"
, ppDerivStrategy ds
, text "instance"
, ppOverlapPragma o
, ppr ty ]
{-
************************************************************************
......
......@@ -3561,6 +3561,7 @@ xFlagsDeps = [
flagSpec "DeriveGeneric" LangExt.DeriveGeneric,
flagSpec "DeriveLift" LangExt.DeriveLift,
flagSpec "DeriveTraversable" LangExt.DeriveTraversable,
flagSpec "DerivingStrategies" LangExt.DerivingStrategies,
flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields,
flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse,
depFlagSpec' "DoRec" LangExt.RecursiveDo
......
......@@ -16,6 +16,7 @@ import SrcLoc
import Util
import Data.Char
import Data.Foldable (foldl')
-- | Source Statistics
ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc
......@@ -128,9 +129,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
spec_info (Just (True, _)) = (0,0,0,0,0,0,1)
data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs
, dd_derivs = derivs}})
= (length cs, case derivs of Nothing -> 0
Just (L _ ds) -> length ds)
, dd_derivs = L _ derivs}})
= ( length cs
, foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
0 derivs )
data_info _ = (0,0)
class_info decl@(ClassDecl {})
......
......@@ -186,7 +186,8 @@ getAndRemoveAnnotationComments (anns,canns) span =
-- corresponding token, unless otherwise noted
-- See note [Api annotations] above for details of the usage
data AnnKeywordId
= AnnAs
= AnnAnyclass
| AnnAs
| AnnAt
| AnnBang -- ^ '!'
| AnnBackquote -- ^ '`'
......@@ -256,6 +257,7 @@ data AnnKeywordId
| AnnSemi -- ^ ';'
| AnnSimpleQuote -- ^ '''
| AnnStatic -- ^ 'static'
| AnnStock
| AnnThen
| AnnThIdSplice -- ^ '$'
| AnnThIdTySplice -- ^ '$$'
......
......@@ -612,6 +612,8 @@ data Token
| ITusing
| ITpattern
| ITstatic
| ITstock
| ITanyclass
-- Pragmas, see note [Pragma source text] in BasicTypes
| ITinline_prag SourceText InlineSpec RuleMatchInfo
......@@ -803,6 +805,8 @@ reservedWordsFM = listToUFM $
( "role", ITrole, 0 ),
( "pattern", ITpattern, xbit PatternSynonymsBit),
( "static", ITstatic, 0 ),
( "stock", ITstock, 0 ),
( "anyclass", ITanyclass, 0 ),
( "group", ITgroup, xbit TransformComprehensionsBit),
( "by", ITby, xbit TransformComprehensionsBit),
( "using", ITusing, xbit TransformComprehensionsBit),
......
......@@ -88,7 +88,7 @@ import qualified GHC.LanguageExtensions as LangExt
%expect 36 -- shift/reduce conflicts
{- Last updated: 9 Jan 2016
{- Last updated: 3 Aug 2016
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:
......@@ -119,7 +119,7 @@ follows. Shift parses as if the 'module' keyword follows.
-------------------------------------------------------------------------------
state 46 contains 2 shift/reduce conflicts.
state 48 contains 2 shift/reduce conflicts.
*** strict_mark -> unpackedness .
strict_mark -> unpackedness . strictness
......@@ -128,7 +128,7 @@ state 46 contains 2 shift/reduce conflicts.
-------------------------------------------------------------------------------
state 50 contains 1 shift/reduce conflict.
state 52 contains 1 shift/reduce conflict.
context -> btype .
*** type -> btype .
......@@ -138,7 +138,7 @@ state 50 contains 1 shift/reduce conflict.
-------------------------------------------------------------------------------
state 51 contains 9 shift/reduce conflicts.
state 53 contains 9 shift/reduce conflicts.
*** btype -> tyapps .
tyapps -> tyapps . tyapp
......@@ -147,7 +147,7 @@ state 51 contains 9 shift/reduce conflicts.
-------------------------------------------------------------------------------
state 132 contains 14 shift/reduce conflicts.
state 134 contains 14 shift/reduce conflicts.
exp -> infixexp . '::' sigtype
exp -> infixexp . '-<' exp
......@@ -172,7 +172,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
state 295 contains 1 shift/reduce conflicts.
state 299 contains 1 shift/reduce conflicts.
rule -> STRING . rule_activation rule_forall infixexp '=' exp
......@@ -190,7 +190,7 @@ a rule instructing how to rewrite the expression '[0] f'.
-------------------------------------------------------------------------------
state 304 contains 1 shift/reduce conflict.
state 309 contains 1 shift/reduce conflict.
*** type -> btype .
type -> btype . '->' ctype
......@@ -201,7 +201,7 @@ Same as state 50 but without contexts.
-------------------------------------------------------------------------------
state 340 contains 1 shift/reduce conflicts.
state 348 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(' commas . ')'
......@@ -216,7 +216,7 @@ if -XTupleSections is not specified.
-------------------------------------------------------------------------------
state 391 contains 1 shift/reduce conflicts.
state 402 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(#' commas . '#)'
......@@ -228,7 +228,7 @@ Same as State 324 for unboxed tuples.
-------------------------------------------------------------------------------
state 465 contains 1 shift/reduce conflict.
state 477 contains 1 shift/reduce conflict.
oqtycon -> '(' qtyconsym . ')'
*** qtyconop -> qtyconsym .
......@@ -239,7 +239,7 @@ TODO: Why?
-------------------------------------------------------------------------------
state 639 contains 1 shift/reduce conflicts.
state 658 contains 1 shift/reduce conflicts.
*** aexp2 -> ipvar .
dbind -> ipvar . '=' exp
......@@ -254,7 +254,7 @@ sensible meaning, namely the lhs of an implicit binding.
-------------------------------------------------------------------------------
state 707 contains 1 shift/reduce conflicts.
state 731 contains 1 shift/reduce conflicts.
rule -> STRING rule_activation . rule_forall infixexp '=' exp
......@@ -271,7 +271,7 @@ doesn't include 'forall'.
-------------------------------------------------------------------------------
state 933 contains 1 shift/reduce conflicts.
state 963 contains 1 shift/reduce conflicts.
transformqual -> 'then' 'group' . 'using' exp
transformqual -> 'then' 'group' . 'by' exp 'using' exp
......@@ -281,7 +281,7 @@ state 933 contains 1 shift/reduce conflicts.
-------------------------------------------------------------------------------
state 1269 contains 1 shift/reduce conflict.
state 1303 contains 1 shift/reduce conflict.
*** atype -> tyvar .
tv_bndr -> '(' tyvar . '::' kind ')'
......@@ -368,6 +368,8 @@ output it generates.
'using' { L _ ITusing } -- for list transform extension
'pattern' { L _ ITpattern } -- for pattern synonyms
'static' { L _ ITstatic } -- for static pointers extension
'stock' { L _ ITstock } -- for DerivingStrategies extension
'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension
'{-# INLINE' { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE
'{-# SPECIALISE' { L _ (ITspec_prag _) }
......@@ -870,10 +872,10 @@ ty_decl :: { LTyClDecl RdrName }
++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) }
-- ordinary data type or newtype declaration
| data_or_newtype capi_ctype tycl_hdr constrs deriving
| data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings
{% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
Nothing (reverse (snd $ unLoc $4))
(unLoc $5))
(fmap reverse $5))
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
((fst $ unLoc $1):(fst $ unLoc $4)) }
......@@ -881,9 +883,10 @@ ty_decl :: { LTyClDecl RdrName }
-- ordinary GADT declaration
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
maybe_derivings
{% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3
(snd $ unLoc $4) (snd $ unLoc $5) (unLoc $6) )
(snd $ unLoc $4) (snd $ unLoc $5)
(fmap reverse $6) )
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
......@@ -912,18 +915,20 @@ inst_decl :: { LInstDecl RdrName }
(mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
-- data/newtype instance declaration
| data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving
| data_or_newtype 'instance' capi_ctype tycl_hdr constrs
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
Nothing (reverse (snd $ unLoc $5))
(unLoc $6))
(fmap reverse $6))
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
-- GADT instance declaration
| data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
(snd $ unLoc $5) (snd $ unLoc $6) (unLoc $7))
(snd $ unLoc $5) (snd $ unLoc $6)
(fmap reverse $7))
((fst $ unLoc $1):mj AnnInstance $2
:(fst $ unLoc $5)++(fst $ unLoc $6)) }
......@@ -938,6 +943,14 @@ overlap_pragma :: { Maybe (Located OverlapMode) }
[mo $1,mc $2] }
| {- empty -} { Nothing }
deriv_strategy :: { Maybe (Located DerivStrategy) }
: 'stock' {% ajs (Just (sL1 $1 DerivStock))
[mj AnnStock $1] }
| 'anyclass' {% ajs (Just (sL1 $1 DerivAnyclass))
[mj AnnAnyclass $1] }
| 'newtype' {% ajs (Just (sL1 $1 DerivNewtype))
[mj AnnNewtype $1] }
| {- empty -} { Nothing }
-- Injective type families
......@@ -1048,18 +1061,19 @@ at_decl_inst :: { LInstDecl RdrName }
(mj AnnType $1:(fst $ unLoc $2)) }
-- data/newtype instance declaration