summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2016-09-30 20:15:25 -0400
committerBen Gamari <ben@smart-cactus.org>2016-09-30 23:23:44 -0400
commit9e862765ffe161da8a4fd9cd67b0a600874feaa9 (patch)
tree235c1ba702b0101e1fa6a8fe7f8146e2c7ec9c69 /compiler
parentb3d55e20d20344bfc09f4ca4a554a819c4ecbfa8 (diff)
downloadhaskell-9e862765ffe161da8a4fd9cd67b0a600874feaa9.tar.gz
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
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/BasicTypes.hs26
-rw-r--r--compiler/deSugar/DsMeta.hs57
-rw-r--r--compiler/hsSyn/Convert.hs27
-rw-r--r--compiler/hsSyn/HsDecls.hs89
-rw-r--r--compiler/main/DynFlags.hs1
-rw-r--r--compiler/main/HscStats.hs8
-rw-r--r--compiler/parser/ApiAnnotation.hs4
-rw-r--r--compiler/parser/Lexer.x4
-rw-r--r--compiler/parser/Parser.y126
-rw-r--r--compiler/prelude/THNames.hs151
-rw-r--r--compiler/rename/RnSource.hs45
-rw-r--r--compiler/rename/RnTypes.hs4
-rw-r--r--compiler/typecheck/TcDeriv.hs554
-rw-r--r--compiler/typecheck/TcGenDeriv.hs21
-rw-r--r--compiler/typecheck/TcInstDcls.hs10
15 files changed, 777 insertions, 350 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index aab0528d1c..0429a43f5d 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -41,6 +41,8 @@ module BasicTypes(
TopLevelFlag(..), isTopLevel, isNotTopLevel,
+ DerivStrategy(..),
+
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
@@ -479,6 +481,30 @@ instance Outputable Origin where
{-
************************************************************************
* *
+ 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"
+
+{-
+************************************************************************
+* *
Instance overlap flag
* *
************************************************************************
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 638d9b468b..d8fdb54183 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -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)
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 5b5119a404..6bb71991d4 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -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"
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 24b13c4917..ed8da4d4e1 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -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 ]
{-
************************************************************************
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index b642bead7b..a972716bc1 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index 78020f72bc..241dfd8095 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -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 {})
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index eebec547cc..ac784bcea4 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -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 -- ^ '$$'
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 410d150f45..361fa0be6a 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -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),
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 5db535f20e..4cab083484 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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
- | data_or_newtype capi_ctype tycl_hdr constrs deriving
+ | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
Nothing (reverse (snd $ unLoc $4))
- (unLoc $5))
+ (fmap reverse $5))
((fst $ unLoc $1):(fst $ unLoc $4)) }
-- GADT instance declaration
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
- deriving
+ maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
- $3 (snd $ unLoc $4) (snd $ unLoc $5) (unLoc $6))
+ $3 (snd $ unLoc $4) (snd $ unLoc $5)
+ (fmap reverse $6))
((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
data_or_newtype :: { Located (AddAnn, NewOrData) }
@@ -1120,11 +1134,11 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
- : 'deriving' 'instance' overlap_pragma inst_type
- {% do { let { err = text "in the stand-alone deriving instance"
- <> colon <+> quotes (ppr $4) }
- ; ams (sLL $1 (hsSigType $>) (DerivDecl $4 $3))
- [mj AnnDeriving $1, mj AnnInstance $2] } }
+ : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type
+ {% do { let { err = text "in the stand-alone deriving instance"
+ <> colon <+> quotes (ppr $5) }
+ ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4))
+ [mj AnnDeriving $1, mj AnnInstance $3] } }
-----------------------------------------------------------------------------
-- Role annotations
@@ -1929,22 +1943,34 @@ fielddecl :: { LConDeclField RdrName }
(ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5)))
[mu AnnDcolon $3] }
+-- Reversed!
+maybe_derivings :: { HsDeriving RdrName }
+ : {- empty -} { noLoc [] }
+ | derivings { $1 }
+
+-- A list of one or more deriving clauses at the end of a datatype
+derivings :: { HsDeriving RdrName }
+ : derivings deriving { sLL $1 $> $ $2 : unLoc $1 }
+ | deriving { sLL $1 $> [$1] }
+
-- The outer Located is just to allow the caller to
-- know the rightmost extremity of the 'deriving' clause
-deriving :: { Located (HsDeriving RdrName) }
- : {- empty -} { noLoc Nothing }
- | 'deriving' qtycondoc {% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ Just $ L full_loc $
- [mkLHsSigType $2])
- [mj AnnDeriving $1] }
-
- | 'deriving' '(' ')' {% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ Just $ L full_loc [])
- [mj AnnDeriving $1,mop $2,mcp $3] }
-
- | 'deriving' '(' deriv_types ')' {% let { full_loc = comb2 $1 $> }
- in ams (L full_loc $ Just $ L full_loc $3)
- [mj AnnDeriving $1,mop $2,mcp $4] }
+deriving :: { LHsDerivingClause RdrName }
+ : 'deriving' deriv_strategy qtycondoc
+ {% let { full_loc = comb2 $1 $> }
+ in ams (L full_loc $ HsDerivingClause $2 $ L full_loc
+ [mkLHsSigType $3])
+ [mj AnnDeriving $1] }
+
+ | 'deriving' deriv_strategy '(' ')'
+ {% let { full_loc = comb2 $1 $> }
+ in ams (L full_loc $ HsDerivingClause $2 $ L full_loc [])
+ [mj AnnDeriving $1,mop $3,mcp $4] }
+
+ | 'deriving' deriv_strategy '(' deriv_types ')'
+ {% let { full_loc = comb2 $1 $> }
+ in ams (L full_loc $ HsDerivingClause $2 $ L full_loc $4)
+ [mj AnnDeriving $1,mop $3,mcp $5] }
-- Glasgow extension: allow partial
-- applications in derivings
@@ -3014,8 +3040,8 @@ qvarid :: { Located RdrName }
| QVARID { sL1 $1 $! mkQual varName (getQVARID $1) }
-- Note that 'role' and 'family' get lexed separately regardless of
--- the use of extensions. However, because they are listed here, this
--- is OK and they can be used as normal varids.
+-- the use of extensions. However, because they are listed here,
+-- this is OK and they can be used as normal varids.
-- See Note [Lexing type pseudo-keywords] in Lexer.x
varid :: { Located RdrName }
: VARID { sL1 $1 $! mkUnqual varName (getVARID $1) }
@@ -3049,8 +3075,8 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
--- except 'unsafe', 'interruptible', 'forall', 'family', and 'role',
--- whose treatment differs depending on context
+-- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and
+-- 'anyclass', whose treatment differs depending on context
special_id :: { Located FastString }
special_id
: 'as' { sL1 $1 (fsLit "as") }
@@ -3065,6 +3091,8 @@ special_id
| 'prim' { sL1 $1 (fsLit "prim") }
| 'javascript' { sL1 $1 (fsLit "javascript") }
| 'group' { sL1 $1 (fsLit "group") }
+ | 'stock' { sL1 $1 (fsLit "stock") }
+ | 'anyclass' { sL1 $1 (fsLit "anyclass") }
special_sym :: { Located FastString }
special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 4f98114bb5..8c184f851e 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -65,7 +65,7 @@ templateHaskellNames = [
-- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName,
classDName, instanceWithOverlapDName,
- standaloneDerivDName, sigDName, forImpDName,
+ standaloneDerivWithStrategyDName, sigDName, forImpDName,
pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName, pragAnnDName, defaultSigDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
@@ -125,6 +125,8 @@ templateHaskellNames = [
-- Overlap
overlappableDataConName, overlappingDataConName, overlapsDataConName,
incoherentDataConName,
+ -- DerivStrategy
+ stockDataConName, anyclassDataConName, newtypeDataConName,
-- TExp
tExpDataConName,
-- RuleBndr
@@ -137,6 +139,8 @@ templateHaskellNames = [
tySynEqnName,
-- AnnTarget
valueAnnotationName, typeAnnotationName, moduleAnnotationName,
+ -- DerivClause
+ derivClauseName,
-- The type classes
liftClassName,
@@ -150,7 +154,7 @@ templateHaskellNames = [
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
- overlapTyConName,
+ overlapTyConName, derivClauseQTyConName, derivStrategyTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -180,24 +184,25 @@ qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
predTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
- overlapTyConName :: Name
-qTyConName = thTc (fsLit "Q") qTyConKey
-nameTyConName = thTc (fsLit "Name") nameTyConKey
-fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
-patTyConName = thTc (fsLit "Pat") patTyConKey
-fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
-expTyConName = thTc (fsLit "Exp") expTyConKey
-decTyConName = thTc (fsLit "Dec") decTyConKey
-typeTyConName = thTc (fsLit "Type") typeTyConKey
-tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
-matchTyConName = thTc (fsLit "Match") matchTyConKey
-clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
-funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
-predTyConName = thTc (fsLit "Pred") predTyConKey
-tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
-injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
-kindTyConName = thTc (fsLit "Kind") kindTyConKey
-overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
+ overlapTyConName, derivStrategyTyConName :: Name
+qTyConName = thTc (fsLit "Q") qTyConKey
+nameTyConName = thTc (fsLit "Name") nameTyConKey
+fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
+patTyConName = thTc (fsLit "Pat") patTyConKey
+fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
+expTyConName = thTc (fsLit "Exp") expTyConKey
+decTyConName = thTc (fsLit "Dec") decTyConKey
+typeTyConName = thTc (fsLit "Type") typeTyConKey
+tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
+matchTyConName = thTc (fsLit "Match") matchTyConKey
+clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
+funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
+predTyConName = thTc (fsLit "Pred") predTyConKey
+tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
+injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
+kindTyConName = thTc (fsLit "Kind") kindTyConKey
+overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
+derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
@@ -332,12 +337,11 @@ parSName = libFun (fsLit "parS") parSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
- pragSpecDName,
- pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,
- standaloneDerivDName, defaultSigDName, dataInstDName, newtypeInstDName,
- tySynInstDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
- infixLDName, infixRDName, infixNDName, roleAnnotDName, patSynDName,
- patSynSigDName :: Name
+ pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
+ pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,
+ dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
+ openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
+ infixNDName, roleAnnotDName, patSynDName, patSynSigDName :: Name
funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey
dataDName = libFun (fsLit "dataD") dataDIdKey
@@ -346,7 +350,8 @@ tySynDName = libFun (fsLit "tySynD") tySynDIdKey
classDName = libFun (fsLit "classD") classDIdKey
instanceWithOverlapDName
= libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey
-standaloneDerivDName = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey
+standaloneDerivWithStrategyDName = libFun
+ (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey
defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
forImpDName = libFun (fsLit "forImpD") forImpDIdKey
@@ -522,11 +527,16 @@ valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey
typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey
moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey
+-- type DerivClause = ...
+derivClauseName :: Name
+derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey
+
matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
decQTyConName, conQTyConName, bangTypeQTyConName,
varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
- ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name
+ ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,
+ derivClauseQTyConName :: Name
matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
@@ -544,6 +554,7 @@ predQTyConName = libTc (fsLit "PredQ") predQTyConKey
ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey
roleTyConName = libTc (fsLit "Role") roleTyConKey
+derivClauseQTyConName = libTc (fsLit "DerivClauseQ") derivClauseQTyConKey
-- quasiquoting
quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -579,6 +590,12 @@ overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey
overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey
incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey
+-- data DerivStrategy = ...
+stockDataConName, anyclassDataConName, newtypeDataConName :: Name
+stockDataConName = thCon (fsLit "Stock") stockDataConKey
+anyclassDataConName = thCon (fsLit "Anyclass") anyclassDataConKey
+newtypeDataConName = thCon (fsLit "Newtype") newtypeDataConKey
+
{- *********************************************************************
* *
Class keys
@@ -608,7 +625,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
- overlapTyConKey :: Unique
+ overlapTyConKey, derivClauseQTyConKey, derivStrategyTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
@@ -643,6 +660,8 @@ tExpTyConKey = mkPreludeTyConUnique 230
injAnnTyConKey = mkPreludeTyConUnique 231
kindTyConKey = mkPreludeTyConUnique 232
overlapTyConKey = mkPreludeTyConUnique 233
+derivClauseQTyConKey = mkPreludeTyConUnique 234
+derivStrategyTyConKey = mkPreludeTyConUnique 235
{- *********************************************************************
* *
@@ -684,6 +703,12 @@ overlappingDataConKey = mkPreludeDataConUnique 110
overlapsDataConKey = mkPreludeDataConUnique 111
incoherentDataConKey = mkPreludeDataConUnique 112
+-- data DerivStrategy = ...
+stockDataConKey, anyclassDataConKey, newtypeDataConKey :: Unique
+stockDataConKey = mkPreludeDataConUnique 113
+anyclassDataConKey = mkPreludeDataConUnique 114
+newtypeDataConKey = mkPreludeDataConUnique 115
+
{- *********************************************************************
* *
Id keys
@@ -830,39 +855,39 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
- newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey, infixLDIdKey,
- infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
+ newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
+ infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
patSynSigDIdKey :: Unique
-funDIdKey = mkPreludeMiscIdUnique 320
-valDIdKey = mkPreludeMiscIdUnique 321
-dataDIdKey = mkPreludeMiscIdUnique 322
-newtypeDIdKey = mkPreludeMiscIdUnique 323
-tySynDIdKey = mkPreludeMiscIdUnique 324
-classDIdKey = mkPreludeMiscIdUnique 325
-instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326
-instanceDIdKey = mkPreludeMiscIdUnique 327
-sigDIdKey = mkPreludeMiscIdUnique 328
-forImpDIdKey = mkPreludeMiscIdUnique 329
-pragInlDIdKey = mkPreludeMiscIdUnique 330
-pragSpecDIdKey = mkPreludeMiscIdUnique 331
-pragSpecInlDIdKey = mkPreludeMiscIdUnique 332
-pragSpecInstDIdKey = mkPreludeMiscIdUnique 333
-pragRuleDIdKey = mkPreludeMiscIdUnique 334
-pragAnnDIdKey = mkPreludeMiscIdUnique 335
-dataFamilyDIdKey = mkPreludeMiscIdUnique 336
-openTypeFamilyDIdKey = mkPreludeMiscIdUnique 337
-dataInstDIdKey = mkPreludeMiscIdUnique 338
-newtypeInstDIdKey = mkPreludeMiscIdUnique 339
-tySynInstDIdKey = mkPreludeMiscIdUnique 340
-closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341
-infixLDIdKey = mkPreludeMiscIdUnique 342
-infixRDIdKey = mkPreludeMiscIdUnique 343
-infixNDIdKey = mkPreludeMiscIdUnique 344
-roleAnnotDIdKey = mkPreludeMiscIdUnique 345
-standaloneDerivDIdKey = mkPreludeMiscIdUnique 346
-defaultSigDIdKey = mkPreludeMiscIdUnique 347
-patSynDIdKey = mkPreludeMiscIdUnique 348
-patSynSigDIdKey = mkPreludeMiscIdUnique 349
+funDIdKey = mkPreludeMiscIdUnique 320
+valDIdKey = mkPreludeMiscIdUnique 321
+dataDIdKey = mkPreludeMiscIdUnique 322
+newtypeDIdKey = mkPreludeMiscIdUnique 323
+tySynDIdKey = mkPreludeMiscIdUnique 324
+classDIdKey = mkPreludeMiscIdUnique 325
+instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326
+instanceDIdKey = mkPreludeMiscIdUnique 327
+sigDIdKey = mkPreludeMiscIdUnique 328
+forImpDIdKey = mkPreludeMiscIdUnique 329
+pragInlDIdKey = mkPreludeMiscIdUnique 330
+pragSpecDIdKey = mkPreludeMiscIdUnique 331
+pragSpecInlDIdKey = mkPreludeMiscIdUnique 332
+pragSpecInstDIdKey = mkPreludeMiscIdUnique 333
+pragRuleDIdKey = mkPreludeMiscIdUnique 334
+pragAnnDIdKey = mkPreludeMiscIdUnique 335
+dataFamilyDIdKey = mkPreludeMiscIdUnique 336
+openTypeFamilyDIdKey = mkPreludeMiscIdUnique 337
+dataInstDIdKey = mkPreludeMiscIdUnique 338
+newtypeInstDIdKey = mkPreludeMiscIdUnique 339
+tySynInstDIdKey = mkPreludeMiscIdUnique 340
+closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341
+infixLDIdKey = mkPreludeMiscIdUnique 342
+infixRDIdKey = mkPreludeMiscIdUnique 343
+infixNDIdKey = mkPreludeMiscIdUnique 344
+roleAnnotDIdKey = mkPreludeMiscIdUnique 345
+standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346
+defaultSigDIdKey = mkPreludeMiscIdUnique 347
+patSynDIdKey = mkPreludeMiscIdUnique 348
+patSynSigDIdKey = mkPreludeMiscIdUnique 349
-- type Cxt = ...
cxtIdKey :: Unique
@@ -1022,6 +1047,10 @@ valueAnnotationIdKey = mkPreludeMiscIdUnique 490
typeAnnotationIdKey = mkPreludeMiscIdUnique 491
moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
+-- type DerivPred = ...
+derivClauseIdKey :: Unique
+derivClauseIdKey = mkPreludeMiscIdUnique 493
+
{-
************************************************************************
* *
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index e3c90a8e2d..68038d98bb 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -42,11 +42,11 @@ import NameEnv
import Avail
import Outputable
import Bag
-import BasicTypes ( RuleName, pprRuleName )
+import BasicTypes ( DerivStrategy, RuleName, pprRuleName )
import FastString
import SrcLoc
import DynFlags
-import Util ( debugIsOn, partitionWith )
+import Util ( debugIsOn, lengthExceeds, partitionWith )
import HscTypes ( HscEnv, hsc_dflags )
import ListSetOps ( findDupsEq, removeDups, equivClasses )
import Digraph ( SCC, flattenSCC, flattenSCCs
@@ -57,6 +57,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Arrow ( first )
import Data.List ( sortBy, mapAccumL )
+import Data.Maybe ( isJust )
import qualified Data.Set as Set ( difference, fromList, toList, null )
{-
@@ -945,11 +946,14 @@ Here 'k' is in scope in the kind signature, just like 'x'.
-}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
-rnSrcDerivDecl (DerivDecl ty overlap)
+rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
= do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
+ ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies
; unless standalone_deriv_ok (addErr standaloneDerivErr)
+ ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
+ illegalDerivStrategyErr $ fmap unLoc deriv_strat
; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
- ; return (DerivDecl ty' overlap, fvs) }
+ ; return (DerivDecl ty' deriv_strat overlap, fvs) }
standaloneDerivErr :: SDoc
standaloneDerivErr
@@ -1767,17 +1771,40 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
L _ (ConDeclGADT {}) : _ -> False
_ -> True
- rn_derivs Nothing
- = return (Nothing, emptyFVs)
- rn_derivs (Just (L loc ds))
- = do { (ds', fvs) <- mapFvRn (rnHsSigType doc) ds
- ; return (Just (L loc ds'), fvs) }
+ rn_derivs (L loc ds)
+ = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
+ ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
+ multipleDerivClausesErr
+ ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds
+ ; return (L loc ds', fvs) }
+
+rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause RdrName
+ -> RnM (LHsDerivingClause Name, FreeVars)
+rnLHsDerivingClause deriv_strats_ok doc
+ (L loc (HsDerivingClause { deriv_clause_strategy = dcs
+ , deriv_clause_tys = L loc' dct }))
+ = do { failIfTc (isJust dcs && not deriv_strats_ok) $
+ illegalDerivStrategyErr $ fmap unLoc dcs
+ ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct
+ ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs
+ , deriv_clause_tys = L loc' dct' })
+ , fvs ) }
badGadtStupidTheta :: HsDocContext -> SDoc
badGadtStupidTheta _
= vcat [text "No context is allowed on a GADT-style data declaration",
text "(You can put a context on each constructor, though.)"]
+illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc
+illegalDerivStrategyErr ds
+ = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds
+ , text "Use DerivingStrategies to enable this extension" ]
+
+multipleDerivClausesErr :: SDoc
+multipleDerivClausesErr
+ = vcat [ text "Illegal use of multiple, consecutive deriving clauses"
+ , text "Use DerivingStrategies to allow this" ]
+
rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
-- inside an *class decl* for cls
-- used for associated types
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index f201b221a6..d672aa081c 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -1553,11 +1553,11 @@ extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName]
-- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
-- Here k should scope over the whole definition
extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
- , dd_cons = cons, dd_derivs = derivs })
+ , dd_cons = cons, dd_derivs = L _ derivs })
= (nubL . freeKiTyVarsKindVars) <$>
(extract_lctxt TypeLevel ctxt =<<
extract_mb extract_lkind ksig =<<
- extract_mb (extract_sig_tys . unLoc) derivs =<<
+ extract_sig_tys (concatMap (unLoc . deriv_clause_tys . unLoc) derivs) =<<
foldrM (extract_con . unLoc) emptyFKTV cons)
where
extract_con (ConDeclGADT { }) acc = return acc
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 858d9209df..c47b00b827 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -39,6 +39,7 @@ import RnSource ( addTcgDUs )
import Avail
import Unify( tcUnifyTy )
+import BasicTypes ( DerivStrategy(..) )
import Class
import Type
import ErrUtils
@@ -83,16 +84,16 @@ Overall plan
3. Add the derived bindings, generating InstInfos
-}
--- DerivSpec is purely local to this module
-data DerivSpec theta = DS { ds_loc :: SrcSpan
- , ds_name :: Name -- DFun name
- , ds_tvs :: [TyVar]
- , ds_theta :: theta
- , ds_cls :: Class
- , ds_tys :: [Type]
- , ds_tc :: TyCon
- , ds_overlap :: Maybe OverlapMode
- , ds_newtype :: Maybe Type } -- The newtype rep type
+-- DerivSpec is purely local to this module
+data DerivSpec theta = DS { ds_loc :: SrcSpan
+ , ds_name :: Name -- DFun name
+ , ds_tvs :: [TyVar]
+ , ds_theta :: theta
+ , ds_cls :: Class
+ , ds_tys :: [Type]
+ , ds_tc :: TyCon
+ , ds_overlap :: Maybe OverlapMode
+ , ds_mechanism :: DerivSpecMechanism }
-- This spec implies a dfun declaration of the form
-- df :: forall tvs. theta => C tys
-- The Name is the name for the DFun we'll build
@@ -105,8 +106,8 @@ data DerivSpec theta = DS { ds_loc :: SrcSpan
-- the theta is either the given and final theta, in standalone deriving,
-- or the not-yet-simplified list of constraints together with their origin
- -- ds_newtype = Just rep_ty <=> Generalised Newtype Deriving (GND)
- -- Nothing <=> Vanilla deriving
+ -- ds_mechanism specifies the means by which GHC derives the instance.
+ -- See Note [Deriving strategies]
{-
Example:
@@ -117,9 +118,25 @@ Example:
axiom :RTList a = Tree a
DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
- , ds_tc = :RTList, ds_newtype = Just (Tree a) }
+ , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }
-}
+-- What action to take in order to derive a class instance.
+-- See Note [Deriving strategies]
+-- NB: DerivSpecMechanism is purely local to this module
+data DerivSpecMechanism
+ = DerivSpecStock -- "Standard" classes (except for Generic(1), which is
+ -- covered by the special case of DerivSpecGeneric)
+ (SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff))
+
+ | DerivSpecGeneric -- -XDeriveGeneric
+ (TyCon -> [Type] -> TcM (LHsBinds RdrName, FamInst))
+
+ | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
+ Type -- ^ The newtype rep type
+
+ | DerivSpecAnyClass -- -XDeriveAnyClass
+
type DerivContext = Maybe ThetaType
-- Nothing <=> Vanilla deriving; infer the context of the instance decl
-- Just theta <=> Standalone deriving: context supplied by programmer
@@ -318,12 +335,12 @@ both of them. So we gather defs/uses from deriving just like anything else.
-}
--- | Stuff needed to process a `deriving` clause
-data DerivInfo = DerivInfo { di_rep_tc :: TyCon
+-- | Stuff needed to process a datatype's `deriving` clauses
+data DerivInfo = DerivInfo { di_rep_tc :: TyCon
-- ^ The data tycon for normal datatypes,
-- or the *representation* tycon for data families
- , di_preds :: [LHsSigType Name]
- , di_ctxt :: SDoc -- ^ error context
+ , di_clauses :: [LHsDerivingClause Name]
+ , di_ctxt :: SDoc -- ^ error context
}
-- | Extract `deriving` clauses of proper data type (skips data families)
@@ -333,9 +350,9 @@ mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls
mk_deriv decl@(DataDecl { tcdLName = L _ data_name
, tcdDataDefn =
- HsDataDefn { dd_derivs = Just (L _ preds) } })
+ HsDataDefn { dd_derivs = L _ clauses } })
= do { tycon <- tcLookupTyCon data_name
- ; return [DerivInfo { di_rep_tc = tycon, di_preds = preds
+ ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses
, di_ctxt = tcMkDeclCtxt decl }] }
mk_deriv _ = return []
@@ -527,10 +544,10 @@ makeDerivSpecs is_boot deriv_infos deriv_decls
------------------------------------------------------------------
-- | Process a `deriving` clause
deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec]
-deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_preds = preds
+deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses
, di_ctxt = err_ctxt })
= addErrCtxt err_ctxt $
- concatMapM (deriveTyData tvs tc tys) preds
+ concatMapM (deriveForClause . unLoc) clauses
where
tvs = tyConTyVars rep_tc
(tc, tys) = case tyConFamInstSig_maybe rep_tc of
@@ -541,15 +558,23 @@ deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_preds = preds
_ -> (rep_tc, mkTyVarTys tvs) -- datatype
+ deriveForClause :: HsDerivingClause Name -> TcM [EarlyDerivSpec]
+ deriveForClause (HsDerivingClause { deriv_clause_strategy = dcs
+ , deriv_clause_tys = L _ preds })
+ = concatMapM (deriveTyData tvs tc tys (fmap unLoc dcs)) preds
+
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
-- Standalone deriving declarations
-- e.g. deriving instance Show a => Show (T a)
-- Rather like tcLocalInstDecl
-deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
+deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
= setSrcSpan loc $
addErrCtxt (standaloneCtxt deriv_ty) $
do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
+ ; let deriv_strat = fmap unLoc deriv_strat'
+ ; traceTc "Deriving strategy (standalone deriving)" $
+ vcat [ppr deriv_strat, ppr deriv_ty]
; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
; traceTc "Standalone deriving;" $ vcat
[ text "tvs:" <+> ppr tvs
@@ -575,11 +600,12 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
| isAlgTyCon tc || isDataFamilyTyCon tc -- All other classes
-> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
tvs cls cls_tys tc tc_args
- (Just theta)
+ (Just theta) deriv_strat
; return [spec] }
_ -> -- Complain about functions, primitive types, etc,
- failWithTc $ derivingThingErr False cls cls_tys inst_ty $
+ failWithTc $ derivingThingErr False cls cls_tys
+ inst_ty deriv_strat $
text "The last argument of the instance must be a data or newtype application"
}
@@ -593,11 +619,12 @@ warnUselessTypeable
------------------------------------------------------------------
deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance
-- Can be a data instance, hence [Type] args
+ -> Maybe DerivStrategy -- The optional deriving strategy
-> LHsSigType Name -- The deriving predicate
-> TcM [EarlyDerivSpec]
-- The deriving clause of a data or newtype declaration
-- I.e. not standalone deriving
-deriveTyData tvs tc tc_args deriv_pred
+deriveTyData tvs tc tc_args deriv_strat deriv_pred
= setSrcSpan (getLoc (hsSigType deriv_pred)) $ -- Use loc of the 'deriving' item
do { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
<- tcExtendTyVarEnv tvs $
@@ -654,6 +681,9 @@ deriveTyData tvs tc tc_args deriv_pred
tkvs = tyCoVarsOfTypesWellScoped $
final_cls_tys ++ final_tc_args
+ ; traceTc "Deriving strategy (deriving clause)" $
+ vcat [ppr deriv_strat, ppr deriv_pred]
+
; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
, pprTvBndrs (tyCoVarsOfTypesList tc_args)
, ppr n_args_to_keep, ppr n_args_to_drop
@@ -676,7 +706,8 @@ deriveTyData tvs tc tc_args deriv_pred
-- newtype instance K a a = ... deriving( Monad )
; spec <- mkEqnHelp Nothing tkvs
- cls final_cls_tys tc final_tc_args Nothing
+ cls final_cls_tys tc final_tc_args
+ Nothing deriv_strat
; traceTc "derivTyData" (ppr spec)
; return [spec] } }
@@ -865,13 +896,14 @@ mkEqnHelp :: Maybe OverlapMode
-> TyCon -> [Type]
-> DerivContext -- Just => context supplied (standalone deriving)
-- Nothing => context inferred (deriving on data decl)
+ -> Maybe DerivStrategy
-> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
-- forall tvs. theta => cls (tys ++ [ty])
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded
-mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
+mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
= do { -- Find the instance of a data family
-- Note [Looking up family instances for deriving]
fam_envs <- tcGetFamInstEnvs
@@ -896,12 +928,13 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
; dflags <- getDynFlags
; if isDataTyCon rep_tc then
mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
- tycon tc_args rep_tc rep_tc_args mtheta
+ tycon tc_args rep_tc rep_tc_args mtheta deriv_strat
else
mkNewTypeEqn dflags overlap_mode tvs cls cls_tys
- tycon tc_args rep_tc rep_tc_args mtheta }
+ tycon tc_args rep_tc rep_tc_args mtheta deriv_strat }
where
- bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
+ bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+ (mkTyConApp tycon tc_args) deriv_strat msg)
{-
Note [Looking up family instances for deriving]
@@ -980,24 +1013,37 @@ mkDataTypeEqn :: DynFlags
-> TyCon -- rep of the above (for type families)
-> [Type] -- rep of the above
-> DerivContext -- Context of the instance, for standalone deriving
+ -> Maybe DerivStrategy -- 'Just' if user requests a particular
+ -- deriving strategy.
+ -- Otherwise, 'Nothing'.
-> TcRn EarlyDerivSpec -- Return 'Nothing' if error
mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
- tycon tc_args rep_tc rep_tc_args mtheta
- = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
- -- NB: pass the *representation* tycon to checkSideConditions
- NonDerivableClass msg -> bale_out (nonStdErr cls $$ msg)
- DerivableClassError msg -> bale_out msg
- CanDerive -> go_for_it
- DerivableViaInstance -> go_for_it
+ tycon tc_args rep_tc rep_tc_args mtheta deriv_strat
+ = case deriv_strat of
+ Just DerivStock -> mk_eqn_stock dflags mtheta cls cls_tys rep_tc
+ go_for_it bale_out
+ Just DerivAnyclass -> mk_eqn_anyclass dflags rep_tc cls
+ go_for_it bale_out
+ -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
+ Just DerivNewtype -> bale_out gndNonNewtypeErr
+ -- Lacking a user-requested deriving strategy, we will try to pick
+ -- between the stock or anyclass strategies
+ Nothing -> mk_eqn_no_mechanism dflags mtheta cls cls_tys rep_tc
+ go_for_it bale_out
where
go_for_it = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
- bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
+ bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+ (mkTyConApp tycon tc_args) deriv_strat msg)
mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> [Type]
-> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
+ -> DerivSpecMechanism -- How GHC should proceed attempting to
+ -- derive this instance, determined in
+ -- mkDataTypeEqn/mkNewTypeEqn
-> TcM EarlyDerivSpec
-mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
+mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
+ mtheta mechanism
= do loc <- getSrcSpanM
dfun_name <- newDFunName' cls tycon
case mtheta of
@@ -1012,7 +1058,7 @@ mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
, ds_tc = rep_tc
, ds_theta = inferred_constraints
, ds_overlap = overlap_mode
- , ds_newtype = Nothing }
+ , ds_mechanism = mechanism }
Just theta -> do -- Specified context
return $ GivenTheta $ DS
{ ds_loc = loc
@@ -1021,11 +1067,56 @@ mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
, ds_tc = rep_tc
, ds_theta = theta
, ds_overlap = overlap_mode
- , ds_newtype = Nothing }
+ , ds_mechanism = mechanism }
where
inst_ty = mkTyConApp tycon tc_args
inst_tys = cls_tys ++ [inst_ty]
+mk_eqn_stock :: DynFlags -> DerivContext -> Class -> [Type] -> TyCon
+ -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
+ -> (SDoc -> TcRn EarlyDerivSpec)
+ -> TcRn EarlyDerivSpec
+mk_eqn_stock dflags mtheta cls cls_tys rep_tc go_for_it bale_out
+ = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
+ CanDerive -> mk_eqn_stock' cls go_for_it
+ DerivableClassError msg -> bale_out msg
+ _ -> bale_out (nonStdErr cls)
+
+mk_eqn_stock' :: Class -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
+ -> TcRn EarlyDerivSpec
+mk_eqn_stock' cls go_for_it
+ | let ck = classKey cls
+ , ck `elem` [genClassKey, gen1ClassKey]
+ = let gk = if ck == genClassKey then Gen0 else Gen1
+ in go_for_it . DerivSpecGeneric . gen_Generic_binds $ gk
+
+ | otherwise = go_for_it $ case hasStockDeriving cls of
+ Just gen_fn -> DerivSpecStock gen_fn
+ Nothing ->
+ pprPanic "mk_eqn_stock': Not a stock class!" (ppr cls)
+
+mk_eqn_anyclass :: DynFlags -> TyCon -> Class
+ -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
+ -> (SDoc -> TcRn EarlyDerivSpec)
+ -> TcRn EarlyDerivSpec
+mk_eqn_anyclass dflags rep_tc cls go_for_it bale_out
+ = case canDeriveAnyClass dflags rep_tc cls of
+ Nothing -> go_for_it DerivSpecAnyClass
+ Just msg -> bale_out msg
+
+mk_eqn_no_mechanism :: DynFlags -> DerivContext -> Class -> [Type] -> TyCon
+ -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
+ -> (SDoc -> TcRn EarlyDerivSpec)
+ -> TcRn EarlyDerivSpec
+mk_eqn_no_mechanism dflags mtheta cls cls_tys rep_tc go_for_it bale_out
+ = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
+ -- NB: pass the *representation* tycon to checkSideConditions
+ NonDerivableClass msg -> bale_out (nonStdErr cls $$ msg)
+ DerivableClassError msg -> bale_out msg
+ CanDerive -> mk_eqn_stock' cls go_for_it
+ DerivableViaInstance -> go_for_it DerivSpecAnyClass
+
+
----------------------
inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
@@ -1219,7 +1310,7 @@ Note [Deriving any class]
~~~~~~~~~~~~~~~~~~~~~~~~~
Classic uses of a deriving clause, or a standalone-deriving declaration, are
for:
- * a built-in class like Eq or Show, for which GHC knows how to generate
+ * a stock class like Eq or Show, for which GHC knows how to generate
the instance code
* a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving
@@ -1244,8 +1335,8 @@ if DeriveAnyClass is enabled.
This is not restricted to Generics; any class can be derived, simply giving
rise to an empty instance.
-Unfortunately, it is not clear how to determine the context (in case of
-standard deriving; in standalone deriving, the user provides the context).
+Unfortunately, it is not clear how to determine the context (when using a
+deriving clause; in standalone deriving, the user provides the context).
GHC uses the same heuristic for figuring out the class context that it uses for
Eq in the case of *-kinded classes, and for Functor in the case of
* -> *-kinded classes. That may not be optimal or even wrong. But in such
@@ -1260,13 +1351,14 @@ cases, standalone deriving can still be used.
-- the data constructors - but we need to be careful to fall back to the
-- family tycon (with indexes) in error messages.
-data DerivStatus = CanDerive -- Standard class, can derive
- | DerivableClassError SDoc -- Standard class, but can't do it
+data DerivStatus = CanDerive -- Stock class, can derive
+ | DerivableClassError SDoc -- Stock class, but can't do it
| DerivableViaInstance -- See Note [Deriving any class]
- | NonDerivableClass SDoc -- Non-standard class
+ | NonDerivableClass SDoc -- Non-stock class
--- A "standard" class is one defined in the Haskell report which GHC knows how
--- to generate code for, such as Eq, Ord, Ix, etc.
+-- A stock class is one either defined in the Haskell report or for which GHC
+-- otherwise knows how to generate code for (possibly requiring the use of a
+-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.
checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
-> TyCon -- tycon
@@ -1277,11 +1369,11 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc
NotValid err -> DerivableClassError err -- Class-specific error
IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
-> CanDerive
- -- All derivable classes are unary in the sense that there
- -- should be not types in cls_tys (i.e., no type args other
- -- than last). Note that cls_types can contain invisible
- -- types as well (e.g., for Generic1, which is poly-kinded),
- -- so make sure those are not counted.
+ -- All stock derivable classes are unary in the sense that
+ -- there should be not types in cls_tys (i.e., no type args
+ -- other than last). Note that cls_types can contain
+ -- invisible types as well (e.g., for Generic1, which is
+ -- poly-kinded), so make sure those are not counted.
| otherwise -> DerivableClassError (classArgsErr cls cls_tys)
-- e.g. deriving( Eq s )
@@ -1302,12 +1394,23 @@ nonUnaryErr ct = quotes (ppr ct)
nonStdErr :: Class -> SDoc
nonStdErr cls =
quotes (ppr cls)
- <+> text "is not a standard derivable class (Eq, Show, etc.)"
+ <+> text "is not a stock derivable class (Eq, Show, etc.)"
+
+gndNonNewtypeErr :: SDoc
+gndNonNewtypeErr =
+ text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"
+-- Side conditions (whether the datatype must have at least one constructor,
+-- required language extensions, etc.) for using GHC's stock deriving
+-- mechanism on certain classes (as opposed to classes that require
+-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
+-- class for which stock deriving isn't possible.
+--
+-- NB: The classes listed below should be in sync with the ones listed in the
+-- definition of hasStockDeriving in TcGenDeriv (except for Generic(1),
+-- which are handled specially). If you add new class to sideConditions,
+-- make sure to update hasStockDeriving as well!
sideConditions :: DerivContext -> Class -> Maybe Condition
--- Side conditions for classes that GHC knows about,
--- that is, "deriviable classes"
--- Returns Nothing for a non-derivable class
sideConditions mtheta cls
| cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls)
| cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls)
@@ -1548,7 +1651,7 @@ std_class_via_coercible :: Class -> Bool
-- because giving so gives the same results as generating the boilerplate
std_class_via_coercible clas
= classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
- -- Not Read/Show/Lift because they respect the type
+ -- Not Read/Show because they respect the type
-- Not Enum, because newtypes are never in Enum
@@ -1636,63 +1739,108 @@ a context for the Data instances:
mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [TyVar] -> Class
-> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
- -> DerivContext
+ -> DerivContext -> Maybe DerivStrategy
-> TcRn EarlyDerivSpec
mkNewTypeEqn dflags overlap_mode tvs
- cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
+ cls cls_tys tycon tc_args rep_tycon rep_tc_args
+ mtheta deriv_strat
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
- | ASSERT( length cls_tys + 1 == classArity cls )
- might_derive_via_coercible && ((newtype_deriving && not deriveAnyClass)
- || std_class_via_coercible cls)
- = do traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
- dfun_name <- newDFunName' cls tycon
- loc <- getSrcSpanM
- case mtheta of
- Just theta -> return $ GivenTheta $ DS
- { ds_loc = loc
- , ds_name = dfun_name, ds_tvs = dfun_tvs
- , ds_cls = cls, ds_tys = inst_tys
- , ds_tc = rep_tycon
- , ds_theta = theta
- , ds_overlap = overlap_mode
- , ds_newtype = Just rep_inst_ty }
- Nothing -> return $ InferTheta $ DS
- { ds_loc = loc
- , ds_name = dfun_name, ds_tvs = dfun_tvs
- , ds_cls = cls, ds_tys = inst_tys
- , ds_tc = rep_tycon
- , ds_theta = all_preds
- , ds_overlap = overlap_mode
- , ds_newtype = Just rep_inst_ty }
- | otherwise
- = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
- -- Error with standard class
- DerivableClassError msg
- | might_derive_via_coercible -> bale_out (msg $$ suggest_gnd)
- | otherwise -> bale_out msg
-
- -- Must use newtype deriving or DeriveAnyClass
- NonDerivableClass _msg
- -- Too hard, even with newtype deriving
- | newtype_deriving -> bale_out cant_derive_err
- -- Try newtype deriving!
- -- Here we suggest GeneralizedNewtypeDeriving even in cases where it may
- -- not be applicable. See Trac #9600.
- | otherwise -> bale_out (non_std $$ suggest_gnd)
-
- -- CanDerive/DerivableViaInstance
- _ -> do when (newtype_deriving && deriveAnyClass) $
- addWarnTc NoReason
- (sep [ text "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled"
- , text "Defaulting to the DeriveAnyClass strategy for instantiating" <+> ppr cls ])
- go_for_it
+ = ASSERT( length cls_tys + 1 == classArity cls )
+ case deriv_strat of
+ Just DerivStock -> mk_eqn_stock dflags mtheta cls cls_tys rep_tycon
+ go_for_it_other bale_out
+ Just DerivAnyclass -> mk_eqn_anyclass dflags rep_tycon cls
+ go_for_it_other bale_out
+ Just DerivNewtype ->
+ -- Since the user explicitly asked for GeneralizedNewtypeDeriving, we
+ -- don't need to perform all of the checks we normally would, such as
+ -- if the class being derived is known to produce ill-roled coercions
+ -- (e.g., Traversable), since we can just derive the instance and let
+ -- it error if need be.
+ -- See Note [Determining whether newtype-deriving is appropriate]
+ if coercion_looks_sensible && newtype_deriving
+ then go_for_it_gnd
+ else bale_out (cant_derive_err $$
+ if newtype_deriving then empty else suggest_gnd)
+ Nothing
+ | might_derive_via_coercible
+ && ((newtype_deriving && not deriveAnyClass)
+ || std_class_via_coercible cls)
+ -> go_for_it_gnd
+ | otherwise
+ -> case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
+ DerivableClassError msg
+ -- There's a particular corner case where
+ --
+ -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are both
+ -- enabled at the same time
+ -- 2. We're deriving a particular stock derivable class
+ -- (such as Functor)
+ --
+ -- and the previous cases won't catch it. This fixes the bug
+ -- reported in Trac #10598.
+ | might_derive_via_coercible && newtype_deriving
+ -> go_for_it_gnd
+ -- Otherwise, throw an error for a stock class
+ | might_derive_via_coercible && not newtype_deriving
+ -> bale_out (msg $$ suggest_gnd)
+ | otherwise
+ -> bale_out msg
+
+ -- Must use newtype deriving or DeriveAnyClass
+ NonDerivableClass _msg
+ -- Too hard, even with newtype deriving
+ | newtype_deriving -> bale_out cant_derive_err
+ -- Try newtype deriving!
+ -- Here we suggest GeneralizedNewtypeDeriving even in cases where
+ -- it may not be applicable. See Trac #9600.
+ | otherwise -> bale_out (non_std $$ suggest_gnd)
+
+ -- DerivableViaInstance
+ DerivableViaInstance -> do
+ -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are
+ -- enabled, we take the diplomatic approach of defaulting to
+ -- DeriveAnyClass, but emitting a warning about the choice.
+ -- See Note [Deriving strategies]
+ when (newtype_deriving && deriveAnyClass) $
+ addWarnTc NoReason $ sep
+ [ text "Both DeriveAnyClass and"
+ <+> text "GeneralizedNewtypeDeriving are enabled"
+ , text "Defaulting to the DeriveAnyClass strategy"
+ <+> text "for instantiating" <+> ppr cls ]
+ go_for_it_other DerivSpecAnyClass
+ -- CanDerive
+ CanDerive -> mk_eqn_stock' cls go_for_it_other
where
newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags
deriveAnyClass = xopt LangExt.DeriveAnyClass dflags
- go_for_it = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args
- rep_tycon rep_tc_args mtheta
+ go_for_it_gnd = do
+ traceTc "newtype deriving:" $
+ ppr tycon <+> ppr rep_tys <+> ppr all_preds
+ dfun_name <- newDFunName' cls tycon
+ loc <- getSrcSpanM
+ case mtheta of
+ Just theta -> return $ GivenTheta $ DS
+ { ds_loc = loc
+ , ds_name = dfun_name, ds_tvs = dfun_tvs
+ , ds_cls = cls, ds_tys = inst_tys
+ , ds_tc = rep_tycon
+ , ds_theta = theta
+ , ds_overlap = overlap_mode
+ , ds_mechanism = DerivSpecNewtype rep_inst_ty }
+ Nothing -> return $ InferTheta $ DS
+ { ds_loc = loc
+ , ds_name = dfun_name, ds_tvs = dfun_tvs
+ , ds_cls = cls, ds_tys = inst_tys
+ , ds_tc = rep_tycon
+ , ds_theta = all_preds
+ , ds_overlap = overlap_mode
+ , ds_mechanism = DerivSpecNewtype rep_inst_ty }
+ go_for_it_other = mk_data_eqn overlap_mode tvs cls cls_tys tycon
+ tc_args rep_tycon rep_tc_args mtheta
bale_out = bale_out' newtype_deriving
bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty
+ deriv_strat
non_std = nonStdErr cls
suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension"
@@ -1785,9 +1933,9 @@ mkNewTypeEqn dflags overlap_mode tvs
-- See Note [Determining whether newtype-deriving is appropriate]
might_derive_via_coercible
= not (non_coercible_class cls)
- && eta_ok
- && ats_ok
+ && coercion_looks_sensible
-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
+ coercion_looks_sensible = eta_ok && ats_ok
-- Check that eta reduction is OK
eta_ok = nt_eta_arity <= length rep_tc_args
@@ -1835,6 +1983,18 @@ or do we do normal deriving? In general, we prefer to do newtype deriving
wherever possible. So, we try newtype deriving unless there's a glaring
reason not to.
+"Glaring reasons not to" include trying to derive a class for which a
+coercion-based instance doesn't make sense. These classes are listed in
+the definition of non_coercible_class. They include Show (since it must
+show the name of the datatype) and Traversable (since a coercion-based
+Traversable instance is ill-roled).
+
+However, non_coercible_class is ignored if the user explicitly requests
+to derive an instance with GeneralizedNewtypeDeriving using the newtype
+deriving strategy. In such a scenario, GHC will unquestioningly try to
+derive the instance via coercions (even if the final generated code is
+ill-roled!). See Note [Deriving strategies].
+
Note that newtype deriving might fail, even after we commit to it. This
is because the derived instance uses `coerce`, which must satisfy its
`Coercible` constraint. This is different than other deriving scenarios,
@@ -2262,15 +2422,19 @@ the renamer. What a great hack!
genInst :: DerivSpec ThetaType
-> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
- , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
+ , ds_theta = theta, ds_mechanism = mechanism, ds_tys = tys
, ds_cls = clas, ds_loc = loc })
- | Just rhs_ty <- is_newtype -- See Note [Bindings for Generalised Newtype Deriving]
+ -- See Note [Bindings for Generalised Newtype Deriving]
+ | DerivSpecNewtype rhs_ty <- mechanism
= do { inst_spec <- newDerivClsInst theta spec
+ ; doDerivInstErrorChecks clas inst_spec mechanism
; return ( InstInfo
{ iSpec = inst_spec
, iBinds = InstBindings
- { ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty
- , ib_tyvars = map Var.varName tvs -- Scope over bindings
+ { ib_binds = gen_Newtype_binds loc clas
+ tvs tys rhs_ty
+ -- Scope over bindings
+ , ib_tyvars = map Var.varName tvs
, ib_pragmas = []
, ib_extensions = [ LangExt.ImpredicativeTypes
, LangExt.RankNTypes ]
@@ -2280,58 +2444,78 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
, emptyBag
, Just $ getName $ head $ tyConDataCons rep_tycon ) }
-- See Note [Newtype deriving and unused constructors]
-
| otherwise
- = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas rep_tycon tys tvs
+ = do { (meth_binds, deriv_stuff) <- genDerivStuff mechanism loc clas
+ rep_tycon tys tvs
; inst_spec <- newDerivClsInst theta spec
+ ; doDerivInstErrorChecks clas inst_spec mechanism
; traceTc "newder" (ppr inst_spec)
- ; let inst_info = InstInfo { iSpec = inst_spec
- , iBinds = InstBindings
- { ib_binds = meth_binds
- , ib_tyvars = map Var.varName tvs
- , ib_pragmas = []
- , ib_extensions = []
- , ib_derived = True } }
+ ; let inst_info
+ = InstInfo { iSpec = inst_spec
+ , iBinds = InstBindings
+ { ib_binds = meth_binds
+ , ib_tyvars = map Var.varName tvs
+ , ib_pragmas = []
+ , ib_extensions = []
+ , ib_derived = True } }
; return ( inst_info, deriv_stuff, Nothing ) }
+doDerivInstErrorChecks :: Class -> ClsInst -> DerivSpecMechanism -> TcM ()
+doDerivInstErrorChecks clas clas_inst mechanism
+ = do { traceTc "doDerivInstErrorChecks" (ppr clas_inst)
+ ; dflags <- getDynFlags
+ -- Check for Generic instances that are derived with an exotic
+ -- deriving strategy like DAC
+ -- See Note [Deriving strategies]
+ ; when (exotic_mechanism && className clas `elem` genericClassNames) $
+ do { failIfTc (safeLanguageOn dflags) gen_inst_err
+ ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }
+ where
+ exotic_mechanism = case mechanism of
+ DerivSpecGeneric _ -> False
+ _ -> True
+
+ gen_inst_err = hang (text ("Generic instances can only be derived in "
+ ++ "Safe Haskell using the stock strategy.") $+$
+ text "In the following instance:")
+ 2 (pprInstanceHdr clas_inst)
+
-- Generate the bindings needed for a derived class that isn't handled by
-- -XGeneralizedNewtypeDeriving.
-genDerivStuff :: SrcSpan -> Class -> TyCon -> [Type] -> [TyVar]
+genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
+ -> TyCon -> [Type] -> [TyVar]
-> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc clas tycon inst_tys tyvars
- -- Special case for DeriveGeneric
- | let ck = classKey clas
- , ck `elem` [genClassKey, gen1ClassKey]
- = let gk = if ck == genClassKey then Gen0 else Gen1
+genDerivStuff mechanism loc clas tycon inst_tys tyvars
+ = case mechanism of
+ -- Special case for DeriveGeneric, since it's monadic
+ DerivSpecGeneric gen_fn -> do
-- TODO NSF: correctly identify when we're building Both instead of One
- in do
- (binds, faminst) <- gen_Generic_binds gk tycon inst_tys
- return (binds, unitBag (DerivFamInst faminst))
+ (binds, faminst) <- gen_fn tycon inst_tys
+ return (binds, unitBag (DerivFamInst faminst))
- -- Not deriving Generic(1), so we first check if the compiler has built-in
- -- support for deriving the class in question.
- | Just gen_fn <- hasBuiltinDeriving clas
- = gen_fn loc tycon
+ -- The rest of the stock derivers
+ DerivSpecStock gen_fn -> gen_fn loc tycon
- | otherwise
- = do { -- If there isn't compiler support for deriving the class, our last
- -- resort is -XDeriveAnyClass (since -XGeneralizedNewtypeDeriving
- -- fell through).
+ -- If there isn't compiler support for deriving the class, our last
+ -- resort is -XDeriveAnyClass (since -XGeneralizedNewtypeDeriving
+ -- fell through).
+ DerivSpecAnyClass -> do
let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
-
- ; dflags <- getDynFlags
- ; tyfam_insts <-
- ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
- , ppr "genDerivStuff: bad derived class" <+> ppr clas )
- mapM (tcATDefault False loc mini_subst emptyNameSet)
- (classATItems clas)
- ; return ( emptyBag -- No method bindings are needed...
- , listToBag (map DerivFamInst (concat tyfam_insts))
- -- ...but we may need to generate binding for associated type
- -- family default instances.
- -- See Note [DeriveAnyClass and default family instances]
- ) }
+ dflags <- getDynFlags
+ tyfam_insts <-
+ ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
+ , ppr "genDerivStuff: bad derived class" <+> ppr clas )
+ mapM (tcATDefault False loc mini_subst emptyNameSet)
+ (classATItems clas)
+ return ( emptyBag -- No method bindings are needed...
+ , listToBag (map DerivFamInst (concat tyfam_insts))
+ -- ...but we may need to generate binding for associated type
+ -- family default instances.
+ -- See Note [DeriveAnyClass and default family instances]
+ )
+
+ _ -> panic "genDerivStuff"
{-
Note [Bindings for Generalised Newtype Deriving]
@@ -2380,6 +2564,54 @@ an implementation for them. We "fill in" the default instances using the
tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle
the empty instance declaration case).
+Note [Deriving strategies]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC has a notion of deriving strategies, which allow the user to explicitly
+request which approach to use when deriving an instance (enabled with the
+-XDerivingStrategies language extension). For more information, refer to the
+original Trac ticket (#10598) or the associated wiki page:
+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies
+
+A deriving strategy can be specified in a deriving clause:
+
+ newtype Foo = MkFoo Bar
+ deriving newtype C
+
+Or in a standalone deriving declaration:
+
+ deriving anyclass instance C Foo
+
+-XDerivingStrategies also allows the use of multiple deriving clauses per data
+declaration so that a user can derive some instance with one deriving strategy
+and other instances with another deriving strategy. For example:
+
+ newtype Baz = Baz Quux
+ deriving (Eq, Ord)
+ deriving stock (Read, Show)
+ deriving newtype (Num, Floating)
+ deriving anyclass C
+
+Currently, the deriving strategies are:
+
+* stock: Have GHC implement a "standard" instance for a data type, if possible
+ (e.g., Eq, Ord, Generic, Data, Functor, etc.)
+
+* anyclass: Use -XDeriveAnyClass
+
+* newtype: Use -XGeneralizedNewtypeDeriving
+
+If an explicit deriving strategy is not given, GHC has an algorithm it uses to
+determine which strategy it will actually use. The algorithm is quite long,
+so it lives in the Haskell wiki at
+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies
+("The deriving strategy resolution algorithm" section).
+
+Internally, GHC uses the DerivStrategy datatype to denote a user-requested
+deriving strategy, and it uses the DerivSpecMechanism datatype to denote what
+GHC will use to derive the instance after taking the above steps. In other
+words, GHC will always settle on a DerivSpecMechnism, even if the user did not
+ask for a particular DerivStrategy (using the algorithm linked to above).
+
************************************************************************
* *
\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
@@ -2411,16 +2643,22 @@ derivingEtaErr cls cls_tys inst_ty
nest 2 (text "instance (...) =>"
<+> pprClassPred cls (cls_tys ++ [inst_ty]))]
-derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc
-derivingThingErr newtype_deriving clas tys ty why
+derivingThingErr :: Bool -> Class -> [Type] -> Type -> Maybe DerivStrategy
+ -> MsgDoc -> MsgDoc
+derivingThingErr newtype_deriving clas tys ty deriv_strat why
= sep [(hang (text "Can't make a derived instance of")
- 2 (quotes (ppr pred))
+ 2 (quotes (ppr pred) <+> via_mechanism)
$$ nest 2 extra) <> colon,
nest 2 why]
where
- extra | newtype_deriving = text "(even with cunning GeneralizedNewtypeDeriving)"
- | otherwise = Outputable.empty
+ extra | Nothing <- deriv_strat, newtype_deriving
+ = text "(even with cunning GeneralizedNewtypeDeriving)"
+ | otherwise = Outputable.empty
pred = mkClassPred clas (tys ++ [ty])
+ via_mechanism = case deriv_strat of
+ Just strat -> text "with the" <+> ppr strat
+ <+> text "strategy"
+ Nothing -> empty
derivingHiddenErr :: TyCon -> SDoc
derivingHiddenErr tc
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index e7d7bd3143..0a5fbb0cf9 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -18,7 +18,7 @@ This is where we do all the grimy bindings' generation.
module TcGenDeriv (
BagDerivStuff, DerivStuff(..),
- hasBuiltinDeriving,
+ hasStockDeriving,
FFoldType(..), functorLikeTraverse,
deepSubtypesContaining, foldDataConArgs,
mkCoerceClassMethEqn,
@@ -102,20 +102,25 @@ data DerivStuff -- Please add this auxiliary stuff
* *
************************************************************************
-Only certain blessed classes can be used in a deriving clause. These classes
-are listed below in the definition of hasBuiltinDeriving (with the exception
+Only certain blessed classes can be used in a deriving clause (without the
+assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
+are listed below in the definition of hasStockDeriving (with the exception
of Generic and Generic1, which are handled separately in TcGenGenerics).
-A class might be able to be used in a deriving clause if it -XDeriveAnyClass
-is willing to support it. The canDeriveAnyClass function checks if this is
-the case.
+A class might be able to be used in a deriving clause if -XDeriveAnyClass
+is willing to support it. The canDeriveAnyClass function in TcDeriv checks
+if this is the case.
-}
-hasBuiltinDeriving :: Class
+-- NB: The classes listed below should be in sync with the ones listed in
+-- the definition of sideConditions in TcDeriv (except for Generic(1), as
+-- noted above). If you add a new class to hasStockDeriving, make sure to
+-- update sideConditions as well!
+hasStockDeriving :: Class
-> Maybe (SrcSpan
-> TyCon
-> TcM (LHsBinds RdrName, BagDerivStuff))
-hasBuiltinDeriving clas
+hasStockDeriving clas
= assocMaybe gen_list (getUnique clas)
where
gen_list :: [(Unique, SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff))]
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 96d7493f79..2e7104cef8 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -683,11 +683,11 @@ tcDataFamInstDecl mb_clsinfo
; checkValidTyCon rep_tc
; let m_deriv_info = case derivs of
- Nothing -> Nothing
- Just (L _ preds) ->
- Just $ DerivInfo { di_rep_tc = rep_tc
- , di_preds = preds
- , di_ctxt = tcMkDataFamInstCtxt decl }
+ L _ [] -> Nothing
+ L _ preds ->
+ Just $ DerivInfo { di_rep_tc = rep_tc
+ , di_clauses = preds
+ , di_ctxt = tcMkDataFamInstCtxt decl }
; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
; return (fam_inst, m_deriv_info) } }
View Lorry Controller Status