ghc-lib-parser-0.20210201: compiler/GHC/Hs/Decls.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module Language.Haskell.Syntax.Extension
{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-- | Abstract syntax of global declarations.
--
-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,
-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
module GHC.Hs.Decls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,
NewOrData(..), newOrDataToFlavour,
StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, DataDeclRn(..),
TyClGroup(..),
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
tyClGroupKindSigs,
isClassDecl, isDataDecl, isSynDecl, tcdName,
isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
tyFamInstDeclName, tyFamInstDeclLName,
countTyClDecls, pprTyClDeclFlavour,
tyClDeclLName, tyClDeclTyVars,
hsDeclHasCusk, famResultKindSignature,
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
InstDecl(..), LInstDecl, FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
TyFamDefltDecl, LTyFamDefltDecl,
DataFamInstDecl(..), LDataFamInstDecl,
pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,
FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,
LClsInstDecl, ClsInstDecl(..),
-- ** Standalone deriving declarations
DerivDecl(..), LDerivDecl,
-- ** Deriving strategies
DerivStrategy(..), LDerivStrategy,
derivStrategyName, foldDerivStrategy, mapDerivStrategy,
-- ** @RULE@ declarations
LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
flattenRuleDecls, pprFullRuleName,
-- ** @default@ declarations
DefaultDecl(..), LDefaultDecl,
-- ** Template haskell declaration splice
SpliceExplicitFlag(..),
SpliceDecl(..), LSpliceDecl,
-- ** Foreign function interface declarations
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl,
HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta,
getConNames, getRecConArgs_maybe,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
WarnDecl(..), LWarnDecl,
WarnDecls(..), LWarnDecls,
-- ** Annotations
AnnDecl(..), LAnnDecl,
AnnProvenance(..), annProvenanceName_maybe,
-- ** Role annotations
RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,
-- ** Injective type families
FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,
resultVariableName, familyDeclLName, familyDeclName,
-- * Grouping
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls,
hsGroupTopLevelFixitySigs,
partitionBindsAndSigs,
) where
-- friends:
import GHC.Prelude
import Language.Haskell.Syntax.Decls
import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprSpliceDecl )
-- Because Expr imports Decls via HsBracket
import GHC.Hs.Binds
import GHC.Hs.Type
import GHC.Hs.Doc
import GHC.Types.Basic
import GHC.Core.Coercion
import Language.Haskell.Syntax.Extension
import GHC.Hs.Extension
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Fixity
-- others:
import GHC.Core.Class
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Types.SourceText
import GHC.Core.Type
import GHC.Data.Bag
import GHC.Data.Maybe
{-
************************************************************************
* *
\subsection[HsDecl]{Declarations}
* *
************************************************************************
-}
type instance XTyClD (GhcPass _) = NoExtField
type instance XInstD (GhcPass _) = NoExtField
type instance XDerivD (GhcPass _) = NoExtField
type instance XValD (GhcPass _) = NoExtField
type instance XSigD (GhcPass _) = NoExtField
type instance XKindSigD (GhcPass _) = NoExtField
type instance XDefD (GhcPass _) = NoExtField
type instance XForD (GhcPass _) = NoExtField
type instance XWarningD (GhcPass _) = NoExtField
type instance XAnnD (GhcPass _) = NoExtField
type instance XRuleD (GhcPass _) = NoExtField
type instance XSpliceD (GhcPass _) = NoExtField
type instance XDocD (GhcPass _) = NoExtField
type instance XRoleAnnotD (GhcPass _) = NoExtField
type instance XXHsDecl (GhcPass _) = NoExtCon
-- | Partition a list of HsDecls into function/pattern bindings, signatures,
-- type family declarations, type family instances, and documentation comments.
--
-- Panics when given a declaration that cannot be put into any of the output
-- groups.
--
-- The primary use of this function is to implement
-- 'GHC.Parser.PostProcess.cvBindsAndSigs'.
partitionBindsAndSigs
:: [LHsDecl GhcPs]
-> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
partitionBindsAndSigs = go
where
go [] = (emptyBag, [], [], [], [], [])
go ((L l decl) : ds) =
let (bs, ss, ts, tfis, dfis, docs) = go ds in
case decl of
ValD _ b
-> (L l b `consBag` bs, ss, ts, tfis, dfis, docs)
SigD _ s
-> (bs, L l s : ss, ts, tfis, dfis, docs)
TyClD _ (FamDecl _ t)
-> (bs, ss, L l t : ts, tfis, dfis, docs)
InstD _ (TyFamInstD { tfid_inst = tfi })
-> (bs, ss, ts, L l tfi : tfis, dfis, docs)
InstD _ (DataFamInstD { dfid_inst = dfi })
-> (bs, ss, ts, tfis, L l dfi : dfis, docs)
DocD _ d
-> (bs, ss, ts, tfis, dfis, L l d : docs)
_ -> pprPanic "partitionBindsAndSigs" (ppr decl)
type instance XCHsGroup (GhcPass _) = NoExtField
type instance XXHsGroup (GhcPass _) = NoExtCon
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
emptyGroup = HsGroup { hs_ext = noExtField,
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 = [] }
-- | The fixity signatures for each top-level declaration and class method
-- in an 'HsGroup'.
-- See Note [Top-level fixity signatures in an HsGroup]
hsGroupTopLevelFixitySigs :: HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]
hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =
fixds ++ cls_fixds
where
cls_fixds = [ L loc sig
| L _ ClassDecl{tcdSigs = sigs} <- tyClGroupTyClDecls tyclds
, L loc (FixSig _ sig) <- sigs
]
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 = noExtField,
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 }
instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass 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 (KindSigD _ ksd) = ppr ksd
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
instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass 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 (tyClGroupRoleDecls tycl_decls),
ppr_ds (tyClGroupKindSigs tycl_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
-- Concatenate vertically with white-space between non-blanks
vcat_mb _ [] = empty
vcat_mb gap (Nothing : ds) = vcat_mb gap ds
vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds
type instance XSpliceDecl (GhcPass _) = NoExtField
type instance XXSpliceDecl (GhcPass _) = NoExtCon
instance OutputableBndrId p
=> Outputable (SpliceDecl (GhcPass p)) where
ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f
{-
************************************************************************
* *
Type and class declarations
* *
************************************************************************
-}
type instance XFamDecl (GhcPass _) = NoExtField
type instance XSynDecl GhcPs = NoExtField
type instance XSynDecl GhcRn = NameSet -- FVs
type instance XSynDecl GhcTc = NameSet -- FVs
type instance XDataDecl GhcPs = NoExtField
type instance XDataDecl GhcRn = DataDeclRn
type instance XDataDecl GhcTc = DataDeclRn
type instance XClassDecl GhcPs = LayoutInfo -- See Note [Class LayoutInfo]
type instance XClassDecl GhcRn = NameSet -- FVs
type instance XClassDecl GhcTc = NameSet -- FVs
type instance XXTyClDecl (GhcPass _) = NoExtCon
-- Dealing with names
tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName = unLoc . tyFamInstDeclLName
tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p))
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = ln }})
= ln
tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p))
tyClDeclLName (FamDecl { tcdFam = fd }) = familyDeclLName fd
tyClDeclLName (SynDecl { tcdLName = ln }) = ln
tyClDeclLName (DataDecl { tcdLName = ln }) = ln
tyClDeclLName (ClassDecl { tcdLName = ln }) = ln
-- FIXME: tcdName is commonly used by both GHC and third-party tools, so it
-- needs to be polymorphic in the pass
tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName = unLoc . tyClDeclLName
-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
hsDeclHasCusk :: TyClDecl GhcRn -> Bool
hsDeclHasCusk (FamDecl { tcdFam =
FamilyDecl { fdInfo = fam_info
, fdTyVars = tyvars
, fdResultSig = L _ resultSig } }) =
case fam_info of
ClosedTypeFamily {} -> hsTvbAllKinded tyvars
&& isJust (famResultKindSignature resultSig)
_ -> True -- Un-associated open type/data families have CUSKs
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
= hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs)
hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass 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 noLHsContext <+> 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 -- No "where" part
= top_matter
| otherwise -- Laid out
= vcat [ top_matter <+> text "where"
, nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++
map (pprTyFamDefltDecl . unLoc) at_defs ++
pprLHsBindsForUser methods sigs) ]
where
top_matter = text "class"
<+> pp_vanilla_decl_head lclas tyvars fixity context
<+> pprFundeps (map unLoc fds)
instance OutputableBndrId p
=> Outputable (TyClGroup (GhcPass p)) where
ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles
, group_kisigs = kisigs
, group_instds = instds
}
)
= hang (text "TyClGroup") 2 $
ppr kisigs $$
ppr tyclds $$
ppr roles $$
ppr instds
pp_vanilla_decl_head :: (OutputableBndrId p)
=> Located (IdP (GhcPass p))
-> LHsQTyVars (GhcPass p)
-> LexicalFixity
-> LHsContext (GhcPass p)
-> SDoc
pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
= hsep [pprLHsContext 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)
pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc
pprTyClDeclFlavour (ClassDecl {}) = text "class"
pprTyClDeclFlavour (SynDecl {}) = text "type"
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
= pprFlavour info <+> text "family"
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
= ppr nd
{- *********************************************************************
* *
TyClGroup
Strongly connected components of
type, class, instance, and role declarations
* *
********************************************************************* -}
type instance XCTyClGroup (GhcPass _) = NoExtField
type instance XXTyClGroup (GhcPass _) = NoExtCon
{- *********************************************************************
* *
Data and type family declarations
* *
********************************************************************* -}
type instance XNoSig (GhcPass _) = NoExtField
type instance XCKindSig (GhcPass _) = NoExtField
type instance XTyVarSig (GhcPass _) = NoExtField
type instance XXFamilyResultSig (GhcPass _) = NoExtCon
type instance XCFamilyDecl (GhcPass _) = NoExtField
type instance XXFamilyDecl (GhcPass _) = NoExtCon
------------- Functions over FamilyDecls -----------
familyDeclLName :: FamilyDecl (GhcPass p) -> Located (IdP (GhcPass p))
familyDeclLName (FamilyDecl { fdLName = n }) = n
familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName = unLoc . familyDeclLName
famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature (NoSig _) = Nothing
famResultKindSignature (KindSig _ ki) = Just ki
famResultKindSignature (TyVarSig _ bndr) =
case unLoc bndr of
UserTyVar _ _ _ -> Nothing
KindedTyVar _ _ _ ki -> Just ki
-- | Maybe return name of the result type variable
resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig
resultVariableName _ = Nothing
------------- Pretty printing FamilyDecls -----------
instance OutputableBndrId p
=> Outputable (FamilyDecl (GhcPass p)) where
ppr = pprFamilyDecl TopLevel
pprFamilyDecl :: (OutputableBndrId 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 noLHsContext <+>
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
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)
{- *********************************************************************
* *
Data types and data constructors
* *
********************************************************************* -}
type instance XCHsDataDefn (GhcPass _) = NoExtField
type instance XXHsDataDefn (GhcPass _) = NoExtCon
type instance XCHsDerivingClause (GhcPass _) = NoExtField
type instance XXHsDerivingClause (GhcPass _) = NoExtCon
instance OutputableBndrId p
=> Outputable (HsDerivingClause (GhcPass p)) where
ppr (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct })
= hsep [ text "deriving"
, pp_strat_before
, ppr dct
, pp_strat_after ]
where
-- @via@ is unique in that in comes /after/ the class being derived,
-- so we must special-case it.
(pp_strat_before, pp_strat_after) =
case dcs of
Just (L _ via@ViaStrategy{}) -> (empty, ppr via)
_ -> (ppDerivStrategy dcs, empty)
type instance XDctSingle (GhcPass _) = NoExtField
type instance XDctMulti (GhcPass _) = NoExtField
type instance XXDerivClauseTys (GhcPass _) = NoExtCon
instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where
ppr (DctSingle _ ty) = ppr ty
ppr (DctMulti _ tys) = parens (interpp'SP tys)
type instance XStandaloneKindSig (GhcPass p) = NoExtField
type instance XXStandaloneKindSig (GhcPass p) = NoExtCon
standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname
type instance XConDeclGADT (GhcPass _) = NoExtField
type instance XConDeclH98 (GhcPass _) = NoExtField
type instance XXConDecl (GhcPass _) = NoExtCon
getConNames :: ConDecl GhcRn -> [Located Name]
getConNames ConDeclH98 {con_name = name} = [name]
getConNames ConDeclGADT {con_names = names} = names
-- | Return @'Just' fields@ if a data constructor declaration uses record
-- syntax (i.e., 'RecCon'), where @fields@ are the field selectors.
-- Otherwise, return 'Nothing'.
getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (Located [LConDeclField GhcRn])
getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of
PrefixCon{} -> Nothing
RecCon flds -> Just flds
InfixCon{} -> Nothing
getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of
PrefixConGADT{} -> Nothing
RecConGADT flds -> Just flds
hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]
hsConDeclTheta Nothing = []
hsConDeclTheta (Just (L _ theta)) = theta
pp_data_defn :: (OutputableBndrId p)
=> (LHsContext (GhcPass p) -> SDoc) -- Printing the header
-> HsDataDefn (GhcPass p)
-> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = 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)
instance OutputableBndrId p
=> Outputable (HsDataDefn (GhcPass p)) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
instance OutputableBndrId p
=> Outputable (StandaloneKindSig (GhcPass p)) where
ppr (StandaloneKindSig _ v ki)
= text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki
pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc
pp_condecls cs
| gadt_syntax -- In GADT syntax
= hang (text "where") 2 (vcat (map ppr cs))
| otherwise -- In H98 syntax
= equals <+> sep (punctuate (text " |") (map ppr cs))
where
gadt_syntax = case cs of
[] -> False
(L _ ConDeclH98{} : _) -> False
(L _ ConDeclGADT{} : _) -> True
instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where
ppr = pprConDecl
pprConDecl :: forall p. OutputableBndrId 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 (mkHsForAllInvisTele ex_tvs) cxt
, ppr_details args ]
where
-- In ppr_details: let's not print the multiplicities (they are always 1, by
-- definition) as they do not appear in an actual declaration.
ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),
pprInfixOcc con,
ppr (hsScaledThing t2)]
ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con
: map (pprHsType . unLoc . hsScaledThing) tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
cxt = fromMaybe noLHsContext mcxt
pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
<+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext cxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
get_args (PrefixConGADT args) = map ppr args
get_args (RecConGADT fields) = [pprConDeclFields (unLoc fields)]
cxt = fromMaybe noLHsContext mcxt
ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
ppr_arrow_chain [] = empty
ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
{-
************************************************************************
* *
Instance declarations
* *
************************************************************************
-}
type instance XCFamEqn (GhcPass _) r = NoExtField
type instance XXFamEqn (GhcPass _) r = NoExtCon
----------------- Class instances -------------
type instance XCClsInstDecl (GhcPass _) = NoExtField
type instance XXClsInstDecl (GhcPass _) = NoExtCon
----------------- Instances of all kinds -------------
type instance XClsInstD (GhcPass _) = NoExtField
type instance XDataFamInstD (GhcPass _) = NoExtField
type instance XTyFamInstD (GhcPass _) = NoExtField
type instance XXInstDecl (GhcPass _) = NoExtCon
instance OutputableBndrId p
=> Outputable (TyFamInstDecl (GhcPass p)) where
ppr = pprTyFamInstDecl TopLevel
pprTyFamInstDecl :: (OutputableBndrId 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
pprTyFamDefltDecl :: (OutputableBndrId p)
=> TyFamDefltDecl (GhcPass p) -> SDoc
pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel
ppr_fam_inst_eqn :: (OutputableBndrId p)
=> TyFamInstEqn (GhcPass p) -> SDoc
ppr_fam_inst_eqn (FamEqn { feqn_tycon = L _ tycon
, feqn_bndrs = bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs })
= pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs
instance OutputableBndrId p
=> Outputable (DataFamInstDecl (GhcPass p)) where
ppr = pprDataFamInstDecl TopLevel
pprDataFamInstDecl :: (OutputableBndrId p)
=> TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn =
(FamEqn { feqn_tycon = L _ tycon
, feqn_bndrs = bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = defn })})
= pp_data_defn pp_hdr defn
where
pp_hdr ctxt = ppr_instance_keyword top_lvl
<+> pprHsFamInstLHS tycon bndrs pats fixity ctxt
-- pp_data_defn pretty-prints the kind sig. See #14817.
pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn =
(FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }})})
= ppr nd
pprHsFamInstLHS :: (OutputableBndrId p)
=> IdP (GhcPass p)
-> HsOuterFamEqnTyVarBndrs (GhcPass p)
-> HsTyPats (GhcPass p)
-> LexicalFixity
-> LHsContext (GhcPass p)
-> SDoc
pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
= hsep [ pprHsOuterFamEqnTyVarBndrs bndrs
, pprLHsContext mb_ctxt
, pp_pats typats ]
where
pp_pats (patl:patr:pats)
| Infix <- fixity
= let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in
case pats of
[] -> pp_op_app
_ -> hsep (parens pp_op_app : map ppr pats)
pp_pats pats = hsep [ pprPrefixOcc thing
, hsep (map ppr pats)]
instance OutputableBndrId p
=> Outputable (ClsInstDecl (GhcPass 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 -- No "where" part
= top_matter
| otherwise -- Laid out
= 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
ppDerivStrategy :: OutputableBndrId p
=> Maybe (LDerivStrategy (GhcPass 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 (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
-- Extract the declarations of associated data types from an instance
instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)]
instDeclDataFamInsts inst_decls
= concatMap do_one inst_decls
where
do_one :: LInstDecl (GhcPass p) -> [DataFamInstDecl (GhcPass p)]
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 {})) = []
{-
************************************************************************
* *
\subsection[DerivDecl]{A stand-alone instance deriving declaration}
* *
************************************************************************
-}
type instance XCDerivDecl (GhcPass _) = NoExtField
type instance XXDerivDecl (GhcPass _) = NoExtCon
instance OutputableBndrId p
=> Outputable (DerivDecl (GhcPass 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 ]
{-
************************************************************************
* *
Deriving strategies
* *
************************************************************************
-}
type instance XViaStrategy GhcPs = LHsSigType GhcPs
type instance XViaStrategy GhcRn = LHsSigType GhcRn
type instance XViaStrategy GhcTc = Type
instance OutputableBndrId p
=> Outputable (DerivStrategy (GhcPass p)) where
ppr StockStrategy = text "stock"
ppr AnyclassStrategy = text "anyclass"
ppr NewtypeStrategy = text "newtype"
ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of
GhcPs -> ppr ty
GhcRn -> ppr ty
GhcTc -> ppr ty
-- | Eliminate a 'DerivStrategy'.
foldDerivStrategy :: (p ~ GhcPass pass)
=> r -> (XViaStrategy p -> r) -> DerivStrategy p -> r
foldDerivStrategy other _ StockStrategy = other
foldDerivStrategy other _ AnyclassStrategy = other
foldDerivStrategy other _ NewtypeStrategy = other
foldDerivStrategy _ via (ViaStrategy t) = via t
-- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise,
-- return the 'DerivStrategy' unchanged.
mapDerivStrategy :: (p ~ GhcPass pass)
=> (XViaStrategy p -> XViaStrategy p)
-> DerivStrategy p -> DerivStrategy p
mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds
{-
************************************************************************
* *
\subsection[DefaultDecl]{A @default@ declaration}
* *
************************************************************************
-}
type instance XCDefaultDecl (GhcPass _) = NoExtField
type instance XXDefaultDecl (GhcPass _) = NoExtCon
instance OutputableBndrId p
=> Outputable (DefaultDecl (GhcPass p)) where
ppr (DefaultDecl _ tys)
= text "default" <+> parens (interpp'SP tys)
{-
************************************************************************
* *
\subsection{Foreign function interface declaration}
* *
************************************************************************
-}
type instance XForeignImport GhcPs = NoExtField
type instance XForeignImport GhcRn = NoExtField
type instance XForeignImport GhcTc = Coercion
type instance XForeignExport GhcPs = NoExtField
type instance XForeignExport GhcRn = NoExtField
type instance XForeignExport GhcTc = Coercion
type instance XXForeignDecl (GhcPass _) = NoExtCon
instance OutputableBndrId p
=> Outputable (ForeignDecl (GhcPass 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)
{-
************************************************************************
* *
\subsection{Rewrite rules}
* *
************************************************************************
-}
type instance XCRuleDecls (GhcPass _) = NoExtField
type instance XXRuleDecls (GhcPass _) = NoExtCon
type instance XHsRule GhcPs = NoExtField
type instance XHsRule GhcRn = HsRuleRn
type instance XHsRule GhcTc = HsRuleRn
type instance XXRuleDecl (GhcPass _) = NoExtCon
flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
type instance XCRuleBndr (GhcPass _) = NoExtField
type instance XRuleBndrSig (GhcPass _) = NoExtField
type instance XXRuleBndr (GhcPass _) = NoExtCon
instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where
ppr (HsRules { rds_src = st
, rds_rules = rules })
= pprWithSourceText st (text "{-# RULES")
<+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where
ppr (HsRule { rd_name = name
, rd_act = act
, rd_tyvs = tys
, rd_tmvs = tms
, rd_lhs = lhs
, rd_rhs = rhs })
= sep [pprFullRuleName name <+> ppr act,
nest 4 (pp_forall_ty tys <+> pp_forall_tm tys
<+> pprExpr (unLoc lhs)),
nest 6 (equals <+> pprExpr (unLoc rhs)) ]
where
pp_forall_ty Nothing = empty
pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
pp_forall_tm Nothing | null tms = empty
pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot
instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
ppr (RuleBndr _ name) = ppr name
ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
{-
************************************************************************
* *
\subsection[DeprecDecl]{Deprecations}
* *
************************************************************************
-}
type instance XWarnings (GhcPass _) = NoExtField
type instance XXWarnDecls (GhcPass _) = NoExtCon
type instance XWarning (GhcPass _) = NoExtField
type instance XXWarnDecl (GhcPass _) = NoExtCon
instance OutputableBndr (IdP (GhcPass p))
=> Outputable (WarnDecls (GhcPass p)) where
ppr (Warnings _ (SourceText src) decls)
= text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"
instance OutputableBndr (IdP (GhcPass p))
=> Outputable (WarnDecl (GhcPass p)) where
ppr (Warning _ thing txt)
= hsep ( punctuate comma (map ppr thing))
<+> ppr txt
{-
************************************************************************
* *
\subsection[AnnDecl]{Annotations}
* *
************************************************************************
-}
type instance XHsAnnotation (GhcPass _) = NoExtField
type instance XXAnnDecl (GhcPass _) = NoExtCon
instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where
ppr (HsAnnotation _ _ provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
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
{-
************************************************************************
* *
\subsection[RoleAnnot]{Role annotations}
* *
************************************************************************
-}
type instance XCRoleAnnotDecl (GhcPass _) = NoExtField
type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon
instance OutputableBndr (IdP (GhcPass p))
=> Outputable (RoleAnnotDecl (GhcPass 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
roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name