Implement deriving strategies
authorRyan Scott <ryan.gl.scott@gmail.com>
Sat, 1 Oct 2016 00:15:25 +0000 (20:15 -0400)
committerBen Gamari <ben@smart-cactus.org>
Sat, 1 Oct 2016 03:23:44 +0000 (23:23 -0400)
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:
compiler/basicTypes/BasicTypes.hs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/main/DynFlags.hs
compiler/main/HscStats.hs
compiler/parser/ApiAnnotation.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/prelude/THNames.hs
compiler/rename/RnSource.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcInstDcls.hs
docs/users_guide/8.2.1-notes.rst
docs/users_guide/glasgow_exts.rst
docs/users_guide/safe_haskell.rst
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
libraries/ghci/GHCi/TH/Binary.hs
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
libraries/template-haskell/changelog.md
testsuite/driver/extra_files.py
testsuite/tests/deriving/should_fail/T10598_fail1.hs [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail1.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail2.hs [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail2.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail3.hs [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail3.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail4.hs [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail4.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail5.hs [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail5.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail6.hs [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T10598_fail6.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_fail/T3833.stderr
testsuite/tests/deriving/should_fail/T3834.stderr
testsuite/tests/deriving/should_fail/T9600.stderr
testsuite/tests/deriving/should_fail/T9968a.stderr
testsuite/tests/deriving/should_fail/all.T
testsuite/tests/deriving/should_fail/drvfail008.stderr
testsuite/tests/deriving/should_run/T10598_bug.hs [new file with mode: 0644]
testsuite/tests/deriving/should_run/T10598_bug.stdout [new file with mode: 0644]
testsuite/tests/deriving/should_run/T10598_run.hs [new file with mode: 0644]
testsuite/tests/deriving/should_run/T10598_run.stdout [new file with mode: 0644]
testsuite/tests/deriving/should_run/all.T
testsuite/tests/driver/T4437.hs
testsuite/tests/generics/T5462No1.stderr
testsuite/tests/ghc-api/annotations/Makefile
testsuite/tests/ghc-api/annotations/T10598.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/Test10598.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/all.T
testsuite/tests/module/mod53.stderr
testsuite/tests/parser/should_fail/readFail039.stderr
testsuite/tests/rts/T7919A.hs
testsuite/tests/safeHaskell/ghci/p16.stderr
testsuite/tests/th/T10598_TH.hs [new file with mode: 0644]
testsuite/tests/th/T10598_TH.stderr [new file with mode: 0644]
testsuite/tests/th/T10697_sourceUtil.hs
testsuite/tests/th/T10819.hs
testsuite/tests/th/T8100.hs
testsuite/tests/th/TH_dataD1.hs
testsuite/tests/th/all.T
utils/haddock
utils/mkUserGuidePart/Options/Language.hs

index aab0528..0429a43 100644 (file)
@@ -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
 *                                                                      *
 ************************************************************************
index 638d9b4..d8fdb54 100644 (file)
@@ -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)
index 5b5119a..6bb7199 100644 (file)
@@ -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"
 
index 24b13c4..ed8da4d 100644 (file)
@@ -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 ]
 
 {-
 ************************************************************************
index b642bea..a972716 100644 (file)
@@ -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
index 78020f7..241dfd8 100644 (file)
@@ -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 {})
index eebec54..ac784bc 100644 (file)
@@ -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 -- ^ '$$'
index 410d150..361fa0b 100644 (file)
@@ -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),
index 5db535f..4cab083 100644 (file)
@@ -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] }
index 4f98114..8c184f8 100644 (file)
@@ -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
+
 {-
 ************************************************************************
 *                                                                      *
index e3c90a8..68038d9 100644 (file)
@@ -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
index f201b22..d672aa0 100644 (file)
@@ -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
index 858d920..c47b00b 100644 (file)
@@ -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
index e7d7bd3..0a5fbb0 100644 (file)
@@ -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))]
index 96d7493..2e7104c 100644 (file)
@@ -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) } }
index 87bc97f..3e13f57 100644 (file)
@@ -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
 ~~~~
 
