Deriving clauses. (#17)

For now, no DerivingVia since it's not in every GHC version.

src/GHC/SourceGen/Decl.hs

@@ -12,7 +12,7 @@ module GHC.SourceGen.Decl
     , type'
     , newtype'
     , data'
-      -- * Data constructors
+      -- ** Data constructors
     , ConDecl'
     , prefixCon
     , infixCon
@@ -21,6 +21,12 @@ module GHC.SourceGen.Decl
     , field
     , strict
     , lazy
+      -- ** Deriving clauses
+    , HsDerivingClause'
+    , deriving'
+    , derivingStock
+    , derivingAnyclass
+    , derivingNewtype
       -- * Class declarations
     , class'
     , ClassDecl
@@ -31,6 +37,9 @@ module GHC.SourceGen.Decl
     ) where
 
 import BasicTypes (LexicalFixity(Prefix))
+#if !MIN_VERSION_ghc(8,6,0)
+import BasicTypes (DerivStrategy(..))
+#endif
 import Bag (listToBag)
 import HsDecls
 import HsTypes
@@ -192,9 +201,14 @@ type' name vars t =
         Prefix
         (builtLoc t)
 
-newOrDataType ::
-    NewOrData -> RdrNameStr -> [RdrNameStr] -> [ConDecl'] -> HsDecl'
-newOrDataType newOrData name vars conDecls
+newOrDataType
+    :: NewOrData
+    -> RdrNameStr
+    -> [RdrNameStr]
+    -> [ConDecl']
+    -> [HsDerivingClause']
+    -> HsDecl'
+newOrDataType newOrData name vars conDecls derivs
     = noExt TyClD $ withPlaceHolder $ withPlaceHolder $
         noExt DataDecl (typeRdrName name)
             (mkQTyVars vars)
@@ -203,25 +217,29 @@ newOrDataType newOrData name vars conDecls
                 (builtLoc []) Nothing
                 Nothing
                 (map builtLoc conDecls)
-                (builtLoc [])
+                (builtLoc $ map builtLoc derivs)
 
 -- | A newtype declaration.
 --
--- > newtype Const a b = Const a
+-- > newtype Const a b = Const a deriving Eq
 -- > =====
--- > newtype' "Const" ["a", "b"] $ conDecl "Const" [var "a"]
-newtype' :: RdrNameStr -> [RdrNameStr] -> ConDecl' -> HsDecl'
+-- > newtype' "Const" ["a", "b"]
+-- >    (conDecl "Const" [var "a"])
+-- >    [var "Show"]
+newtype' :: RdrNameStr -> [RdrNameStr] -> ConDecl' -> [HsDerivingClause'] -> HsDecl'
 newtype' name vars conD = newOrDataType NewType name vars [conD]
 
 -- | A data declaration.
 --
 -- > data Either a b = Left a | Right b
+-- >    deriving Show
 -- > =====
 -- > data' "Either" ["a", "b"]
 -- >   [ conDecl "Left" [var "a"]
 -- >   , conDecl "Right" [var "b"]
 -- >   ]
-data' :: RdrNameStr -> [RdrNameStr] -> [ConDecl'] -> HsDecl'
+-- >   [var "Show"]
+data' :: RdrNameStr -> [RdrNameStr] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl'
 data' = newOrDataType DataType
 
 -- | Declares a Haskell-98-style prefix constructor for a data or type
@@ -314,3 +332,19 @@ renderCon98Decl name details = noExt ConDeclH98 (typeRdrName name)
     Nothing
     details
     Nothing
+
+deriving' :: [HsType'] -> HsDerivingClause'
+deriving' = derivingWay Nothing
+
+derivingWay :: Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'
+derivingWay way ts =
+    noExt HsDerivingClause (fmap builtLoc way) $ builtLoc $ map sigType ts
+
+derivingStock :: [HsType'] -> HsDerivingClause'
+derivingStock = derivingWay (Just StockStrategy)
+
+derivingNewtype :: [HsType'] -> HsDerivingClause'
+derivingNewtype = derivingWay (Just NewtypeStrategy)
+
+derivingAnyclass :: [HsType'] -> HsDerivingClause'
+derivingAnyclass = derivingWay (Just AnyclassStrategy)

src/GHC/SourceGen/Syntax/Internal.hs

@@ -35,6 +35,12 @@ import HsSyn
     , LHsWcType
     )
 import HsBinds (Sig, HsLocalBinds)
+#if MIN_VERSION_ghc(8,6,0)
+import HsDecls (DerivStrategy)
+#else
+import BasicTypes (DerivStrategy)
+#endif
+import HsDecls (HsDerivingClause)
 import HsPat
 import RdrName (RdrName)
 import SrcLoc (SrcSpan, Located, GenLocated(..), mkGeneralSrcSpan)
@@ -131,6 +137,7 @@ type IE' = IE GhcPs
 type ImportDecl' = ImportDecl GhcPs
 type LHsSigWcType' = LHsSigWcType GhcPs
 type LHsWcType' = LHsWcType GhcPs
+type HsDerivingClause' = HsDerivingClause GhcPs
 
 #else
 type HsExpr' = HsExpr RdrName
@@ -159,5 +166,12 @@ type IE' = IE RdrName
 type ImportDecl' = ImportDecl RdrName
 type LHsSigWcType' = LHsSigWcType RdrName
 type LHsWcType' = LHsWcType RdrName
+type HsDerivingClause' = HsDerivingClause RdrName
 
 #endif
+
+#if MIN_VERSION_ghc(8,6,0)
+type DerivStrategy' = DerivStrategy GhcPs
+#else
+type DerivStrategy' = DerivStrategy
+#endif

tests/pprint_examples.hs

@@ -134,7 +134,9 @@ test3 = pprint $ module' Nothing Nothing []
         [ prefixCon "A" [field (var "b"), field (var "c")]
         , prefixCon "D" []
         ]
+        [deriving' [var "X", var "Y"]]
     , newtype' "A" ["b", "c"] (prefixCon "A" [field (var "b")])
+        [deriving' [var "X", var "Y"]]
     , instance' (var "A" @@ var "b" @@ var "c")
         [ typeSig "f" $ var "b" --> var "c"
         , funBind "f" $ matchRhs [] $ var "undefined"
@@ -187,6 +189,7 @@ test3 = pprint $ module' Nothing Nothing []
             , ("y", lazy $ field $ var "A" @@ var "b")
             ]
         ]
+        []
     , funBind "strictness"
         $ matchRhs
             [strictP (conP "A" [var "b"]),