module HsDecls (
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
TyClDecl(..), LTyClDecl, DataDeclRn(..),
TyClGroup(..), mkTyClGroup, emptyTyClGroup,
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
isClassDecl, isDataDecl, isSynDecl, tcdName,
isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
tyFamInstDeclName, tyFamInstDeclLName,
countTyClDecls, pprTyClDeclFlavour,
tyClDeclLName, tyClDeclTyVars,
hsDeclHasCusk, famDeclHasCusk,
FamilyDecl(..), LFamilyDecl,
InstDecl(..), LInstDecl, FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS,
FamInstEqn, LFamInstEqn, FamEqn(..),
TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
HsTyPats,
LClsInstDecl, ClsInstDecl(..),
DerivDecl(..), LDerivDecl,
DerivStrategy(..), LDerivStrategy, derivStrategyName,
LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..),
RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
flattenRuleDecls, pprFullRuleName,
DefaultDecl(..), LDefaultDecl,
SpliceExplicitFlag(..),
SpliceDecl(..), LSpliceDecl,
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..),
ConDecl(..), LConDecl,
HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
getConNames, getConArgs,
DocDecl(..), LDocDecl, docDeclDoc,
WarnDecl(..), LWarnDecl,
WarnDecls(..), LWarnDecls,
AnnDecl(..), LAnnDecl,
AnnProvenance(..), annProvenanceName_maybe,
RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,
FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,
resultVariableName,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls
) where
import GhcPrelude
import HsExpr( HsExpr, HsSplice, pprExpr,
pprSpliceDecl )
import HsBinds
import HsTypes
import HsDoc
import TyCon
import BasicTypes
import Coercion
import ForeignCall
import HsExtension
import NameSet
import Class
import Outputable
import Util
import SrcLoc
import Type
import Bag
import Maybes
import Data.Data hiding (TyCon,Fixity, Infix)
type LHsDecl p = Located (HsDecl p)
data HsDecl p
= TyClD (XTyClD p) (TyClDecl p)
| InstD (XInstD p) (InstDecl p)
| DerivD (XDerivD p) (DerivDecl p)
| ValD (XValD p) (HsBind p)
| SigD (XSigD p) (Sig p)
| DefD (XDefD p) (DefaultDecl p)
| ForD (XForD p) (ForeignDecl p)
| WarningD (XWarningD p) (WarnDecls p)
| AnnD (XAnnD p) (AnnDecl p)
| RuleD (XRuleD p) (RuleDecls p)
| SpliceD (XSpliceD p) (SpliceDecl p)
| DocD (XDocD p) (DocDecl)
| RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p)
| XHsDecl (XXHsDecl p)
type instance XTyClD (GhcPass _) = NoExt
type instance XInstD (GhcPass _) = NoExt
type instance XDerivD (GhcPass _) = NoExt
type instance XValD (GhcPass _) = NoExt
type instance XSigD (GhcPass _) = NoExt
type instance XDefD (GhcPass _) = NoExt
type instance XForD (GhcPass _) = NoExt
type instance XWarningD (GhcPass _) = NoExt
type instance XAnnD (GhcPass _) = NoExt
type instance XRuleD (GhcPass _) = NoExt
type instance XSpliceD (GhcPass _) = NoExt
type instance XDocD (GhcPass _) = NoExt
type instance XRoleAnnotD (GhcPass _) = NoExt
type instance XXHsDecl (GhcPass _) = NoExt
data HsGroup p
= HsGroup {
hs_ext :: XCHsGroup p,
hs_valds :: HsValBinds p,
hs_splcds :: [LSpliceDecl p],
hs_tyclds :: [TyClGroup p],
hs_derivds :: [LDerivDecl p],
hs_fixds :: [LFixitySig p],
hs_defds :: [LDefaultDecl p],
hs_fords :: [LForeignDecl p],
hs_warnds :: [LWarnDecls p],
hs_annds :: [LAnnDecl p],
hs_ruleds :: [LRuleDecls p],
hs_docs :: [LDocDecl]
}
| XHsGroup (XXHsGroup p)
type instance XCHsGroup (GhcPass _) = NoExt
type instance XXHsGroup (GhcPass _) = NoExt
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
hsGroupInstDecls :: HsGroup id -> [LInstDecl id]
hsGroupInstDecls = (=<<) group_instds . hs_tyclds
emptyGroup = HsGroup { hs_ext = noExt,
hs_tyclds = [],
hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_annds = [],
hs_fords = [], hs_warnds = [], hs_ruleds = [],
hs_valds = error "emptyGroup hs_valds: Can't happen",
hs_splcds = [],
hs_docs = [] }
appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
-> HsGroup (GhcPass p)
appendGroups
HsGroup {
hs_valds = val_groups1,
hs_splcds = spliceds1,
hs_tyclds = tyclds1,
hs_derivds = derivds1,
hs_fixds = fixds1,
hs_defds = defds1,
hs_annds = annds1,
hs_fords = fords1,
hs_warnds = warnds1,
hs_ruleds = rulds1,
hs_docs = docs1 }
HsGroup {
hs_valds = val_groups2,
hs_splcds = spliceds2,
hs_tyclds = tyclds2,
hs_derivds = derivds2,
hs_fixds = fixds2,
hs_defds = defds2,
hs_annds = annds2,
hs_fords = fords2,
hs_warnds = warnds2,
hs_ruleds = rulds2,
hs_docs = docs2 }
=
HsGroup {
hs_ext = noExt,
hs_valds = val_groups1 `plusHsValBinds` val_groups2,
hs_splcds = spliceds1 ++ spliceds2,
hs_tyclds = tyclds1 ++ tyclds2,
hs_derivds = derivds1 ++ derivds2,
hs_fixds = fixds1 ++ fixds2,
hs_annds = annds1 ++ annds2,
hs_defds = defds1 ++ defds2,
hs_fords = fords1 ++ fords2,
hs_warnds = warnds1 ++ warnds2,
hs_ruleds = rulds1 ++ rulds2,
hs_docs = docs1 ++ docs2 }
appendGroups _ _ = panic "appendGroups"
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where
ppr (TyClD _ dcl) = ppr dcl
ppr (ValD _ binds) = ppr binds
ppr (DefD _ def) = ppr def
ppr (InstD _ inst) = ppr inst
ppr (DerivD _ deriv) = ppr deriv
ppr (ForD _ fd) = ppr fd
ppr (SigD _ sd) = ppr sd
ppr (RuleD _ rd) = ppr rd
ppr (WarningD _ wd) = ppr wd
ppr (AnnD _ ad) = ppr ad
ppr (SpliceD _ dd) = ppr dd
ppr (DocD _ doc) = ppr doc
ppr (RoleAnnotD _ ra) = ppr ra
ppr (XHsDecl x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where
ppr (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
hs_fixds = fix_decls,
hs_warnds = deprec_decls,
hs_annds = ann_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls })
= vcat_mb empty
[ppr_ds fix_decls, ppr_ds default_decls,
ppr_ds deprec_decls, ppr_ds ann_decls,
ppr_ds rule_decls,
if isEmptyValBinds val_decls
then Nothing
else Just (ppr val_decls),
ppr_ds (tyClGroupTyClDecls tycl_decls),
ppr_ds (tyClGroupInstDecls tycl_decls),
ppr_ds deriv_decls,
ppr_ds foreign_decls]
where
ppr_ds :: Outputable a => [a] -> Maybe SDoc
ppr_ds [] = Nothing
ppr_ds ds = Just (vcat (map ppr ds))
vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc
vcat_mb _ [] = empty
vcat_mb gap (Nothing : ds) = vcat_mb gap ds
vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds
ppr (XHsGroup x) = ppr x
type LSpliceDecl pass = Located (SpliceDecl pass)
data SpliceDecl p
= SpliceDecl
(XSpliceDecl p)
(Located (HsSplice p))
SpliceExplicitFlag
| XSpliceDecl (XXSpliceDecl p)
type instance XSpliceDecl (GhcPass _) = NoExt
type instance XXSpliceDecl (GhcPass _) = NoExt
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (SpliceDecl p) where
ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f
ppr (XSpliceDecl x) = ppr x
type LTyClDecl pass = Located (TyClDecl pass)
data TyClDecl pass
=
FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass }
|
SynDecl { tcdSExt :: XSynDecl pass
, tcdLName :: Located (IdP pass)
, tcdTyVars :: LHsQTyVars pass
, tcdFixity :: LexicalFixity
, tcdRhs :: LHsType pass }
|
DataDecl { tcdDExt :: XDataDecl pass
, tcdLName :: Located (IdP pass)
, tcdTyVars :: LHsQTyVars pass
, tcdFixity :: LexicalFixity
, tcdDataDefn :: HsDataDefn pass }
| ClassDecl { tcdCExt :: XClassDecl pass,
tcdCtxt :: LHsContext pass,
tcdLName :: Located (IdP pass),
tcdTyVars :: LHsQTyVars pass,
tcdFixity :: LexicalFixity,
tcdFDs :: [Located (FunDep (Located (IdP pass)))],
tcdSigs :: [LSig pass],
tcdMeths :: LHsBinds pass,
tcdATs :: [LFamilyDecl pass],
tcdATDefs :: [LTyFamDefltEqn pass],
tcdDocs :: [LDocDecl]
}
| XTyClDecl (XXTyClDecl pass)
data DataDeclRn = DataDeclRn
{ tcdDataCusk :: Bool
, tcdFVs :: NameSet }
deriving Data
type instance XFamDecl (GhcPass _) = NoExt
type instance XSynDecl GhcPs = NoExt
type instance XSynDecl GhcRn = NameSet
type instance XSynDecl GhcTc = NameSet
type instance XDataDecl GhcPs = NoExt
type instance XDataDecl GhcRn = DataDeclRn
type instance XDataDecl GhcTc = DataDeclRn
type instance XClassDecl GhcPs = NoExt
type instance XClassDecl GhcRn = NameSet
type instance XClassDecl GhcTc = NameSet
type instance XXTyClDecl (GhcPass _) = NoExt
isDataDecl :: TyClDecl pass -> Bool
isDataDecl (DataDecl {}) = True
isDataDecl _other = False
isSynDecl :: TyClDecl pass -> Bool
isSynDecl (SynDecl {}) = True
isSynDecl _other = False
isClassDecl :: TyClDecl pass -> Bool
isClassDecl (ClassDecl {}) = True
isClassDecl _ = False
isFamilyDecl :: TyClDecl pass -> Bool
isFamilyDecl (FamDecl {}) = True
isFamilyDecl _other = False
isTypeFamilyDecl :: TyClDecl pass -> Bool
isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of
OpenTypeFamily -> True
ClosedTypeFamily {} -> True
_ -> False
isTypeFamilyDecl _ = False
isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool
isOpenTypeFamilyInfo OpenTypeFamily = True
isOpenTypeFamilyInfo _ = False
isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool
isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True
isClosedTypeFamilyInfo _ = False
isDataFamilyDecl :: TyClDecl pass -> Bool
isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True
isDataFamilyDecl _other = False
tyFamInstDeclName :: TyFamInstDecl pass -> (IdP pass)
tyFamInstDeclName = unLoc . tyFamInstDeclLName
tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass)
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
(HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })
= ln
tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn _)))
= panic "tyFamInstDeclLName"
tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs _))
= panic "tyFamInstDeclLName"
tyClDeclLName :: TyClDecl pass -> Located (IdP pass)
tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
tyClDeclLName decl = tcdLName decl
tcdName :: TyClDecl pass -> (IdP pass)
tcdName = unLoc . tyClDeclLName
tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass
tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
tyClDeclTyVars d = tcdTyVars d
countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)
countTyClDecls decls
= (count isClassDecl decls,
count isSynDecl decls,
count isDataTy decls,
count isNewTy decls,
count isFamilyDecl decls)
where
isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
isDataTy _ = False
isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
isNewTy _ = False
hsDeclHasCusk :: TyClDecl GhcRn -> Bool
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
= hsTvbAllKinded tyvars && rhs_annotated rhs
where
rhs_annotated (L _ ty) = case ty of
HsParTy _ lty -> rhs_annotated lty
HsKindSig {} -> True
_ -> False
hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk"
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where
ppr (FamDecl { tcdFam = decl }) = ppr decl
ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
, tcdRhs = rhs })
= hang (text "type" <+>
pp_vanilla_decl_head ltycon tyvars fixity [] <+> equals)
4 (ppr rhs)
ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
, tcdDataDefn = defn })
= pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdFDs = fds,
tcdSigs = sigs, tcdMeths = methods,
tcdATs = ats, tcdATDefs = at_defs})
| null sigs && isEmptyBag methods && null ats && null at_defs
= top_matter
| otherwise
= vcat [ top_matter <+> text "where"
, nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++
map ppr_fam_deflt_eqn at_defs ++
pprLHsBindsForUser methods sigs) ]
where
top_matter = text "class"
<+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
<+> pprFundeps (map unLoc fds)
ppr (XTyClDecl x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (TyClGroup p) where
ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles
, group_instds = instds
}
)
= ppr tyclds $$
ppr roles $$
ppr instds
ppr (XTyClGroup x) = ppr x
pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p))
=> Located (IdP (GhcPass p))
-> LHsQTyVars (GhcPass p)
-> LexicalFixity
-> HsContext (GhcPass p)
-> SDoc
pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
= hsep [pprHsContext context, pp_tyvars tyvars]
where
pp_tyvars (varl:varsr)
| fixity == Infix && length varsr > 1
= hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)
, (ppr.unLoc) (head varsr), char ')'
, hsep (map (ppr.unLoc) (tail varsr))]
| fixity == Infix
= hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)
, hsep (map (ppr.unLoc) varsr)]
| otherwise = hsep [ pprPrefixOcc (unLoc thing)
, hsep (map (ppr.unLoc) (varl:varsr))]
pp_tyvars [] = pprPrefixOcc (unLoc thing)
pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x
pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc
pprTyClDeclFlavour (ClassDecl {}) = text "class"
pprTyClDeclFlavour (SynDecl {}) = text "type"
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
= pprFlavour info <+> text "family"
pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x})
= ppr x
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
= ppr nd
pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x })
= ppr x
pprTyClDeclFlavour (XTyClDecl x) = ppr x
data TyClGroup pass
= TyClGroup { group_ext :: XCTyClGroup pass
, group_tyclds :: [LTyClDecl pass]
, group_roles :: [LRoleAnnotDecl pass]
, group_instds :: [LInstDecl pass] }
| XTyClGroup (XXTyClGroup pass)
type instance XCTyClGroup (GhcPass _) = NoExt
type instance XXTyClGroup (GhcPass _) = NoExt
emptyTyClGroup :: TyClGroup (GhcPass p)
emptyTyClGroup = TyClGroup noExt [] [] []
tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls = concatMap group_tyclds
tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass]
tyClGroupInstDecls = concatMap group_instds
tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]
tyClGroupRoleDecls = concatMap group_roles
mkTyClGroup :: [LTyClDecl (GhcPass p)] -> [LInstDecl (GhcPass p)]
-> TyClGroup (GhcPass p)
mkTyClGroup decls instds = TyClGroup
{ group_ext = noExt
, group_tyclds = decls
, group_roles = []
, group_instds = instds
}
type LFamilyResultSig pass = Located (FamilyResultSig pass)
data FamilyResultSig pass =
NoSig (XNoSig pass)
| KindSig (XCKindSig pass) (LHsKind pass)
| TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass)
| XFamilyResultSig (XXFamilyResultSig pass)
type instance XNoSig (GhcPass _) = NoExt
type instance XCKindSig (GhcPass _) = NoExt
type instance XTyVarSig (GhcPass _) = NoExt
type instance XXFamilyResultSig (GhcPass _) = NoExt
type LFamilyDecl pass = Located (FamilyDecl pass)
data FamilyDecl pass = FamilyDecl
{ fdExt :: XCFamilyDecl pass
, fdInfo :: FamilyInfo pass
, fdLName :: Located (IdP pass)
, fdTyVars :: LHsQTyVars pass
, fdFixity :: LexicalFixity
, fdResultSig :: LFamilyResultSig pass
, fdInjectivityAnn :: Maybe (LInjectivityAnn pass)
}
| XFamilyDecl (XXFamilyDecl pass)
type instance XCFamilyDecl (GhcPass _) = NoExt
type instance XXFamilyDecl (GhcPass _) = NoExt
type LInjectivityAnn pass = Located (InjectivityAnn pass)
data InjectivityAnn pass
= InjectivityAnn (Located (IdP pass)) [Located (IdP pass)]
data FamilyInfo pass
= DataFamily
| OpenTypeFamily
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
famDeclHasCusk :: Maybe Bool
-> FamilyDecl pass -> Bool
famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _
, fdTyVars = tyvars
, fdResultSig = L _ resultSig })
= hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
hasReturnKindSignature :: FamilyResultSig a -> Bool
hasReturnKindSignature (NoSig _) = False
hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False
hasReturnKindSignature _ = True
resultVariableName :: FamilyResultSig a -> Maybe (IdP a)
resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig
resultVariableName _ = Nothing
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (FamilyDecl p) where
ppr = pprFamilyDecl TopLevel
pprFamilyDecl :: (OutputableBndrId (GhcPass p))
=> TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc
pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
, fdTyVars = tyvars
, fdFixity = fixity
, fdResultSig = L _ result
, fdInjectivityAnn = mb_inj })
= vcat [ pprFlavour info <+> pp_top_level <+>
pp_vanilla_decl_head ltycon tyvars fixity [] <+>
pp_kind <+> pp_inj <+> pp_where
, nest 2 $ pp_eqns ]
where
pp_top_level = case top_level of
TopLevel -> text "family"
NotTopLevel -> empty
pp_kind = case result of
NoSig _ -> empty
KindSig _ kind -> dcolon <+> ppr kind
TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr
XFamilyResultSig x -> ppr x
pp_inj = case mb_inj of
Just (L _ (InjectivityAnn lhs rhs)) ->
hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
Nothing -> empty
(pp_where, pp_eqns) = case info of
ClosedTypeFamily mb_eqns ->
( text "where"
, case mb_eqns of
Nothing -> text ".."
Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
_ -> (empty, empty)
pprFamilyDecl _ (XFamilyDecl x) = ppr x
pprFlavour :: FamilyInfo pass -> SDoc
pprFlavour DataFamily = text "data"
pprFlavour OpenTypeFamily = text "type"
pprFlavour (ClosedTypeFamily {}) = text "type"
instance Outputable (FamilyInfo pass) where
ppr info = pprFlavour info <+> text "family"
data HsDataDefn pass
=
HsDataDefn { dd_ext :: XCHsDataDefn pass,
dd_ND :: NewOrData,
dd_ctxt :: LHsContext pass,
dd_cType :: Maybe (Located CType),
dd_kindSig:: Maybe (LHsKind pass),
dd_cons :: [LConDecl pass],
dd_derivs :: HsDeriving pass
}
| XHsDataDefn (XXHsDataDefn pass)
type instance XCHsDataDefn (GhcPass _) = NoExt
type instance XXHsDataDefn (GhcPass _) = NoExt
type HsDeriving pass = Located [LHsDerivingClause pass]
type LHsDerivingClause pass = Located (HsDerivingClause pass)
data HsDerivingClause pass
= HsDerivingClause
{ deriv_clause_ext :: XCHsDerivingClause pass
, deriv_clause_strategy :: Maybe (LDerivStrategy pass)
, deriv_clause_tys :: Located [LHsSigType pass]
}
| XHsDerivingClause (XXHsDerivingClause pass)
type instance XCHsDerivingClause (GhcPass _) = NoExt
type instance XXHsDerivingClause (GhcPass _) = NoExt
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsDerivingClause p) where
ppr (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct })
= hsep [ text "deriving"
, pp_strat_before
, pp_dct dct
, pp_strat_after ]
where
pp_dct [HsIB { hsib_body = ty }]
= ppr (parenthesizeHsType appPrec ty)
pp_dct _ = parens (interpp'SP dct)
(pp_strat_before, pp_strat_after) =
case dcs of
Just (L _ via@ViaStrategy{}) -> (empty, ppr via)
_ -> (ppDerivStrategy dcs, empty)
ppr (XHsDerivingClause x) = ppr x
data NewOrData
= NewType
| DataType
deriving( Eq, Data )
newOrDataToFlavour :: NewOrData -> TyConFlavour
newOrDataToFlavour NewType = NewtypeFlavour
newOrDataToFlavour DataType = DataTypeFlavour
type LConDecl pass = Located (ConDecl pass)
data ConDecl pass
= ConDeclGADT
{ con_g_ext :: XConDeclGADT pass
, con_names :: [Located (IdP pass)]
, con_forall :: Located Bool
, con_qvars :: LHsQTyVars pass
, con_mb_cxt :: Maybe (LHsContext pass)
, con_args :: HsConDeclDetails pass
, con_res_ty :: LHsType pass
, con_doc :: Maybe LHsDocString
}
| ConDeclH98
{ con_ext :: XConDeclH98 pass
, con_name :: Located (IdP pass)
, con_forall :: Located Bool
, con_ex_tvs :: [LHsTyVarBndr pass]
, con_mb_cxt :: Maybe (LHsContext pass)
, con_args :: HsConDeclDetails pass
, con_doc :: Maybe LHsDocString
}
| XConDecl (XXConDecl pass)
type instance XConDeclGADT (GhcPass _) = NoExt
type instance XConDeclH98 (GhcPass _) = NoExt
type instance XXConDecl (GhcPass _) = NoExt
type HsConDeclDetails pass
= HsConDetails (LBangType pass) (Located [LConDeclField pass])
getConNames :: ConDecl pass -> [Located (IdP pass)]
getConNames ConDeclH98 {con_name = name} = [name]
getConNames ConDeclGADT {con_names = names} = names
getConNames XConDecl {} = panic "getConNames"
getConArgs :: ConDecl pass -> HsConDeclDetails pass
getConArgs d = con_args d
hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass]
hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)
hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]
hsConDeclTheta Nothing = []
hsConDeclTheta (Just (L _ theta)) = theta
pp_data_defn :: (OutputableBndrId (GhcPass p))
=> (HsContext (GhcPass p) -> SDoc)
-> HsDataDefn (GhcPass p)
-> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
, dd_cType = mb_ct
, dd_kindSig = mb_sig
, dd_cons = condecls, dd_derivs = derivings })
| null condecls
= ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig
<+> pp_derivings derivings
| otherwise
= hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig)
2 (pp_condecls condecls $$ pp_derivings derivings)
where
pp_ct = case mb_ct of
Nothing -> empty
Just ct -> ppr ct
pp_sig = case mb_sig of
Nothing -> empty
Just kind -> dcolon <+> ppr kind
pp_derivings (L _ ds) = vcat (map ppr ds)
pp_data_defn _ (XHsDataDefn x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsDataDefn p) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
instance Outputable NewOrData where
ppr NewType = text "newtype"
ppr DataType = text "data"
pp_condecls :: (OutputableBndrId (GhcPass p)) => [LConDecl (GhcPass p)] -> SDoc
pp_condecls cs@(L _ ConDeclGADT{} : _)
= hang (text "where") 2 (vcat (map ppr cs))
pp_condecls cs
= equals <+> sep (punctuate (text " |") (map ppr cs))
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDecl p) where
ppr = pprConDecl
pprConDecl :: (OutputableBndrId (GhcPass p)) => ConDecl (GhcPass p) -> SDoc
pprConDecl (ConDeclH98 { con_name = L _ con
, con_ex_tvs = ex_tvs
, con_mb_cxt = mcxt
, con_args = args
, con_doc = doc })
= sep [ppr_mbDoc doc, pprHsForAll ex_tvs cxt, ppr_details args]
where
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
: map (pprHsType . unLoc) tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
cxt = fromMaybe (noLoc []) mcxt
pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
<+> (sep [pprHsForAll (hsq_explicit qvars) cxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
get_args (PrefixCon args) = map ppr args
get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]
get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons)
cxt = fromMaybe (noLoc []) mcxt
ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
ppr_arrow_chain [] = empty
pprConDecl (XConDecl x) = ppr x
ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass)
type HsTyPats pass = [LHsType pass]
type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass)
type LTyFamInstDecl pass = Located (TyFamInstDecl pass)
newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
type LDataFamInstDecl pass = Located (DataFamInstDecl pass)
newtype DataFamInstDecl pass
= DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }
type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)
type FamInstEqn pass rhs
= HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
data FamEqn pass pats rhs
= FamEqn
{ feqn_ext :: XCFamEqn pass pats rhs
, feqn_tycon :: Located (IdP pass)
, feqn_pats :: pats
, feqn_fixity :: LexicalFixity
, feqn_rhs :: rhs
}
| XFamEqn (XXFamEqn pass pats rhs)
type instance XCFamEqn (GhcPass _) p r = NoExt
type instance XXFamEqn (GhcPass _) p r = NoExt
type LClsInstDecl pass = Located (ClsInstDecl pass)
data ClsInstDecl pass
= ClsInstDecl
{ cid_ext :: XCClsInstDecl pass
, cid_poly_ty :: LHsSigType pass
, cid_binds :: LHsBinds pass
, cid_sigs :: [LSig pass]
, cid_tyfam_insts :: [LTyFamInstDecl pass]
, cid_datafam_insts :: [LDataFamInstDecl pass]
, cid_overlap_mode :: Maybe (Located OverlapMode)
}
| XClsInstDecl (XXClsInstDecl pass)
type instance XCClsInstDecl (GhcPass _) = NoExt
type instance XXClsInstDecl (GhcPass _) = NoExt
type LInstDecl pass = Located (InstDecl pass)
data InstDecl pass
= ClsInstD
{ cid_d_ext :: XClsInstD pass
, cid_inst :: ClsInstDecl pass }
| DataFamInstD
{ dfid_ext :: XDataFamInstD pass
, dfid_inst :: DataFamInstDecl pass }
| TyFamInstD
{ tfid_ext :: XTyFamInstD pass
, tfid_inst :: TyFamInstDecl pass }
| XInstDecl (XXInstDecl pass)
type instance XClsInstD (GhcPass _) = NoExt
type instance XDataFamInstD (GhcPass _) = NoExt
type instance XTyFamInstD (GhcPass _) = NoExt
type instance XXInstDecl (GhcPass _) = NoExt
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (TyFamInstDecl p) where
ppr = pprTyFamInstDecl TopLevel
pprTyFamInstDecl :: (OutputableBndrId (GhcPass p))
=> TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc
pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
= text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = text "instance"
ppr_instance_keyword NotTopLevel = empty
ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p))
=> TyFamInstEqn (GhcPass p) -> SDoc
ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs }})
= pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x
ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x
ppr_fam_deflt_eqn :: (OutputableBndrId (GhcPass p))
=> LTyFamDefltEqn (GhcPass p) -> SDoc
ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
, feqn_pats = tvs
, feqn_fixity = fixity
, feqn_rhs = rhs }))
= text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
<+> equals <+> ppr rhs
ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (DataFamInstDecl p) where
ppr = pprDataFamInstDecl TopLevel
pprDataFamInstDecl :: (OutputableBndrId (GhcPass p))
=> TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = tycon
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = defn }}})
= pp_data_defn pp_hdr defn
where
pp_hdr ctxt = ppr_instance_keyword top_lvl
<+> pprFamInstLHS tycon pats fixity ctxt Nothing
pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x)))
= ppr x
pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x))
= ppr x
pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
= ppr nd
pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = XHsDataDefn x}}})
= ppr x
pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x)))
= ppr x
pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x))
= ppr x
pprFamInstLHS :: (OutputableBndrId (GhcPass p))
=> Located (IdP (GhcPass p))
-> HsTyPats (GhcPass p)
-> LexicalFixity
-> HsContext (GhcPass p)
-> Maybe (LHsKind (GhcPass p))
-> SDoc
pprFamInstLHS thing typats fixity context mb_kind_sig
= hsep [ pprHsContext context, pp_pats typats, pp_kind_sig ]
where
pp_pats (patl:patr:pats)
| Infix <- fixity
= let pp_op_app = hsep [ ppr patl, pprInfixOcc (unLoc thing), ppr patr ] in
case pats of
[] -> pp_op_app
_ -> hsep (parens pp_op_app : map ppr pats)
pp_pats pats = hsep [ pprPrefixOcc (unLoc thing)
, hsep (map ppr pats)]
pp_kind_sig
| Just k <- mb_kind_sig
= dcolon <+> ppr k
| otherwise
= empty
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ClsInstDecl p) where
ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = mbOverlap
, cid_datafam_insts = adts })
| null sigs, null ats, null adts, isEmptyBag binds
= top_matter
| otherwise
= vcat [ top_matter <+> text "where"
, nest 2 $ pprDeclList $
map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++
map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
pprLHsBindsForUser binds sigs ]
where
top_matter = text "instance" <+> ppOverlapPragma mbOverlap
<+> ppr inst_ty
ppr (XClsInstDecl x) = ppr x
ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p)
=> Maybe (LDerivStrategy p) -> SDoc
ppDerivStrategy mb =
case mb of
Nothing -> empty
Just (L _ ds) -> ppr ds
ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
ppOverlapPragma mb =
case mb of
Nothing -> empty
Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}"
Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"
Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}"
Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}"
Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}"
where
maybe_stext NoSourceText alt = text alt
maybe_stext (SourceText src) _ = text src <+> text "#-}"
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
ppr (XInstDecl x) = ppr x
instDeclDataFamInsts :: [LInstDecl pass] -> [DataFamInstDecl pass]
instDeclDataFamInsts inst_decls
= concatMap do_one inst_decls
where
do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
= map unLoc fam_insts
do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst]
do_one (L _ (TyFamInstD {})) = []
do_one (L _ (ClsInstD _ (XClsInstDecl _))) = panic "instDeclDataFamInsts"
do_one (L _ (XInstDecl _)) = panic "instDeclDataFamInsts"
type LDerivDecl pass = Located (DerivDecl pass)
data DerivDecl pass = DerivDecl
{ deriv_ext :: XCDerivDecl pass
, deriv_type :: LHsSigWcType pass
, deriv_strategy :: Maybe (LDerivStrategy pass)
, deriv_overlap_mode :: Maybe (Located OverlapMode)
}
| XDerivDecl (XXDerivDecl pass)
type instance XCDerivDecl (GhcPass _) = NoExt
type instance XXDerivDecl (GhcPass _) = NoExt
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (DerivDecl p) where
ppr (DerivDecl { deriv_type = ty
, deriv_strategy = ds
, deriv_overlap_mode = o })
= hsep [ text "deriving"
, ppDerivStrategy ds
, text "instance"
, ppOverlapPragma o
, ppr ty ]
ppr (XDerivDecl x) = ppr x
type LDerivStrategy pass = Located (DerivStrategy pass)
data DerivStrategy pass
= StockStrategy
| AnyclassStrategy
| NewtypeStrategy
| ViaStrategy (XViaStrategy pass)
type instance XViaStrategy GhcPs = LHsSigType GhcPs
type instance XViaStrategy GhcRn = LHsSigType GhcRn
type instance XViaStrategy GhcTc = Type
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (DerivStrategy p) where
ppr StockStrategy = text "stock"
ppr AnyclassStrategy = text "anyclass"
ppr NewtypeStrategy = text "newtype"
ppr (ViaStrategy ty) = text "via" <+> ppr ty
derivStrategyName :: DerivStrategy a -> SDoc
derivStrategyName = text . go
where
go StockStrategy = "stock"
go AnyclassStrategy = "anyclass"
go NewtypeStrategy = "newtype"
go (ViaStrategy {}) = "via"
type LDefaultDecl pass = Located (DefaultDecl pass)
data DefaultDecl pass
= DefaultDecl (XCDefaultDecl pass) [LHsType pass]
| XDefaultDecl (XXDefaultDecl pass)
type instance XCDefaultDecl (GhcPass _) = NoExt
type instance XXDefaultDecl (GhcPass _) = NoExt
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (DefaultDecl p) where
ppr (DefaultDecl _ tys)
= text "default" <+> parens (interpp'SP tys)
ppr (XDefaultDecl x) = ppr x
type LForeignDecl pass = Located (ForeignDecl pass)
data ForeignDecl pass
= ForeignImport
{ fd_i_ext :: XForeignImport pass
, fd_name :: Located (IdP pass)
, fd_sig_ty :: LHsSigType pass
, fd_fi :: ForeignImport }
| ForeignExport
{ fd_e_ext :: XForeignExport pass
, fd_name :: Located (IdP pass)
, fd_sig_ty :: LHsSigType pass
, fd_fe :: ForeignExport }
| XForeignDecl (XXForeignDecl pass)
type instance XForeignImport GhcPs = NoExt
type instance XForeignImport GhcRn = NoExt
type instance XForeignImport GhcTc = Coercion
type instance XForeignExport GhcPs = NoExt
type instance XForeignExport GhcRn = NoExt
type instance XForeignExport GhcTc = Coercion
type instance XXForeignDecl (GhcPass _) = NoExt
data ForeignImport =
CImport (Located CCallConv)
(Located Safety)
(Maybe Header)
CImportSpec
(Located SourceText)
deriving Data
data CImportSpec = CLabel CLabelString
| CFunction CCallTarget
| CWrapper
deriving Data
data ForeignExport = CExport (Located CExportSpec)
(Located SourceText)
deriving Data
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ForeignDecl p) where
ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
= hang (text "foreign import" <+> ppr fimport <+> ppr n)
2 (dcolon <+> ppr ty)
ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =
hang (text "foreign export" <+> ppr fexport <+> ppr n)
2 (dcolon <+> ppr ty)
ppr (XForeignDecl x) = ppr x
instance Outputable ForeignImport where
ppr (CImport cconv safety mHeader spec (L _ srcText)) =
ppr cconv <+> ppr safety
<+> pprWithSourceText srcText (pprCEntity spec "")
where
pp_hdr = case mHeader of
Nothing -> empty
Just (Header _ header) -> ftext header
pprCEntity (CLabel lbl) _ =
doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl
pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =
if dqNeeded then doubleQuotes ce else empty
where
dqNeeded = (take 6 src == "static")
|| isJust mHeader
|| not isFun
|| st /= NoSourceText
ce =
(if take 6 src == "static" then text "static" else empty)
<+> pp_hdr
<+> (if isFun then empty else text "value")
<+> (pprWithSourceText st empty)
pprCEntity (CFunction DynamicTarget) _ =
doubleQuotes $ text "dynamic"
pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"
instance Outputable ForeignExport where
ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) =
ppr cconv <+> char '"' <> ppr lbl <> char '"'
type LRuleDecls pass = Located (RuleDecls pass)
data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass
, rds_src :: SourceText
, rds_rules :: [LRuleDecl pass] }
| XRuleDecls (XXRuleDecls pass)
type instance XCRuleDecls (GhcPass _) = NoExt
type instance XXRuleDecls (GhcPass _) = NoExt
type LRuleDecl pass = Located (RuleDecl pass)
data RuleDecl pass
= HsRule
(XHsRule pass)
(Located (SourceText,RuleName))
Activation
[LRuleBndr pass]
(Located (HsExpr pass))
(Located (HsExpr pass))
| XRuleDecl (XXRuleDecl pass)
data HsRuleRn = HsRuleRn NameSet NameSet
deriving Data
type instance XHsRule GhcPs = NoExt
type instance XHsRule GhcRn = HsRuleRn
type instance XHsRule GhcTc = HsRuleRn
type instance XXRuleDecl (GhcPass _) = NoExt
flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
type LRuleBndr pass = Located (RuleBndr pass)
data RuleBndr pass
= RuleBndr (XCRuleBndr pass) (Located (IdP pass))
| RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass)
| XRuleBndr (XXRuleBndr pass)
type instance XCRuleBndr (GhcPass _) = NoExt
type instance XRuleBndrSig (GhcPass _) = NoExt
type instance XXRuleBndr (GhcPass _) = NoExt
collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (RuleDecls p) where
ppr (HsRules _ st rules)
= pprWithSourceText st (text "{-# RULES")
<+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
ppr (XRuleDecls x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where
ppr (HsRule _ name act ns lhs rhs)
= sep [pprFullRuleName name <+> ppr act,
nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
nest 6 (equals <+> pprExpr (unLoc rhs)) ]
where
pp_forall | null ns = empty
| otherwise = forAllLit <+> fsep (map ppr ns) <> dot
ppr (XRuleDecl x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where
ppr (RuleBndr _ name) = ppr name
ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
ppr (XRuleBndr x) = ppr x
type LDocDecl = Located (DocDecl)
data DocDecl
= DocCommentNext HsDocString
| DocCommentPrev HsDocString
| DocCommentNamed String HsDocString
| DocGroup Int HsDocString
deriving Data
instance Outputable DocDecl where
ppr _ = text "<document comment>"
docDeclDoc :: DocDecl -> HsDocString
docDeclDoc (DocCommentNext d) = d
docDeclDoc (DocCommentPrev d) = d
docDeclDoc (DocCommentNamed _ d) = d
docDeclDoc (DocGroup _ d) = d
type LWarnDecls pass = Located (WarnDecls pass)
data WarnDecls pass = Warnings { wd_ext :: XWarnings pass
, wd_src :: SourceText
, wd_warnings :: [LWarnDecl pass]
}
| XWarnDecls (XXWarnDecls pass)
type instance XWarnings (GhcPass _) = NoExt
type instance XXWarnDecls (GhcPass _) = NoExt
type LWarnDecl pass = Located (WarnDecl pass)
data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt
| XWarnDecl (XXWarnDecl pass)
type instance XWarning (GhcPass _) = NoExt
type instance XXWarnDecl (GhcPass _) = NoExt
instance (p ~ GhcPass pass,OutputableBndr (IdP p))
=> Outputable (WarnDecls p) where
ppr (Warnings _ (SourceText src) decls)
= text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"
ppr (XWarnDecls x) = ppr x
instance (p ~ GhcPass pass, OutputableBndr (IdP p))
=> Outputable (WarnDecl p) where
ppr (Warning _ thing txt)
= hsep ( punctuate comma (map ppr thing))
<+> ppr txt
ppr (XWarnDecl x) = ppr x
type LAnnDecl pass = Located (AnnDecl pass)
data AnnDecl pass = HsAnnotation
(XHsAnnotation pass)
SourceText
(AnnProvenance (IdP pass)) (Located (HsExpr pass))
| XAnnDecl (XXAnnDecl pass)
type instance XHsAnnotation (GhcPass _) = NoExt
type instance XXAnnDecl (GhcPass _) = NoExt
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where
ppr (HsAnnotation _ _ provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
ppr (XAnnDecl x) = ppr x
data AnnProvenance name = ValueAnnProvenance (Located name)
| TypeAnnProvenance (Located name)
| ModuleAnnProvenance
deriving instance Functor AnnProvenance
deriving instance Foldable AnnProvenance
deriving instance Traversable AnnProvenance
deriving instance (Data pass) => Data (AnnProvenance pass)
annProvenanceName_maybe :: AnnProvenance name -> Maybe name
annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name
annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name
annProvenanceName_maybe ModuleAnnProvenance = Nothing
pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
pprAnnProvenance ModuleAnnProvenance = text "ANN module"
pprAnnProvenance (ValueAnnProvenance (L _ name))
= text "ANN" <+> ppr name
pprAnnProvenance (TypeAnnProvenance (L _ name))
= text "ANN type" <+> ppr name
type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass)
data RoleAnnotDecl pass
= RoleAnnotDecl (XCRoleAnnotDecl pass)
(Located (IdP pass))
[Located (Maybe Role)]
| XRoleAnnotDecl (XXRoleAnnotDecl pass)
type instance XCRoleAnnotDecl (GhcPass _) = NoExt
type instance XXRoleAnnotDecl (GhcPass _) = NoExt
instance (p ~ GhcPass pass, OutputableBndr (IdP p))
=> Outputable (RoleAnnotDecl p) where
ppr (RoleAnnotDecl _ ltycon roles)
= text "type role" <+> pprPrefixOcc (unLoc ltycon) <+>
hsep (map (pp_role . unLoc) roles)
where
pp_role Nothing = underscore
pp_role (Just r) = ppr r
ppr (XRoleAnnotDecl x) = ppr x
roleAnnotDeclName :: RoleAnnotDecl pass -> (IdP pass)
roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name
roleAnnotDeclName (XRoleAnnotDecl _) = panic "roleAnnotDeclName"