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( ...@@ -41,6 +41,8 @@ module BasicTypes(
TopLevelFlag(..), isTopLevel, isNotTopLevel, TopLevelFlag(..), isTopLevel, isNotTopLevel,
DerivStrategy(..),
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
...@@ -476,6 +478,30 @@ instance Outputable Origin where ...@@ -476,6 +478,30 @@ instance Outputable Origin where
ppr FromSource = text "FromSource" ppr FromSource = text "FromSource"
ppr Generated = text "Generated" 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 ...@@ -455,11 +455,13 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) 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 { dec <- addSimpleTyVarBinds tvs $
do { cxt' <- repLContext cxt do { cxt' <- repLContext cxt
; strat' <- repDerivStrategy strat
; inst_ty' <- repLTy inst_ty ; inst_ty' <- repLTy inst_ty
; repDeriv cxt' inst_ty' } ; repDeriv strat' cxt' inst_ty' }
; return (loc, dec) } ; return (loc, dec) }
where where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
...@@ -668,22 +670,22 @@ repBangTy ty = do ...@@ -668,22 +670,22 @@ repBangTy ty = do
_ -> (NoSrcUnpack, NoSrcStrict, ty) _ -> (NoSrcUnpack, NoSrcStrict, ty)
------------------------------------------------------- -------------------------------------------------------
-- Deriving clause -- Deriving clauses
------------------------------------------------------- -------------------------------------------------------
repDerivs :: HsDeriving Name -> DsM (Core TH.CxtQ) repDerivs :: HsDeriving Name -> DsM (Core [TH.DerivClauseQ])
repDerivs deriv = do repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses
let clauses = case deriv of
Nothing -> [] repDerivClause :: LHsDerivingClause Name
Just (L _ ctxt) -> ctxt -> DsM (Core TH.DerivClauseQ)
tys <- repList typeQTyConName repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
(rep_deriv . hsSigType) , deriv_clause_tys = L _ dct }))
clauses = do MkC dcs' <- repDerivStrategy dcs
:: DsM (Core [TH.PredQ]) MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
repCtxt tys rep2 derivClauseName [dcs',dct']
where where
rep_deriv :: LHsType Name -> DsM (Core TH.TypeQ) rep_deriv_ty :: LHsType Name -> DsM (Core TH.TypeQ)
rep_deriv (L _ ty) = repTy ty rep_deriv_ty (L _ ty) = repTy ty
------------------------------------------------------- -------------------------------------------------------
-- Signatures in a class decl, or a group of bindings -- Signatures in a class decl, or a group of bindings
...@@ -1982,7 +1984,7 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] ...@@ -1982,7 +1984,7 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) -> 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) repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
= rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons) 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) ...@@ -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] repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) -> 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) repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
(MkC derivs) (MkC derivs)
= rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
...@@ -2009,6 +2011,20 @@ repInst :: Core (Maybe TH.Overlap) -> ...@@ -2009,6 +2011,20 @@ repInst :: Core (Maybe TH.Overlap) ->
repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
[o, cxt, ty, ds] [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 :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
repOverlap mb = repOverlap mb =
case mb of case mb of
...@@ -2031,8 +2047,11 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] ...@@ -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) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
= rep2 classDName [cxt, cls, tvs, fds, ds] = rep2 classDName [cxt, cls, tvs, fds, ds]
repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ) repDeriv :: Core (Maybe TH.DerivStrategy)
repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty] -> 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 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
-> Core TH.Phases -> DsM (Core TH.DecQ) -> Core TH.Phases -> DsM (Core TH.DecQ)
......
...@@ -339,12 +339,14 @@ cvtDec (TH.RoleAnnotD tc roles) ...@@ -339,12 +339,14 @@ cvtDec (TH.RoleAnnotD tc roles)
; let roles' = map (noLoc . cvtRole) roles ; let roles' = map (noLoc . cvtRole) roles
; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') } ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
cvtDec (TH.StandaloneDerivD cxt ty) cvtDec (TH.StandaloneDerivD ds cxt ty)
= do { cxt' <- cvtContext cxt = do { cxt' <- cvtContext cxt
; L loc ty' <- cvtType ty ; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' } ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
; returnJustL $ DerivD $ ; 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) cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
...@@ -560,12 +562,9 @@ cvt_id_arg (i, str, ty) ...@@ -560,12 +562,9 @@ cvt_id_arg (i, str, ty)
, cd_fld_type = ty' , cd_fld_type = ty'
, cd_fld_doc = Nothing}) } , cd_fld_doc = Nothing}) }
cvtDerivs :: TH.Cxt -> CvtM (HsDeriving RdrName) cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving RdrName)
cvtDerivs [] = return Nothing cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
cvtDerivs cs = fmap (Just . mkSigTypes) (cvtContext cs) ; returnL cs' }
where
mkSigTypes :: Located (HsContext RdrName) -> Located [LHsSigType RdrName]
mkSigTypes = fmap (map mkLHsSigType)
cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
...@@ -1127,6 +1126,18 @@ cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } ...@@ -1127,6 +1126,18 @@ cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
cvtPred :: TH.Pred -> CvtM (LHsType RdrName) cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
cvtPred = cvtType 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 :: TH.Type -> CvtM (LHsType RdrName)
cvtType = cvtTypeKind "type" cvtType = cvtTypeKind "type"
......
...@@ -19,6 +19,7 @@ ...@@ -19,6 +19,7 @@
module HsDecls ( module HsDecls (
-- * Toplevel declarations -- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
HsDerivingClause(..), LHsDerivingClause,
-- ** Class or type declarations -- ** Class or type declarations
TyClDecl(..), LTyClDecl, TyClDecl(..), LTyClDecl,
...@@ -1027,23 +1028,47 @@ data HsDataDefn name -- The payload of a data type defn ...@@ -1027,23 +1028,47 @@ data HsDataDefn name -- The payload of a data type defn
deriving instance (DataId id) => Data (HsDataDefn id) deriving instance (DataId id) => Data (HsDataDefn id)
-- | Haskell Deriving clause -- | Haskell Deriving clause
type HsDeriving name = Maybe (Located [LHsSigType name]) type HsDeriving name = Located [LHsDerivingClause name]
-- ^ The optional 'deriving' clause of a data declaration -- ^ 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, -- The list of 'LHsDerivingClause's corresponds to exactly what the user
-- @Just []@ => derive exactly what is asked -- requested to derive, in order. If no deriving clauses were specified,
-- -- the list is empty.
-- It's a 'LHsSigType' because, with Generalised Newtype
-- Deriving, we can mention type variables that aren't type LHsDerivingClause name = Located (HsDerivingClause name)
-- bound by the date type. e.g.
-- data T b = ... deriving( C [a] ) -- | A single @deriving@ clause of a data declaration.
-- should producd a derived instance for (C [a] (T b)) --
-- -- - 'ApiAnnotation.AnnKeywordId' :
-- The payload of the Maybe is Located so that we have a -- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock',
-- place to hang the API annotations: -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',
-- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- 'ApiAnnotation.AnnDeriving', data HsDerivingClause name
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- 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 data NewOrData
= NewType -- ^ @newtype Blah ...@ = NewType -- ^ @newtype Blah ...@
...@@ -1159,15 +1184,12 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context ...@@ -1159,15 +1184,12 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
| otherwise | otherwise
= hang (ppr new_or_data <+> pp_hdr context <+> pp_sig) = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
2 (pp_condecls condecls $$ pp_derivings) 2 (pp_condecls condecls $$ pp_derivings derivings)
where where
pp_sig = case mb_sig of pp_sig = case mb_sig of
Nothing -> empty Nothing -> empty
Just kind -> dcolon <+> ppr kind Just kind -> dcolon <+> ppr kind
pp_derivings = case derivings of pp_derivings (L _ ds) = vcat (map ppr ds)
Nothing -> empty
Just (L _ ds) -> hsep [ text "deriving"
, parens (interpp'SP ds)]
instance (OutputableBndrId name) => Outputable (HsDataDefn name) where instance (OutputableBndrId name) => Outputable (HsDataDefn name) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
...@@ -1455,6 +1477,12 @@ instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where ...@@ -1455,6 +1477,12 @@ instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where
top_matter = text "instance" <+> ppOverlapPragma mbOverlap top_matter = text "instance" <+> ppOverlapPragma mbOverlap
<+> ppr inst_ty <+> 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 :: Maybe (Located OverlapMode) -> SDoc
ppOverlapPragma mb = ppOverlapPragma mb =
case mb of case mb of
...@@ -1496,19 +1524,26 @@ type LDerivDecl name = Located (DerivDecl name) ...@@ -1496,19 +1524,26 @@ type LDerivDecl name = Located (DerivDecl name)
-- | Deriving Declaration -- | Deriving Declaration
data DerivDecl name = DerivDecl data DerivDecl name = DerivDecl
{ deriv_type :: LHsSigType name { deriv_type :: LHsSigType name
, deriv_strategy :: Maybe (Located DerivStrategy)
, deriv_overlap_mode :: Maybe (Located OverlapMode) , deriv_overlap_mode :: Maybe (Located OverlapMode)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
-- 'ApiAnnotation.AnnClose', -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',
-- 'ApiAnnotation.AnnDeriving', -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',
-- 'ApiAnnotation.AnnInstance' -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation -- For details on above see note [Api annotations] in ApiAnnotation
} }
deriving instance (DataId name) => Data (DerivDecl name) deriving instance (DataId name) => Data (DerivDecl name)
instance (OutputableBndrId name) => Outputable (DerivDecl name) where instance (OutputableBndrId name) => Outputable (DerivDecl name) where
ppr (DerivDecl ty o) ppr (DerivDecl { deriv_type = ty
= hsep [text "deriving instance", ppOverlapPragma o, ppr ty] , deriv_strategy = ds
, deriv_overlap_mode = o })
= hsep [ text "deriving"
, ppDerivStrategy ds
, text "instance"
, ppOverlapPragma o
, ppr ty ]
{- {-
************************************************************************ ************************************************************************
......
...@@ -3561,6 +3561,7 @@ xFlagsDeps = [ ...@@ -3561,6 +3561,7 @@ xFlagsDeps = [
flagSpec "DeriveGeneric" LangExt.DeriveGeneric, flagSpec "DeriveGeneric" LangExt.DeriveGeneric,
flagSpec "DeriveLift" LangExt.DeriveLift, flagSpec "DeriveLift" LangExt.DeriveLift,
flagSpec "DeriveTraversable" LangExt.DeriveTraversable, flagSpec "DeriveTraversable" LangExt.DeriveTraversable,
flagSpec "DerivingStrategies" LangExt.DerivingStrategies,
flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields,
flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse,
depFlagSpec' "DoRec" LangExt.RecursiveDo depFlagSpec' "DoRec" LangExt.RecursiveDo
......
...@@ -16,6 +16,7 @@ import SrcLoc ...@@ -16,6 +16,7 @@ import SrcLoc
import Util import Util
import Data.Char import Data.Char
import Data.Foldable (foldl')
-- | Source Statistics -- | Source Statistics
ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc
...@@ -128,9 +129,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ...@@ -128,9 +129,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
spec_info (Just (True, _)) = (0,0,0,0,0,0,1) spec_info (Just (True, _)) = (0,0,0,0,0,0,1)
data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs
, dd_derivs = derivs}}) , dd_derivs = L _ derivs}})
= (length cs, case derivs of Nothing -> 0 = ( length cs
Just (L _ ds) -> length ds) , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
0 derivs )
data_info _ = (0,0) data_info _ = (0,0)
class_info decl@(ClassDecl {}) class_info decl@(ClassDecl {})
......
...@@ -186,7 +186,8 @@ getAndRemoveAnnotationComments (anns,canns) span = ...@@ -186,7 +186,8 @@ getAndRemoveAnnotationComments (anns,canns) span =
-- corresponding token, unless otherwise noted -- corresponding token, unless otherwise noted
-- See note [Api annotations] above for details of the usage -- See note [Api annotations] above for details of the usage
data AnnKeywordId data AnnKeywordId
= AnnAs = AnnAnyclass
| AnnAs
| AnnAt | AnnAt
| AnnBang -- ^ '!' | AnnBang -- ^ '!'
| AnnBackquote -- ^ '`' | AnnBackquote -- ^ '`'
...@@ -256,6 +257,7 @@ data AnnKeywordId ...@@ -256,6 +257,7 @@ data AnnKeywordId
| AnnSemi -- ^ ';' | AnnSemi -- ^ ';'
| AnnSimpleQuote -- ^ ''' | AnnSimpleQuote -- ^ '''
| AnnStatic -- ^ 'static' | AnnStatic -- ^ 'static'
| AnnStock
| AnnThen | AnnThen
| AnnThIdSplice -- ^ '$' | AnnThIdSplice -- ^ '$'
| AnnThIdTySplice -- ^ '$$' | AnnThIdTySplice -- ^ '$$'
......
...@@ -612,6 +612,8 @@ data Token ...@@ -612,6 +612,8 @@ data Token
| ITusing | ITusing
| ITpattern | ITpattern
| ITstatic | ITstatic
| ITstock
| ITanyclass
-- Pragmas, see note [Pragma source text] in BasicTypes -- Pragmas, see note [Pragma source text] in BasicTypes
| ITinline_prag SourceText InlineSpec RuleMatchInfo | ITinline_prag SourceText InlineSpec RuleMatchInfo
...@@ -803,6 +805,8 @@ reservedWordsFM = listToUFM $ ...@@ -803,6 +805,8 @@ reservedWordsFM = listToUFM $
( "role", ITrole, 0 ), ( "role", ITrole, 0 ),
( "pattern", ITpattern, xbit PatternSynonymsBit), ( "pattern", ITpattern, xbit PatternSynonymsBit),
( "static", ITstatic, 0 ), ( "static", ITstatic, 0 ),
( "stock", ITstock, 0 ),
( "anyclass", ITanyclass, 0 ),
( "group", ITgroup, xbit TransformComprehensionsBit), ( "group", ITgroup, xbit TransformComprehensionsBit),
( "by", ITby, xbit TransformComprehensionsBit), ( "by", ITby, xbit TransformComprehensionsBit),
( "using", ITusing, xbit TransformComprehensionsBit), ( "using", ITusing, xbit TransformComprehensionsBit),
......
...@@ -88,7 +88,7 @@ import qualified GHC.LanguageExtensions as LangExt ...@@ -88,7 +88,7 @@ import qualified GHC.LanguageExtensions as LangExt
%expect 36 -- shift/reduce conflicts %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. 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: 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. ...@@ -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 .
strict_mark -> unpackedness . strictness strict_mark -> unpackedness . strictness
...@@ -128,7 +128,7 @@ state 46 contains 2 shift/reduce conflicts. ...@@ -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 . context -> btype .
*** type -> btype . *** type -> btype .
...@@ -138,7 +138,7 @@ state 50 contains 1 shift/reduce conflict. ...@@ -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 . *** btype -> tyapps .
tyapps -> tyapps . tyapp tyapps -> tyapps . tyapp
...@@ -147,7 +147,7 @@ state 51 contains 9 shift/reduce conflicts. ...@@ -147,7 +147,7 @@ state 51 contains 9 shift/reduce conflicts.
------------------------------------------------------------------------------- -------------------------------------------------------------------------------