index b41a09a..bcfef01 100644 (file)
@@ -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
index 6ce8b8f..653b741 100644 (file)
@@ -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:
index 85664c2..ff26ec6 100644 (file)
@@ -80,6 +80,7 @@ data Extension
    | DefaultSignatures        -- Allow extra signatures for defmeths
    | DeriveAnyClass           -- Allow deriving any class
    | DeriveLift               -- Allow deriving Lift
+   | DerivingStrategies
 
    | TypeSynonymInstances
    | FlexibleContexts
index 0bdc756..e930956 100644 (file)
@@ -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
index 7cf342a..bde698e 100644 (file)
@@ -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,
index 2631c0e..c425438 100644 (file)
@@ -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
 
index 7376135..8941a8b 100644 (file)
@@ -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
index 00ac0b3..afe961b 100644 (file)
@@ -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
index e23fbf7..19038c7 100644 (file)
@@ -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
index 5af9695..3f1e75b 100644 (file)
@@ -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 (file)
index 0000000..ee48886
--- /dev/null
@@ -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 (file)
index 0000000..0183ec5
--- /dev/null
@@ -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 (file)
index 0000000..ba77fe0
--- /dev/null
@@ -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 (file)
index 0000000..5ddd81d
--- /dev/null
@@ -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 (file)
index 0000000..23f9ad9
--- /dev/null
@@ -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 (file)
index 0000000..a987a49
--- /dev/null
@@ -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 (file)
index 0000000..911111c
--- /dev/null
@@ -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 (file)
index 0000000..7d724d0
--- /dev/null
@@ -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 (file)
index 0000000..74f57fd
--- /dev/null
@@ -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 (file)
index 0000000..af38cdc
--- /dev/null
@@ -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 (file)
index 0000000..673bfcc
--- /dev/null
@@ -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 (file)
index 0000000..a80e5ba
--- /dev/null
@@ -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’
index da7da91..bf9a59c 100644 (file)
@@ -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)’
index 3eec64a..9d2223e 100644 (file)
@@ -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’
index 2e88277..5c03f2e 100644 (file)
@@ -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’
index 9f52b2e..a725631 100644 (file)
@@ -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’
index bcb410b..aebfa9e 100644 (file)
@@ -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, [''])
index bfa7392..dcd43ec 100644 (file)
@@ -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 (file)
index 0000000..e34d2c2
--- /dev/null
@@ -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 (file)
index 0000000..31d7367
--- /dev/null
@@ -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 (file)
index 0000000..96238d7
--- /dev/null
@@ -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 (file)
index 0000000..74a3087
--- /dev/null
@@ -0,0 +1,2 @@
+100
+42
index 29e8bbd..ede2f90 100644 (file)
@@ -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, [''])
index 45e257e..0bef4c5 100644 (file)
@@ -40,7 +40,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
                              "TypeFamilyDependencies",
-                             "UnboxedSums"]
+                             "UnboxedSums",
+                             "DerivingStrategies"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
index 7c1aec8..c82f1b8 100644 (file)
@@ -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’
index c557c66..158dadb 100644 (file)
@@ -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 (file)
index 0000000..21029da
--- /dev/null
@@ -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 (file)
index 0000000..8a7651c
--- /dev/null
@@ -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
index c14153d..fac5d56 100644 (file)
@@ -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'])
index a4c176d..754c452 100644 (file)
@@ -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’
index 91b9a16..be948f0 100644 (file)
@@ -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’
index ddbdb04..cfcb329 100644 (file)
@@ -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
index 4b44516..52315cc 100644 (file)
@@ -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 (file)
index 0000000..aab8bb3
--- /dev/null
@@ -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 (file)
index 0000000..bcfbb08
--- /dev/null
@@ -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
index 048a422..7ef60b7 100644 (file)
@@ -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
index 0a217df..265934b 100644 (file)
@@ -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
index debc2f7..3551251 100644 (file)
@@ -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
index 1a51ac4..9d0c95b 100644 (file)
@@ -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]})
        |]
 
index 5d2fe3b..d6a124c 100644 (file)
@@ -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'])
index 073d899..d73b286 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 073d899a8f94ddec698f617a38d3420160a7fd0b
+Subproject commit d73b286cb39ad9d02bee4b1a104e817783ceb195
index c2012af..f86b27d 100644 (file)
@@ -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>`. "++