diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2016-09-30 20:15:25 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2016-09-30 23:23:44 -0400 |
| commit | 9e862765ffe161da8a4fd9cd67b0a600874feaa9 (patch) | |
| tree | 235c1ba702b0101e1fa6a8fe7f8146e2c7ec9c69 | |
| parent | b3d55e20d20344bfc09f4ca4a554a819c4ecbfa8 (diff) | |
| download | haskell-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
68 files changed, 1235 insertions, 404 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) } } diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst index 87bc97f768..3e13f57c57 100644 --- a/docs/users_guide/8.2.1-notes.rst +++ b/docs/users_guide/8.2.1-notes.rst @@ -38,6 +38,10 @@ Compiler syntax can be used, in addition to a new form for specifying the cost centre name. See :ref:`scc-pragma` for examples. +- It is now possible to explicitly pick a strategy to use when deriving a + class instance using the :ghc-flag:`-XDerivingStrategies` language extension + (see :ref:`deriving-strategies`). + GHCi ~~~~ diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index b41a09a097..bcfef017e1 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -3955,10 +3955,10 @@ usually have one "main" parameter for which deriving new instances is most interesting. Lastly, all of this applies only for classes other than ``Read``, -``Show``, ``Typeable``, and ``Data``, for which the built-in derivation +``Show``, ``Typeable``, and ``Data``, for which the stock derivation applies (section 4.3.3. of the Haskell Report). (For the standard classes ``Eq``, ``Ord``, ``Ix``, and ``Bounded`` it is immaterial -whether the standard method is used or the one described here.) +whether the stock method is used or the one described here.) .. _derive-any-class: @@ -4064,6 +4064,64 @@ Note the following details and then the normal rules for filling in associated types from the default will apply, making ``Size Bar`` equal to ``Int``. +.. _deriving-strategies: + +Deriving strategies +------------------- + +In most scenarios, every ``deriving`` statement generates a typeclass instance +in an unambiguous fashion. There is a corner case, however, where +simultaneously enabling both the :ghc-flag:`-XGeneralizedNewtypeDeriving` and +:ghc-flag:`-XDeriveAnyClass` extensions can make deriving become ambiguous. +Consider the following example :: + + {-# LANGUAGE DeriveAnyClass, GeneralizedNewtypeDeriving #-} + newtype Foo = MkFoo Bar deriving C + +One could either pick the ``DeriveAnyClass`` approach to deriving ``C`` or the +``GeneralizedNewtypeDeriving`` approach to deriving ``C``, both of which would +be equally as valid. GHC defaults to favoring ``DeriveAnyClass`` in such a +dispute, but this is not a satisfying solution, since that leaves users unable +to use both language extensions in a single module. + +To make this more robust, GHC has a notion of deriving strategies, which allow +the user to explicitly request which approach to use when deriving an instance. +To enable this feature, one must enable the :ghc-flag:`-XDerivingStrategies` +language extension. 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 + +:ghc-flag:`-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 :ghc-flag:`-XDeriveAnyClass` + +- ``newtype``: Use :ghc-flag:`-XGeneralizedNewtypeDeriving` + +If an explicit deriving strategy is not given, GHC has an algorithm for +determining how it will actually derive an instance. For brevity, the algorithm +is omitted here. You can read the full algorithm at +:ghc-wiki:`Wiki page <DerivingStrategies>`. + .. _pattern-synonyms: Pattern synonyms diff --git a/docs/users_guide/safe_haskell.rst b/docs/users_guide/safe_haskell.rst index 6ce8b8fc26..653b741339 100644 --- a/docs/users_guide/safe_haskell.rst +++ b/docs/users_guide/safe_haskell.rst @@ -284,7 +284,12 @@ Furthermore, we restrict the following features: the structure of the data type for which the instance is defined, and allowing manually implemented ``Generic`` instances would break that invariant. Derived instances (through the :ghc-flag:`-XDeriveGeneric` - extension) are still allowed. Refer to the + extension) are still allowed. Note that the only allowed + :ref:`deriving strategy <deriving-strategies>` for deriving ``Generic`` under + Safe Haskell is ``stock``, as another strategy (e.g., ``anyclass``) would + produce an instance that violates the invariant. + + Refer to the :ref:`generic programming <generic-programming>` section for more details. .. _safe-overlapping-instances: diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index 85664c2144..ff26ec6ce7 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -80,6 +80,7 @@ data Extension | DefaultSignatures -- Allow extra signatures for defmeths | DeriveAnyClass -- Allow deriving any class | DeriveLift -- Allow deriving Lift + | DerivingStrategies | TypeSynonymInstances | FlexibleContexts diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs index 0bdc756870..e93095662e 100644 --- a/libraries/ghci/GHCi/TH/Binary.hs +++ b/libraries/ghci/GHCi/TH/Binary.hs @@ -30,6 +30,8 @@ instance Binary TH.Pat instance Binary TH.Exp instance Binary TH.Dec instance Binary TH.Overlap +instance Binary TH.DerivClause +instance Binary TH.DerivStrategy instance Binary TH.Guard instance Binary TH.Body instance Binary TH.Match diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 7cf342a460..bde698eaa3 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -85,11 +85,11 @@ module Language.Haskell.TH( -- * Library functions -- ** Abbreviations - InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ, - ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ, - SourceUnpackednessQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, - VarStrictTypeQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, - PatSynArgsQ, + InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, + DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, + SourceStrictnessQ, SourceUnpackednessQ, BangTypeQ, VarBangTypeQ, + StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, + PatSynDirQ, PatSynArgsQ, -- ** Constructors lifted to 'Q' -- *** Literals @@ -144,9 +144,10 @@ module Language.Haskell.TH( -- *** Top Level Declarations -- **** Data valD, funD, tySynD, dataD, newtypeD, + derivClause, DerivClause(..), DerivStrategy(..), -- **** Class classD, instanceD, instanceWithOverlapD, Overlap(..), - sigD, standaloneDerivD, defaultSigD, + sigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, -- **** Role annotations roleAnnotD, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 2631c0e32d..c42543863d 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -30,6 +30,7 @@ type TypeQ = Q Type type TyLitQ = Q TyLit type CxtQ = Q Cxt type PredQ = Q Pred +type DerivClauseQ = Q DerivClause type MatchQ = Q Match type ClauseQ = Q Clause type BodyQ = Q Body @@ -360,20 +361,22 @@ funD nm cs = tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ +dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] + -> DecQ dataD ctxt tc tvs ksig cons derivs = do ctxt1 <- ctxt cons1 <- sequence cons - derivs1 <- derivs + derivs1 <- sequence derivs return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> CxtQ -> DecQ +newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> [DerivClauseQ] + -> DecQ newtypeD ctxt tc tvs ksig con derivs = do ctxt1 <- ctxt con1 <- con - derivs1 <- derivs + derivs1 <- sequence derivs return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ @@ -452,22 +455,24 @@ pragAnnD target expr pragLineD :: Int -> String -> DecQ pragLineD line file = return $ PragmaD $ LineP line file -dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ +dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] + -> DecQ dataInstD ctxt tc tys ksig cons derivs = do ctxt1 <- ctxt tys1 <- sequence tys cons1 <- sequence cons - derivs1 <- derivs + derivs1 <- sequence derivs return (DataInstD ctxt1 tc tys1 ksig cons1 derivs1) -newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> CxtQ -> DecQ +newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ] + -> DecQ newtypeInstD ctxt tc tys ksig con derivs = do ctxt1 <- ctxt tys1 <- sequence tys con1 <- con - derivs1 <- derivs + derivs1 <- sequence derivs return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1) tySynInstD :: Name -> TySynEqnQ -> DecQ @@ -534,11 +539,14 @@ roleAnnotD :: Name -> [Role] -> DecQ roleAnnotD name roles = return $ RoleAnnotD name roles standaloneDerivD :: CxtQ -> TypeQ -> DecQ -standaloneDerivD ctxtq tyq = +standaloneDerivD = standaloneDerivWithStrategyD Nothing + +standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD ds ctxtq tyq = do ctxt <- ctxtq ty <- tyq - return $ StandaloneDerivD ctxt ty + return $ StandaloneDerivD ds ctxt ty defaultSigD :: Name -> TypeQ -> DecQ defaultSigD n tyq = @@ -570,6 +578,10 @@ tySynEqn lhs rhs = cxt :: [PredQ] -> CxtQ cxt = sequence +derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ +derivClause ds p = do p' <- cxt p + return $ DerivClause ds p' + normalC :: Name -> [BangTypeQ] -> ConQ normalC con strtys = liftM (NormalC con) $ sequence strtys diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 7376135ed0..8941a8ba81 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -358,8 +358,12 @@ ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns) = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs ppr_dec _ (RoleAnnotD name roles) = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) -ppr_dec _ (StandaloneDerivD cxt ty) - = hsep [ text "deriving instance", pprCxt cxt, ppr ty ] +ppr_dec _ (StandaloneDerivD ds cxt ty) + = hsep [ text "deriving" + , maybe empty ppr_deriv_strategy ds + , text "instance" + , pprCxt cxt + , ppr ty ] ppr_dec _ (DefaultSigD n ty) = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ] ppr_dec _ (PatSynD name args dir pat) @@ -373,6 +377,12 @@ ppr_dec _ (PatSynD name args dir pat) ppr_dec _ (PatSynSigD name ty) = pprPatSynSig name ty +ppr_deriv_strategy :: DerivStrategy -> Doc +ppr_deriv_strategy ds = text $ + case ds of + Stock -> "stock" + Anyclass -> "anyclass" + Newtype -> "newtype" ppr_overlap :: Overlap -> Doc ppr_overlap o = text $ @@ -382,7 +392,8 @@ ppr_overlap o = text $ Overlapping -> "{-# OVERLAPPING #-}" Incoherent -> "{-# INCOHERENT #-}" -ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc +ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] + -> Doc ppr_data maybeInst ctxt t argsDoc ksig cs decs = sep [text "data" <+> maybeInst <+> pprCxt ctxt @@ -391,7 +402,7 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs if null decs then empty else nest nestDepth - $ text "deriving" <+> ppr_cxt_preds decs] + $ vcat $ map ppr_deriv_clause decs] where pref :: [Doc] -> [Doc] pref xs | isGadtDecl = xs @@ -413,7 +424,8 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs Nothing -> empty Just k -> dcolon <+> ppr k -ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> Cxt -> Doc +ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> [DerivClause] + -> Doc ppr_newtype maybeInst ctxt t argsDoc ksig c decs = sep [text "newtype" <+> maybeInst <+> pprCxt ctxt @@ -422,12 +434,17 @@ ppr_newtype maybeInst ctxt t argsDoc ksig c decs if null decs then empty else nest nestDepth - $ text "deriving" <+> ppr_cxt_preds decs] + $ vcat $ map ppr_deriv_clause decs] where ksigDoc = case ksig of Nothing -> empty Just k -> dcolon <+> ppr k +ppr_deriv_clause :: DerivClause -> Doc +ppr_deriv_clause (DerivClause ds ctxt) + = text "deriving" <+> maybe empty ppr_deriv_strategy ds + <+> ppr_cxt_preds ctxt + ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 00ac0b308b..afe961b50e 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1549,13 +1549,15 @@ data Dec | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@ | DataD Cxt Name [TyVarBndr] (Maybe Kind) -- Kind signature (allowed only for GADTs) - [Con] Cxt + [Con] [DerivClause] -- ^ @{ data Cxt x => T x = A x | B (T x) - -- deriving (Z,W)}@ + -- deriving (Z,W) + -- deriving stock Eq }@ | NewtypeD Cxt Name [TyVarBndr] (Maybe Kind) -- Kind signature - Con Cxt -- ^ @{ newtype Cxt x => T x = A (B x) - -- deriving (Z,W Q)}@ + Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x) + -- deriving (Z,W Q) + -- deriving stock Eq }@ | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@ | ClassD Cxt Name [TyVarBndr] [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ @@ -1578,14 +1580,18 @@ data Dec | DataInstD Cxt Name [Type] (Maybe Kind) -- Kind signature - [Con] Cxt -- ^ @{ data instance Cxt x => T [x] - -- = A x | B (T x) deriving (Z,W)}@ + [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x] + -- = A x | B (T x) + -- deriving (Z,W) + -- deriving stock Eq }@ | NewtypeInstD Cxt Name [Type] - (Maybe Kind) -- Kind signature - Con Cxt -- ^ @{ newtype instance Cxt x => T [x] - -- = A (B x) deriving (Z,W)}@ - | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ + (Maybe Kind) -- Kind signature + Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x] + -- = A (B x) + -- deriving (Z,W) + -- deriving stock Eq }@ + | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') | OpenTypeFamilyD TypeFamilyHead @@ -1595,7 +1601,8 @@ data Dec -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@ | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@ - | StandaloneDerivD Cxt Type -- ^ @{ deriving instance Ord a => Ord (Foo a) }@ + | StandaloneDerivD (Maybe DerivStrategy) Cxt Type + -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@ | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@ -- | Pattern Synonyms @@ -1620,6 +1627,17 @@ data Overlap = Overlappable -- ^ May be overlapped by more specific instances -- available. deriving( Show, Eq, Ord, Data, Generic ) +-- | A single @deriving@ clause at the end of a datatype. +data DerivClause = DerivClause (Maybe DerivStrategy) Cxt + -- ^ @{ deriving stock (Eq, Ord) }@ + deriving( Show, Eq, Ord, Data, Generic ) + +-- | What the user explicitly requests when deriving an instance. +data DerivStrategy = Stock -- ^ A \"standard\" derived instance + | Anyclass -- ^ @-XDeriveAnyClass@ + | Newtype -- ^ @-XGeneralizedNewtypeDeriving@ + deriving( Show, Eq, Ord, Data, Generic ) + -- | A Pattern synonym's type. Note that a pattern synonym's *fully* -- specified type has a peculiar shape coming with two forall -- quantifiers and two constraint contexts. For example, consider the diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index e23fbf7db1..19038c755e 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -12,6 +12,9 @@ * Add support for visible type applications. (#12530) + * Add support for attaching deriving strategies to `deriving` statements + (#10598) + ## 2.11.0.0 *May 2016* * Bundled with GHC 8.0.1 diff --git a/testsuite/driver/extra_files.py b/testsuite/driver/extra_files.py index 5af9695885..3f1e75b644 100644 --- a/testsuite/driver/extra_files.py +++ b/testsuite/driver/extra_files.py @@ -50,6 +50,7 @@ extra_src_files = { 'T10529c': ['.hpc/', 'hpc_sample_no_parse.tix'], 'T10576a': ['T10576.hs'], 'T10576b': ['T10576.hs'], + 'T10598': ['Test10598.hs'], 'T10637': ['A.hs', 'A.hs-boot'], 'T10672_x64': ['Main.hs', 'Printf.hs', 'cxxy.cpp'], 'T10672_x86': ['Main.hs', 'Printf.hs', 'cxxy.cpp'], diff --git a/testsuite/tests/deriving/should_fail/T10598_fail1.hs b/testsuite/tests/deriving/should_fail/T10598_fail1.hs new file mode 100644 index 0000000000..ee488869a4 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module T10598_fail1 where + +class Z f where + z :: f a b + +data A = A Int deriving newtype Show +newtype B = B Int deriving stock Num +data C a b = C Int deriving anyclass Z diff --git a/testsuite/tests/deriving/should_fail/T10598_fail1.stderr b/testsuite/tests/deriving/should_fail/T10598_fail1.stderr new file mode 100644 index 0000000000..0183ec515d --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail1.stderr @@ -0,0 +1,17 @@ + +T10598_fail1.hs:9:40: error: + • Can't make a derived instance of + ‘Show A’ with the newtype strategy: + GeneralizedNewtypeDeriving cannot be used on non-newtypes + • In the data declaration for ‘A’ + +T10598_fail1.hs:10:40: error: + • Can't make a derived instance of ‘Num B’ with the stock strategy: + ‘Num’ is not a stock derivable class (Eq, Show, etc.) + • In the newtype declaration for ‘B’ + +T10598_fail1.hs:11:41: error: + • Can't make a derived instance of + ‘Z C’ with the anyclass strategy: + The last argument of class ‘Z’ does not have kind * or (* -> *) + • In the data declaration for ‘C’ diff --git a/testsuite/tests/deriving/should_fail/T10598_fail2.hs b/testsuite/tests/deriving/should_fail/T10598_fail2.hs new file mode 100644 index 0000000000..ba77fe0fbf --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} +module T10598_fail2 where + +data A = A Int deriving anyclass Eq +newtype B = B Int deriving newtype Eq diff --git a/testsuite/tests/deriving/should_fail/T10598_fail2.stderr b/testsuite/tests/deriving/should_fail/T10598_fail2.stderr new file mode 100644 index 0000000000..5ddd81dd1e --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail2.stderr @@ -0,0 +1,12 @@ + +T10598_fail2.hs:4:37: error: + • Can't make a derived instance of + ‘Eq A’ with the anyclass strategy: + Try enabling DeriveAnyClass + • In the data declaration for ‘A’ + +T10598_fail2.hs:5:37: error: + • Can't make a derived instance of + ‘Eq B’ with the newtype strategy: + Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension + • In the newtype declaration for ‘B’ diff --git a/testsuite/tests/deriving/should_fail/T10598_fail3.hs b/testsuite/tests/deriving/should_fail/T10598_fail3.hs new file mode 100644 index 0000000000..23f9ad987f --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail3.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE Safe #-} +module T10598_fail3 where + +import GHC.Generics + +data T = MkT Int deriving anyclass Generic diff --git a/testsuite/tests/deriving/should_fail/T10598_fail3.stderr b/testsuite/tests/deriving/should_fail/T10598_fail3.stderr new file mode 100644 index 0000000000..a987a4993d --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail3.stderr @@ -0,0 +1,5 @@ + +T10598_fail3.hs:1:1: error: + Generic instances can only be derived in Safe Haskell using the stock strategy. + In the following instance: + instance [safe] Generic T diff --git a/testsuite/tests/deriving/should_fail/T10598_fail4.hs b/testsuite/tests/deriving/should_fail/T10598_fail4.hs new file mode 100644 index 0000000000..911111c8ea --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail4.hs @@ -0,0 +1,4 @@ +module T10598_fail4 where + +data Bar = Bar + deriving stock Eq diff --git a/testsuite/tests/deriving/should_fail/T10598_fail4.stderr b/testsuite/tests/deriving/should_fail/T10598_fail4.stderr new file mode 100644 index 0000000000..7d724d07bd --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail4.stderr @@ -0,0 +1,4 @@ + +T10598_fail4.hs:3:1: error: + Illegal deriving strategy: stock + Use DerivingStrategies to enable this extension diff --git a/testsuite/tests/deriving/should_fail/T10598_fail5.hs b/testsuite/tests/deriving/should_fail/T10598_fail5.hs new file mode 100644 index 0000000000..74f57fd307 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail5.hs @@ -0,0 +1,5 @@ +module T10598_fail5 where + +data Foo = Foo + deriving Eq + deriving Ord diff --git a/testsuite/tests/deriving/should_fail/T10598_fail5.stderr b/testsuite/tests/deriving/should_fail/T10598_fail5.stderr new file mode 100644 index 0000000000..af38cdcc51 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail5.stderr @@ -0,0 +1,4 @@ + +T10598_fail5.hs:3:1: error: + Illegal use of multiple, consecutive deriving clauses + Use DerivingStrategies to allow this diff --git a/testsuite/tests/deriving/should_fail/T10598_fail6.hs b/testsuite/tests/deriving/should_fail/T10598_fail6.hs new file mode 100644 index 0000000000..673bfcc971 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail6.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module T10598_fail6 where + +newtype F x = F ([x], Maybe x) deriving Functor diff --git a/testsuite/tests/deriving/should_fail/T10598_fail6.stderr b/testsuite/tests/deriving/should_fail/T10598_fail6.stderr new file mode 100644 index 0000000000..a80e5bab56 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T10598_fail6.stderr @@ -0,0 +1,6 @@ + +T10598_fail6.hs:5:41: error: + • Can't make a derived instance of ‘Functor F’ + (even with cunning GeneralizedNewtypeDeriving): + You need DeriveFunctor to derive an instance for this class + • In the newtype declaration for ‘F’ diff --git a/testsuite/tests/deriving/should_fail/T3833.stderr b/testsuite/tests/deriving/should_fail/T3833.stderr index da7da919bc..bf9a59cb8a 100644 --- a/testsuite/tests/deriving/should_fail/T3833.stderr +++ b/testsuite/tests/deriving/should_fail/T3833.stderr @@ -1,6 +1,6 @@ T3833.hs:9:1: error: Can't make a derived instance of ‘Monoid (DecodeMap e)’: - ‘Monoid’ is not a standard derivable class (Eq, Show, etc.) + ‘Monoid’ is not a stock derivable class (Eq, Show, etc.) Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension In the stand-alone deriving instance for ‘Monoid (DecodeMap e)’ diff --git a/testsuite/tests/deriving/should_fail/T3834.stderr b/testsuite/tests/deriving/should_fail/T3834.stderr index 3eec64a6c5..9d2223e1f8 100644 --- a/testsuite/tests/deriving/should_fail/T3834.stderr +++ b/testsuite/tests/deriving/should_fail/T3834.stderr @@ -1,6 +1,6 @@ T3834.hs:8:1: error: Can't make a derived instance of ‘C T’: - ‘C’ is not a standard derivable class (Eq, Show, etc.) + ‘C’ is not a stock derivable class (Eq, Show, etc.) Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension In the stand-alone deriving instance for ‘C T’ diff --git a/testsuite/tests/deriving/should_fail/T9600.stderr b/testsuite/tests/deriving/should_fail/T9600.stderr index 2e88277f54..5c03f2efc2 100644 --- a/testsuite/tests/deriving/should_fail/T9600.stderr +++ b/testsuite/tests/deriving/should_fail/T9600.stderr @@ -1,6 +1,6 @@ T9600.hs:3:39: error: Can't make a derived instance of ‘Applicative Foo’: - ‘Applicative’ is not a standard derivable class (Eq, Show, etc.) + ‘Applicative’ is not a stock derivable class (Eq, Show, etc.) Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension In the newtype declaration for ‘Foo’ diff --git a/testsuite/tests/deriving/should_fail/T9968a.stderr b/testsuite/tests/deriving/should_fail/T9968a.stderr index 9f52b2efa9..a72563162e 100644 --- a/testsuite/tests/deriving/should_fail/T9968a.stderr +++ b/testsuite/tests/deriving/should_fail/T9968a.stderr @@ -1,6 +1,6 @@ T9968a.hs:8:13: error: • Can't make a derived instance of ‘Bifunctor Blah’: - ‘Bifunctor’ is not a standard derivable class (Eq, Show, etc.) + ‘Bifunctor’ is not a stock derivable class (Eq, Show, etc.) The last argument of class ‘Bifunctor’ does not have kind * or (* -> *) • In the data declaration for ‘Blah’ diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T index bcb410b6ef..aebfa9e470 100644 --- a/testsuite/tests/deriving/should_fail/all.T +++ b/testsuite/tests/deriving/should_fail/all.T @@ -58,4 +58,10 @@ test('T9687', normal, compile_fail, ['']) test('T8984', normal, compile_fail, ['']) test('T9968a', normal, compile_fail, ['']) +test('T10598_fail1', normal, compile_fail, ['']) +test('T10598_fail2', normal, compile_fail, ['']) +test('T10598_fail3', normal, compile_fail, ['']) +test('T10598_fail4', normal, compile_fail, ['']) +test('T10598_fail5', normal, compile_fail, ['']) +test('T10598_fail6', normal, compile_fail, ['']) test('T12163', normal, compile_fail, ['']) diff --git a/testsuite/tests/deriving/should_fail/drvfail008.stderr b/testsuite/tests/deriving/should_fail/drvfail008.stderr index bfa73927c9..dcd43eca62 100644 --- a/testsuite/tests/deriving/should_fail/drvfail008.stderr +++ b/testsuite/tests/deriving/should_fail/drvfail008.stderr @@ -1,6 +1,6 @@ drvfail008.hs:10:43: error: • Can't make a derived instance of ‘Monad M’: - ‘Monad’ is not a standard derivable class (Eq, Show, etc.) + ‘Monad’ is not a stock derivable class (Eq, Show, etc.) Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘M’ diff --git a/testsuite/tests/deriving/should_run/T10598_bug.hs b/testsuite/tests/deriving/should_run/T10598_bug.hs new file mode 100644 index 0000000000..e34d2c24ee --- /dev/null +++ b/testsuite/tests/deriving/should_run/T10598_bug.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Main where + +newtype MyMaybe a = MyMaybe (Maybe a) + deriving (Functor, Show) + +main :: IO () +main = print $ fmap (+1) $ MyMaybe $ Just (10 :: Int) diff --git a/testsuite/tests/deriving/should_run/T10598_bug.stdout b/testsuite/tests/deriving/should_run/T10598_bug.stdout new file mode 100644 index 0000000000..31d7367d82 --- /dev/null +++ b/testsuite/tests/deriving/should_run/T10598_bug.stdout @@ -0,0 +1 @@ +MyMaybe (Just 11) diff --git a/testsuite/tests/deriving/should_run/T10598_run.hs b/testsuite/tests/deriving/should_run/T10598_run.hs new file mode 100644 index 0000000000..96238d70f8 --- /dev/null +++ b/testsuite/tests/deriving/should_run/T10598_run.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +module Main where + +import Data.Proxy + +class C a where + c :: proxy a -> Int + c _ = 42 + +instance C Int where + c _ = 27 + +newtype Foo = MkFoo Int + deriving Eq + deriving anyclass C +deriving newtype instance Show Foo + +main :: IO () +main = do + print $ MkFoo 100 + print $ c (Proxy :: Proxy Foo) diff --git a/testsuite/tests/deriving/should_run/T10598_run.stdout b/testsuite/tests/deriving/should_run/T10598_run.stdout new file mode 100644 index 0000000000..74a3087e37 --- /dev/null +++ b/testsuite/tests/deriving/should_run/T10598_run.stdout @@ -0,0 +1,2 @@ +100 +42 diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T index 29e8bbd250..ede2f90140 100644 --- a/testsuite/tests/deriving/should_run/all.T +++ b/testsuite/tests/deriving/should_run/all.T @@ -40,5 +40,7 @@ test('T9576', exit_code(1), compile_and_run, ['']) test('T9830', extra_clean(['T9830a.hi', 'T9830a.o']), multimod_compile_and_run, ['T9830','-v0']) test('T10104', normal, compile_and_run, ['']) test('T10447', normal, compile_and_run, ['']) +test('T10598_bug', normal, compile_and_run, ['']) +test('T10598_run', normal, compile_and_run, ['']) test('T11535', when(opsys('mingw32'), expect_broken_for(12210, ['ghci'])), compile_and_run, ['']) diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 45e257e4ec..0bef4c5632 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -40,7 +40,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", "TypeFamilyDependencies", - "UnboxedSums"] + "UnboxedSums", + "DerivingStrategies"] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", diff --git a/testsuite/tests/generics/T5462No1.stderr b/testsuite/tests/generics/T5462No1.stderr index 7c1aec8d79..c82f1b86ee 100644 --- a/testsuite/tests/generics/T5462No1.stderr +++ b/testsuite/tests/generics/T5462No1.stderr @@ -3,18 +3,18 @@ T5462No1.hs:24:42: error: Can't make a derived instance of ‘GFunctor F’: - ‘GFunctor’ is not a standard derivable class (Eq, Show, etc.) + ‘GFunctor’ is not a stock derivable class (Eq, Show, etc.) Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension In the newtype declaration for ‘F’ T5462No1.hs:26:23: error: Can't make a derived instance of ‘C1 G’: - ‘C1’ is not a standard derivable class (Eq, Show, etc.) + ‘C1’ is not a stock derivable class (Eq, Show, etc.) Try enabling DeriveAnyClass In the data declaration for ‘G’ T5462No1.hs:27:23: error: Can't make a derived instance of ‘C2 H’: - ‘C2’ is not a standard derivable class (Eq, Show, etc.) + ‘C2’ is not a stock derivable class (Eq, Show, etc.) Try enabling DeriveAnyClass In the data declaration for ‘H’ diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile index c557c66624..158dadb72c 100644 --- a/testsuite/tests/ghc-api/annotations/Makefile +++ b/testsuite/tests/ghc-api/annotations/Makefile @@ -112,6 +112,10 @@ T11018: T10276: $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10276.hs +.PHONY: T10598 +T10598: + $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10598.hs + .PHONY: T11321 T11321: $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11321.hs diff --git a/testsuite/tests/ghc-api/annotations/T10598.stdout b/testsuite/tests/ghc-api/annotations/T10598.stdout new file mode 100644 index 0000000000..21029da26d --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/T10598.stdout @@ -0,0 +1,36 @@ +---Problems (should be empty list)--- +[] +---Annotations----------------------- +-- SrcSpan the annotation is attached to, AnnKeywordId, +-- list of locations the keyword item appears in +[ +((Test10598.hs:1:1,AnnModule), [Test10598.hs:5:1-6]), +((Test10598.hs:1:1,AnnWhere), [Test10598.hs:5:18-22]), +((Test10598.hs:(7,1)-(9,10),AnnClass), [Test10598.hs:7:1-5]), +((Test10598.hs:(7,1)-(9,10),AnnSemi), [Test10598.hs:11:1]), +((Test10598.hs:(7,1)-(9,10),AnnWhere), [Test10598.hs:7:11-15]), +((Test10598.hs:8:3-21,AnnDcolon), [Test10598.hs:8:5-6]), +((Test10598.hs:8:3-21,AnnSemi), [Test10598.hs:9:3]), +((Test10598.hs:8:8-21,AnnRarrow), [Test10598.hs:8:16-17]), +((Test10598.hs:9:3-10,AnnEqual), [Test10598.hs:9:7]), +((Test10598.hs:9:3-10,AnnFunId), [Test10598.hs:9:3]), +((Test10598.hs:(11,1)-(12,10),AnnInstance), [Test10598.hs:11:1-8]), +((Test10598.hs:(11,1)-(12,10),AnnSemi), [Test10598.hs:14:1]), +((Test10598.hs:(11,1)-(12,10),AnnWhere), [Test10598.hs:11:16-20]), +((Test10598.hs:12:3-10,AnnEqual), [Test10598.hs:12:7]), +((Test10598.hs:12:3-10,AnnFunId), [Test10598.hs:12:3]), +((Test10598.hs:(14,1)-(17,21),AnnEqual), [Test10598.hs:14:13]), +((Test10598.hs:(14,1)-(17,21),AnnNewtype), [Test10598.hs:14:1-7]), +((Test10598.hs:(14,1)-(17,21),AnnSemi), [Test10598.hs:18:1]), +((Test10598.hs:15:3-22,AnnDeriving), [Test10598.hs:15:3-10]), +((Test10598.hs:16:3-23,AnnDeriving), [Test10598.hs:16:3-10]), +((Test10598.hs:16:12-16,AnnStock), [Test10598.hs:16:12-16]), +((Test10598.hs:17:3-21,AnnDeriving), [Test10598.hs:17:3-10]), +((Test10598.hs:17:12-19,AnnAnyclass), [Test10598.hs:17:12-19]), +((Test10598.hs:18:1-34,AnnDeriving), [Test10598.hs:18:1-8]), +((Test10598.hs:18:1-34,AnnInstance), [Test10598.hs:18:18-25]), +((Test10598.hs:18:1-34,AnnSemi), [Test10598.hs:19:1]), +((Test10598.hs:18:10-16,AnnNewtype), [Test10598.hs:18:10-16]), +((<no location info>,AnnEofPos), [Test10598.hs:19:1]) +] + diff --git a/testsuite/tests/ghc-api/annotations/Test10598.hs b/testsuite/tests/ghc-api/annotations/Test10598.hs new file mode 100644 index 0000000000..8a7651c154 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/Test10598.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +module Test10598 where + +class C a where + c :: proxy a -> Int + c _ = 42 + +instance C Int where + c _ = 27 + +newtype Foo = MkFoo Int + deriving Eq + deriving stock Ord + deriving anyclass C +deriving newtype instance Show Foo diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index c14153dfbb..fac5d56658 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -21,6 +21,7 @@ test('T10313', normal, run_command, ['$MAKE -s --no-print-directory T10313' test('T11018', normal, run_command, ['$MAKE -s --no-print-directory T11018']) test('bundle-export', normal, run_command, ['$MAKE -s --no-print-directory bundle-export']) test('T10276', normal, run_command, ['$MAKE -s --no-print-directory T10276']) +test('T10598', normal, run_command, ['$MAKE -s --no-print-directory T10598']) test('T11321', normal, run_command, ['$MAKE -s --no-print-directory T11321']) test('T11332', normal, run_command, ['$MAKE -s --no-print-directory T11332']) test('T11430', normal, run_command, ['$MAKE -s --no-print-directory T11430']) diff --git a/testsuite/tests/module/mod53.stderr b/testsuite/tests/module/mod53.stderr index a4c176d11a..754c4524a5 100644 --- a/testsuite/tests/module/mod53.stderr +++ b/testsuite/tests/module/mod53.stderr @@ -1,6 +1,6 @@ mod53.hs:4:22: error: Can't make a derived instance of ‘C T’: - ‘C’ is not a standard derivable class (Eq, Show, etc.) + ‘C’ is not a stock derivable class (Eq, Show, etc.) Try enabling DeriveAnyClass In the data declaration for ‘T’ diff --git a/testsuite/tests/parser/should_fail/readFail039.stderr b/testsuite/tests/parser/should_fail/readFail039.stderr index 91b9a16553..be948f0a07 100644 --- a/testsuite/tests/parser/should_fail/readFail039.stderr +++ b/testsuite/tests/parser/should_fail/readFail039.stderr @@ -1,6 +1,6 @@ readFail039.hs:8:14: error: Can't make a derived instance of ‘C Foo’: - ‘C’ is not a standard derivable class (Eq, Show, etc.) + ‘C’ is not a stock derivable class (Eq, Show, etc.) Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension In the newtype declaration for ‘Foo’ diff --git a/testsuite/tests/rts/T7919A.hs b/testsuite/tests/rts/T7919A.hs index ddbdb04750..cfcb329517 100644 --- a/testsuite/tests/rts/T7919A.hs +++ b/testsuite/tests/rts/T7919A.hs @@ -23,7 +23,7 @@ largeData = [normalC dataName (replicate size (((,) <$> bang noSourceUnpackedness noSourceStrictness) `ap` [t| Int |]))] - (cxt []) + [] conE' :: Name -> [ExpQ] -> ExpQ conE' n es = foldl appE (conE n) es diff --git a/testsuite/tests/safeHaskell/ghci/p16.stderr b/testsuite/tests/safeHaskell/ghci/p16.stderr index 4b445166d2..52315cce17 100644 --- a/testsuite/tests/safeHaskell/ghci/p16.stderr +++ b/testsuite/tests/safeHaskell/ghci/p16.stderr @@ -4,7 +4,7 @@ <interactive>:15:29: error: • Can't make a derived instance of ‘Op T2’: - ‘Op’ is not a standard derivable class (Eq, Show, etc.) + ‘Op’ is not a stock derivable class (Eq, Show, etc.) Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘T2’ diff --git a/testsuite/tests/th/T10598_TH.hs b/testsuite/tests/th/T10598_TH.hs new file mode 100644 index 0000000000..aab8bb3aa6 --- /dev/null +++ b/testsuite/tests/th/T10598_TH.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +module T10598_TH where + +import Language.Haskell.TH + +class C a +instance C Int + +class C a => D a +instance D Int + +{- +newtype Foo = MkFoo Int + deriving stock Eq + deriving anyclass C + deriving newtype Read + +deriving stock instance Ord Foo +deriving anyclass instance D Foo +deriving newtype instance Show Foo +-} + +$(do fooDataName <- newName "Foo" + mkFooConName <- newName "MkFoo" + let fooType = conT fooDataName + sequence [ newtypeD (cxt []) fooDataName [] Nothing + (normalC mkFooConName + [ bangType (bang noSourceUnpackedness noSourceStrictness) + [t| Int |] ]) + [ derivClause (Just Stock) [ [t| Eq |] ] + , derivClause (Just Anyclass) [ [t| C |] ] + , derivClause (Just Newtype) [ [t| Read |] ] ] + , standaloneDerivWithStrategyD (Just Stock) + (cxt []) [t| Ord $(fooType) |] + , standaloneDerivWithStrategyD (Just Anyclass) + (cxt []) [t| D $(fooType) |] + , standaloneDerivWithStrategyD (Just Newtype) + (cxt []) [t| Show $(fooType) |] ]) diff --git a/testsuite/tests/th/T10598_TH.stderr b/testsuite/tests/th/T10598_TH.stderr new file mode 100644 index 0000000000..bcfbb089c5 --- /dev/null +++ b/testsuite/tests/th/T10598_TH.stderr @@ -0,0 +1,41 @@ +T10598_TH.hs:(27,3)-(42,50): Splicing declarations + do { fooDataName <- newName "Foo"; + mkFooConName <- newName "MkFoo"; + let fooType = conT fooDataName; + sequence + [newtypeD + (cxt []) + fooDataName + [] + Nothing + (normalC + mkFooConName + [bangType + (bang noSourceUnpackedness noSourceStrictness) [t| Int |]]) + [derivClause (Just Stock) [[t| Eq |]], + derivClause (Just Anyclass) [[t| C |]], + derivClause (Just Newtype) [[t| Read |]]], + standaloneDerivWithStrategyD + (Just Stock) + (cxt []) + [t| Ord $fooType |] + pending(rn) [<splice, fooType>], + standaloneDerivWithStrategyD + (Just Anyclass) + (cxt []) + [t| D $fooType |] + pending(rn) [<splice, fooType>], + standaloneDerivWithStrategyD + (Just Newtype) + (cxt []) + [t| Show $fooType |] + pending(rn) [<splice, fooType>]] } + ======> + newtype Foo + = MkFoo Int + deriving stock (Eq) + deriving anyclass (C) + deriving newtype (Read) + deriving stock instance Ord Foo + deriving anyclass instance D Foo + deriving newtype instance Show Foo diff --git a/testsuite/tests/th/T10697_sourceUtil.hs b/testsuite/tests/th/T10697_sourceUtil.hs index 048a422b99..7ef60b79ae 100644 --- a/testsuite/tests/th/T10697_sourceUtil.hs +++ b/testsuite/tests/th/T10697_sourceUtil.hs @@ -10,7 +10,7 @@ makeSimpleDatatype :: Name -> Q Dec makeSimpleDatatype tyName conName srcUpk srcStr = dataD (cxt []) tyName [] Nothing [normalC conName - [bangType (bang srcUpk srcStr) (conT ''Int)]] (cxt []) + [bangType (bang srcUpk srcStr) (conT ''Int)]] [] checkBang :: Name -> SourceUnpackednessQ diff --git a/testsuite/tests/th/T10819.hs b/testsuite/tests/th/T10819.hs index 0a217df479..265934be1a 100644 --- a/testsuite/tests/th/T10819.hs +++ b/testsuite/tests/th/T10819.hs @@ -16,7 +16,8 @@ data D = X instance C Int D where f X = 2 -$(doSomeTH "N" (mkName "D") [ConT (mkName "C") `AppT` ConT (mkName "Int")]) +$(doSomeTH "N" (mkName "D") + [DerivClause Nothing [ConT (mkName "C") `AppT` ConT (mkName "Int")]]) thing :: N thing = N X diff --git a/testsuite/tests/th/T8100.hs b/testsuite/tests/th/T8100.hs index debc2f7166..3551251299 100644 --- a/testsuite/tests/th/T8100.hs +++ b/testsuite/tests/th/T8100.hs @@ -9,8 +9,8 @@ data Bar = Bar Int $( do decs <- [d| deriving instance Eq a => Eq (Foo a) deriving instance Ord a => Ord (Foo a) |] - return ( StandaloneDerivD [] (ConT ''Eq `AppT` ConT ''Bar) - : StandaloneDerivD [] (ConT ''Ord `AppT` ConT ''Bar) + return ( StandaloneDerivD Nothing [] (ConT ''Eq `AppT` ConT ''Bar) + : StandaloneDerivD Nothing [] (ConT ''Ord `AppT` ConT ''Bar) : decs ) ) blah :: Ord a => Foo a -> Foo a -> Ordering diff --git a/testsuite/tests/th/TH_dataD1.hs b/testsuite/tests/th/TH_dataD1.hs index 1a51ac4aef..9d0c95b1a9 100644 --- a/testsuite/tests/th/TH_dataD1.hs +++ b/testsuite/tests/th/TH_dataD1.hs @@ -6,7 +6,7 @@ import Language.Haskell.TH ds :: Q [Dec] ds = [d| $(do { d <- dataD (cxt []) (mkName "D") [] Nothing - [normalC (mkName "K") []] (cxt []) + [normalC (mkName "K") []] [] ; return [d]}) |] diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 5d2fe3b051..d6a124c48e 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -368,6 +368,7 @@ test('T10267', extra_clean(['T10267a.hi', 'T10267a.o']), test('T10279', normal, compile_fail, ['-v0']) test('T10306', normal, compile, ['-v0']) test('T10596', normal, compile, ['-v0']) +test('T10598_TH', normal, compile, ['-v0 -dsuppress-uniques -ddump-splices']) test('T10620', normal, compile_and_run, ['-v0']) test('T10638', normal, compile_fail, ['-v0']) test('T10697_decided_1', normal, compile_and_run, ['-v0']) diff --git a/utils/haddock b/utils/haddock -Subproject 073d899a8f94ddec698f617a38d3420160a7fd0 +Subproject d73b286cb39ad9d02bee4b1a104e817783ceb19 diff --git a/utils/mkUserGuidePart/Options/Language.hs b/utils/mkUserGuidePart/Options/Language.hs index c2012af915..f86b27d6c7 100644 --- a/utils/mkUserGuidePart/Options/Language.hs +++ b/utils/mkUserGuidePart/Options/Language.hs @@ -191,6 +191,13 @@ languageOptions = , flagReverse = "-XNoDeriveTraversable" , flagSince = "7.10.1" } + , flag { flagName = "-XDerivingStrategies" + , flagDescription = + "Enables :ref:`deriving strategies <deriving-strategies>`." + , flagType = DynamicFlag + , flagReverse = "-XNoDerivingStrategies" + , flagSince = "8.2.1" + } , flag { flagName = "-XDisambiguateRecordFields" , flagDescription = "Enable :ref:`record field disambiguation <disambiguate-fields>`. "++ |