mirror of
https://github.com/google/ghc-source-gen.git
synced 2024-09-11 22:07:09 +03:00
Deriving clauses. (#17)
For now, no DerivingVia since it's not in every GHC version.
This commit is contained in:
parent
b37db25dc0
commit
f1e93651c9
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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"]),
|
||||
|
Loading…
Reference in New Issue
Block a user