{-# LANGUAGE CPP #-}
module GHC.SourceGen.Decl
( HsDecl'
, type'
, newtype'
, data'
, ConDecl'
, prefixCon
, infixCon
, recordCon
, Field
, field
, strict
, lazy
, HsDerivingClause'
, deriving'
, derivingStock
, derivingAnyclass
, derivingNewtype
#if MIN_VERSION_ghc(8,6,0)
, derivingVia
#endif
, class'
, ClassDecl
, funDep
, instance'
, RawInstDecl
, HasTyFamInst(..)
, tyFamInst
, patSynSigs
, patSynSig
, patSynBind
) where
import BasicTypes (LexicalFixity(Prefix))
#if !MIN_VERSION_ghc(8,6,0)
import BasicTypes (DerivStrategy(..))
#endif
import Bag (listToBag)
import HsBinds
import HsDecls
import HsTypes
( ConDeclField(..)
, FieldOcc(..)
, HsConDetails(..)
, HsSrcBang(..)
, HsType(..)
#if MIN_VERSION_ghc(8,8,0)
, HsArg(..)
#endif
, SrcStrictness(..)
, SrcUnpackedness(..)
)
import SrcLoc (Located)
#if MIN_VERSION_ghc(8,6,0)
import HsExtension (NoExt(NoExt))
#else
import PlaceHolder (PlaceHolder(..))
#endif
import GHC.SourceGen.Binds.Internal
import GHC.SourceGen.Lit.Internal (noSourceText)
import GHC.SourceGen.Name
import GHC.SourceGen.Name.Internal
import GHC.SourceGen.Syntax.Internal
import GHC.SourceGen.Type.Internal
data ClassDecl
= ClassSig Sig'
| ClassDefaultMethod HsBind'
| ClassFunDep [RdrNameStr] [RdrNameStr]
instance HasValBind ClassDecl where
sigB = ClassSig
bindB = ClassDefaultMethod
funDep :: [RdrNameStr] -> [RdrNameStr] -> ClassDecl
funDep = ClassFunDep
class'
:: [HsType']
-> OccNameStr
-> [OccNameStr]
-> [ClassDecl]
-> HsDecl'
class' context name vars decls
= noExt TyClD $ ClassDecl
{ tcdCtxt = builtLoc $ map builtLoc context
#if MIN_VERSION_ghc(8,6,0)
, tcdCExt = NoExt
#else
, tcdFVs = PlaceHolder
#endif
, tcdLName = typeRdrName $ unqual name
, tcdTyVars = mkQTyVars vars
, tcdFixity = Prefix
, tcdFDs = [ builtLoc (map typeRdrName xs, map typeRdrName ys)
| ClassFunDep xs ys <- decls
]
, tcdSigs = [builtLoc sig | ClassSig sig <- decls]
, tcdMeths =
listToBag [builtLoc bind | ClassDefaultMethod bind <- decls]
, tcdATs = [] -- Associated types
, tcdATDefs = [] -- Associated type defaults
, tcdDocs = [] -- Haddocks
}
-- | A definition that can appear in the body of an @instance@ declaration.
--
-- 'RawInstDecl' definitions may be constructed using its class instances, e.g.,
-- 'HasValBind'. For more details, see the documentation of those classes.
data RawInstDecl
= InstSig Sig'
| InstBind HsBind'
| InstTyFam TyFamInstDecl'
instance HasValBind RawInstDecl where
sigB = InstSig
bindB = InstBind
-- | An instance declaration.
--
-- > instance Show Bool where
-- > show :: Bool -> String -- Requires the InstanceSigs extension
-- > show True = "True"
-- > show False = "False"
-- > =====
-- > instance' (var "Show" @@ var "Bool")
-- > [ typeSig "show" $ var "Bool" --> var "String"
-- > , funBinds "show"
-- > [ match [bvar "True"] $ string "True"
-- > , match [bvar "False"] $ string "False"
-- > ]
-- > ]
instance' :: HsType' -> [RawInstDecl] -> HsDecl'
instance' ty decls = noExt InstD $ noExt ClsInstD $ ClsInstDecl
{ cid_poly_ty = sigType ty
#if MIN_VERSION_ghc(8,6,0)
, cid_ext = NoExt
#endif
, cid_binds = listToBag [builtLoc b | InstBind b <- decls]
, cid_sigs = [builtLoc sig | InstSig sig <- decls]
, cid_tyfam_insts = [builtLoc $ t | InstTyFam t <- decls]
, cid_datafam_insts = []
, cid_overlap_mode = Nothing
}
-- | Terms which can contain a type instance declaration.
--
-- To use this class, call 'tyFamInst'.
class HasTyFamInst t where
tyFamInstD :: TyFamInstDecl' -> t
instance HasTyFamInst HsDecl' where
tyFamInstD = noExt InstD . noExt TyFamInstD
instance HasTyFamInst RawInstDecl where
tyFamInstD = InstTyFam
-- | A type family instance.
--
-- > type Elt String = Char
-- > =====
-- > tyFamInst "Elt" [var "String"] (var "Char")
tyFamInst :: HasTyFamInst t => RdrNameStr -> [HsType'] -> HsType' -> t
tyFamInst name params ty = tyFamInstD
#if MIN_VERSION_ghc(8,4,0)
$ TyFamInstDecl
$ implicitBndrs
$ noExt FamEqn (typeRdrName name)
#if MIN_VERSION_ghc(8,8,0)
Nothing
(map (HsValArg . builtLoc) params)
#else
(map builtLoc params)
#endif
Prefix
(builtLoc ty)
#else
$ withPlaceHolder $ TyFamInstDecl
$ builtLoc $ TyFamEqn (typeRdrName name)
(implicitBndrs $ map builtLoc params)
Prefix
(builtLoc ty)
#endif
type' :: OccNameStr -> [OccNameStr] -> HsType' -> HsDecl'
type' name vars t =
noExt TyClD $ withPlaceHolder $ noExt SynDecl (typeRdrName $ unqual name)
(mkQTyVars vars)
Prefix
(builtLoc t)
newOrDataType
:: NewOrData
-> OccNameStr
-> [OccNameStr]
-> [ConDecl']
-> [HsDerivingClause']
-> HsDecl'
newOrDataType newOrData name vars conDecls derivs
= noExt TyClD $ withPlaceHolder $ withPlaceHolder $
noExt DataDecl (typeRdrName $ unqual name)
(mkQTyVars vars)
Prefix
$ noExt HsDataDefn newOrData
(builtLoc []) Nothing
Nothing
(map builtLoc conDecls)
(builtLoc $ map builtLoc derivs)
newtype' :: OccNameStr -> [OccNameStr] -> ConDecl' -> [HsDerivingClause'] -> HsDecl'
newtype' name vars conD = newOrDataType NewType name vars [conD]
data' :: OccNameStr -> [OccNameStr] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl'
data' = newOrDataType DataType
prefixCon :: OccNameStr -> [Field] -> ConDecl'
prefixCon name fields = renderCon98Decl name
$ PrefixCon $ map renderField fields
infixCon :: Field -> OccNameStr -> Field -> ConDecl'
infixCon f name f' = renderCon98Decl name
$ InfixCon (renderField f) (renderField f')
recordCon :: OccNameStr -> [(OccNameStr, Field)] -> ConDecl'
recordCon name fields = renderCon98Decl name
$ RecCon $ builtLoc $ map mkLConDeclField fields
where
mkLConDeclField (n, f) =
builtLoc $ noExt ConDeclField
[builtLoc $ withPlaceHolder $ noExt FieldOcc $ valueRdrName $ unqual n]
(renderField f)
Nothing
data Field = Field
{ fieldType :: HsType'
, strictness :: SrcStrictness
}
field :: HsType' -> Field
field t = Field t NoSrcStrict
strict :: Field -> Field
strict f = f { strictness = SrcStrict }
lazy :: Field -> Field
lazy f = f { strictness = SrcLazy }
renderField :: Field -> Located HsType'
renderField f = wrap $ parenthesizeTypeForApp $ builtLoc $ fieldType f
where
wrap = case strictness f of
NoSrcStrict -> id
s -> builtLoc . (noExt HsBangTy $ noSourceText HsSrcBang NoSrcUnpack s)
renderCon98Decl :: OccNameStr -> HsConDeclDetails' -> ConDecl'
renderCon98Decl name details = noExt ConDeclH98 (typeRdrName $ unqual name)
#if MIN_VERSION_ghc(8,6,0)
(builtLoc False)
[]
#else
Nothing
#endif
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)
#if MIN_VERSION_ghc(8,6,0)
derivingVia :: HsType' -> [HsType'] -> HsDerivingClause'
derivingVia t = derivingWay (Just $ ViaStrategy $ sigType t)
#endif
patSynSigs :: [OccNameStr] -> HsType' -> HsDecl'
patSynSigs names t =
sigB $ noExt PatSynSig (map (typeRdrName . unqual) names)
$ sigType t
patSynSig :: OccNameStr -> HsType' -> HsDecl'
patSynSig n = patSynSigs [n]
patSynBind :: OccNameStr -> [OccNameStr] -> Pat' -> HsDecl'
patSynBind n ns p = bindB $ noExt PatSynBind
$ withPlaceHolder (noExt PSB (valueRdrName $ unqual n))
#if MIN_VERSION_ghc(8,4,0)
(PrefixCon
#else
(PrefixPatSyn
#endif
(map (valueRdrName . unqual) ns))
(builtPat p)
ImplicitBidirectional