module HsExpr where
#include "HsVersions.h"
import GhcPrelude
import HsDecls
import HsPat
import HsLit
import PlaceHolder ( NameOrRdrName )
import HsExtension
import HsTypes
import HsBinds
import TcEvidence
import CoreSyn
import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) )
import Name
import NameSet
import RdrName ( GlobalRdrEnv )
import BasicTypes
import ConLike
import SrcLoc
import Util
import Outputable
import FastString
import Type
import Data.Data hiding (Fixity(..))
import qualified Data.Data as Data (Fixity(..))
import Data.Maybe (isNothing)
import GHCi.RemoteTypes ( ForeignRef )
import qualified Language.Haskell.TH as TH (Q)
type LHsExpr p = Located (HsExpr p)
type PostTcExpr = HsExpr GhcTc
type PostTcTable = [(Name, PostTcExpr)]
data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p
, syn_arg_wraps :: [HsWrapper]
, syn_res_wrap :: HsWrapper }
noExpr :: HsExpr (GhcPass p)
noExpr = HsLit noExt (HsString (SourceText "noExpr") (fsLit "noExpr"))
noSyntaxExpr :: SyntaxExpr (GhcPass p)
noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExt (HsString NoSourceText
(fsLit "noSyntaxExpr"))
, syn_arg_wraps = []
, syn_res_wrap = WpHole }
mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn
mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar noExt $ noLoc name
, syn_arg_wraps = []
, syn_res_wrap = WpHole }
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (SyntaxExpr p) where
ppr (SyntaxExpr { syn_expr = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
= sdocWithDynFlags $ \ dflags ->
getPprStyle $ \s ->
if debugStyle s || gopt Opt_PrintExplicitCoercions dflags
then ppr expr <> braces (pprWithCommas ppr arg_wraps)
<> braces (ppr res_wrap)
else ppr expr
type CmdSyntaxTable p = [(Name, HsExpr p)]
data UnboundVar
= OutOfScope OccName GlobalRdrEnv
| TrueExprHole OccName
deriving Data
instance Outputable UnboundVar where
ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ)
ppr (TrueExprHole occ) = text "ExprHole" <> parens (ppr occ)
unboundVarOcc :: UnboundVar -> OccName
unboundVarOcc (OutOfScope occ _) = occ
unboundVarOcc (TrueExprHole occ) = occ
data HsExpr p
= HsVar (XVar p)
(Located (IdP p))
| HsUnboundVar (XUnboundVar p)
UnboundVar
| HsConLikeOut (XConLikeOut p)
ConLike
| HsRecFld (XRecFld p)
(AmbiguousFieldOcc p)
| HsOverLabel (XOverLabel p)
(Maybe (IdP p)) FastString
| HsIPVar (XIPVar p)
HsIPName
| HsOverLit (XOverLitE p)
(HsOverLit p)
| HsLit (XLitE p)
(HsLit p)
| HsLam (XLam p)
(MatchGroup p (LHsExpr p))
| HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p))
| HsApp (XApp p) (LHsExpr p) (LHsExpr p)
| HsAppType (XAppTypeE p) (LHsExpr p)
| OpApp (XOpApp p)
(LHsExpr p)
(LHsExpr p)
(LHsExpr p)
| NegApp (XNegApp p)
(LHsExpr p)
(SyntaxExpr p)
| HsPar (XPar p)
(LHsExpr p)
| SectionL (XSectionL p)
(LHsExpr p)
(LHsExpr p)
| SectionR (XSectionR p)
(LHsExpr p)
(LHsExpr p)
| ExplicitTuple
(XExplicitTuple p)
[LHsTupArg p]
Boxity
| ExplicitSum
(XExplicitSum p)
ConTag
Arity
(LHsExpr p)
| HsCase (XCase p)
(LHsExpr p)
(MatchGroup p (LHsExpr p))
| HsIf (XIf p)
(Maybe (SyntaxExpr p))
(LHsExpr p)
(LHsExpr p)
(LHsExpr p)
| HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)]
| HsLet (XLet p)
(LHsLocalBinds p)
(LHsExpr p)
| HsDo (XDo p)
(HsStmtContext Name)
(Located [ExprLStmt p])
| ExplicitList
(XExplicitList p)
(Maybe (SyntaxExpr p))
[LHsExpr p]
| RecordCon
{ rcon_ext :: XRecordCon p
, rcon_con_name :: Located (IdP p)
, rcon_flds :: HsRecordBinds p }
| RecordUpd
{ rupd_ext :: XRecordUpd p
, rupd_expr :: LHsExpr p
, rupd_flds :: [LHsRecUpdField p]
}
| ExprWithTySig
(XExprWithTySig p)
(LHsExpr p)
| ArithSeq
(XArithSeq p)
(Maybe (SyntaxExpr p))
(ArithSeqInfo p)
| HsSCC (XSCC p)
SourceText
StringLiteral
(LHsExpr p)
| HsCoreAnn (XCoreAnn p)
SourceText
StringLiteral
(LHsExpr p)
| HsBracket (XBracket p) (HsBracket p)
| HsRnBracketOut
(XRnBracketOut p)
(HsBracket GhcRn)
[PendingRnSplice]
| HsTcBracketOut
(XTcBracketOut p)
(HsBracket GhcRn)
[PendingTcSplice]
| HsSpliceE (XSpliceE p) (HsSplice p)
| HsProc (XProc p)
(LPat p)
(LHsCmdTop p)
| HsStatic (XStatic p)
(LHsExpr p)
| HsArrApp
(XArrApp p)
(LHsExpr p)
(LHsExpr p)
HsArrAppType
Bool
| HsArrForm
(XArrForm p)
(LHsExpr p)
(Maybe Fixity)
[LHsCmdTop p]
| HsTick
(XTick p)
(Tickish (IdP p))
(LHsExpr p)
| HsBinTick
(XBinTick p)
Int
Int
(LHsExpr p)
| HsTickPragma
(XTickPragma p)
SourceText
(StringLiteral,(Int,Int),(Int,Int))
((SourceText,SourceText),(SourceText,SourceText))
(LHsExpr p)
| EWildPat (XEWildPat p)
| EAsPat (XEAsPat p)
(Located (IdP p))
(LHsExpr p)
| EViewPat (XEViewPat p)
(LHsExpr p)
(LHsExpr p)
| ELazyPat (XELazyPat p) (LHsExpr p)
| HsWrap (XWrap p)
HsWrapper
(HsExpr p)
| XExpr (XXExpr p)
data RecordConTc = RecordConTc
{ rcon_con_like :: ConLike
, rcon_con_expr :: PostTcExpr
}
data RecordUpdTc = RecordUpdTc
{ rupd_cons :: [ConLike]
, rupd_in_tys :: [Type]
, rupd_out_tys :: [Type]
, rupd_wrap :: HsWrapper
} deriving Data
type instance XVar (GhcPass _) = NoExt
type instance XUnboundVar (GhcPass _) = NoExt
type instance XConLikeOut (GhcPass _) = NoExt
type instance XRecFld (GhcPass _) = NoExt
type instance XOverLabel (GhcPass _) = NoExt
type instance XIPVar (GhcPass _) = NoExt
type instance XOverLitE (GhcPass _) = NoExt
type instance XLitE (GhcPass _) = NoExt
type instance XLam (GhcPass _) = NoExt
type instance XLamCase (GhcPass _) = NoExt
type instance XApp (GhcPass _) = NoExt
type instance XAppTypeE GhcPs = LHsWcType GhcPs
type instance XAppTypeE GhcRn = LHsWcType GhcRn
type instance XAppTypeE GhcTc = LHsWcType GhcRn
type instance XOpApp GhcPs = NoExt
type instance XOpApp GhcRn = Fixity
type instance XOpApp GhcTc = Fixity
type instance XNegApp (GhcPass _) = NoExt
type instance XPar (GhcPass _) = NoExt
type instance XSectionL (GhcPass _) = NoExt
type instance XSectionR (GhcPass _) = NoExt
type instance XExplicitTuple (GhcPass _) = NoExt
type instance XExplicitSum GhcPs = NoExt
type instance XExplicitSum GhcRn = NoExt
type instance XExplicitSum GhcTc = [Type]
type instance XCase (GhcPass _) = NoExt
type instance XIf (GhcPass _) = NoExt
type instance XMultiIf GhcPs = NoExt
type instance XMultiIf GhcRn = NoExt
type instance XMultiIf GhcTc = Type
type instance XLet (GhcPass _) = NoExt
type instance XDo GhcPs = NoExt
type instance XDo GhcRn = NoExt
type instance XDo GhcTc = Type
type instance XExplicitList GhcPs = NoExt
type instance XExplicitList GhcRn = NoExt
type instance XExplicitList GhcTc = Type
type instance XRecordCon GhcPs = NoExt
type instance XRecordCon GhcRn = NoExt
type instance XRecordCon GhcTc = RecordConTc
type instance XRecordUpd GhcPs = NoExt
type instance XRecordUpd GhcRn = NoExt
type instance XRecordUpd GhcTc = RecordUpdTc
type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs)
type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn)
type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn)
type instance XArithSeq GhcPs = NoExt
type instance XArithSeq GhcRn = NoExt
type instance XArithSeq GhcTc = PostTcExpr
type instance XSCC (GhcPass _) = NoExt
type instance XCoreAnn (GhcPass _) = NoExt
type instance XBracket (GhcPass _) = NoExt
type instance XRnBracketOut (GhcPass _) = NoExt
type instance XTcBracketOut (GhcPass _) = NoExt
type instance XSpliceE (GhcPass _) = NoExt
type instance XProc (GhcPass _) = NoExt
type instance XStatic GhcPs = NoExt
type instance XStatic GhcRn = NameSet
type instance XStatic GhcTc = NameSet
type instance XArrApp GhcPs = NoExt
type instance XArrApp GhcRn = NoExt
type instance XArrApp GhcTc = Type
type instance XArrForm (GhcPass _) = NoExt
type instance XTick (GhcPass _) = NoExt
type instance XBinTick (GhcPass _) = NoExt
type instance XTickPragma (GhcPass _) = NoExt
type instance XEWildPat (GhcPass _) = NoExt
type instance XEAsPat (GhcPass _) = NoExt
type instance XEViewPat (GhcPass _) = NoExt
type instance XELazyPat (GhcPass _) = NoExt
type instance XWrap (GhcPass _) = NoExt
type instance XXExpr (GhcPass _) = NoExt
type LHsTupArg id = Located (HsTupArg id)
data HsTupArg id
= Present (XPresent id) (LHsExpr id)
| Missing (XMissing id)
| XTupArg (XXTupArg id)
type instance XPresent (GhcPass _) = NoExt
type instance XMissing GhcPs = NoExt
type instance XMissing GhcRn = NoExt
type instance XMissing GhcTc = Type
type instance XXTupArg (GhcPass _) = NoExt
tupArgPresent :: LHsTupArg id -> Bool
tupArgPresent (L _ (Present {})) = True
tupArgPresent (L _ (Missing {})) = False
tupArgPresent (L _ (XTupArg {})) = False
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) where
ppr expr = pprExpr expr
pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
pprLExpr (L _ e) = pprExpr e
pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e
| otherwise = pprDeeper (ppr_expr e)
isQuietHsExpr :: HsExpr id -> Bool
isQuietHsExpr (HsPar {}) = True
isQuietHsExpr (HsApp {}) = True
isQuietHsExpr (HsAppType {}) = True
isQuietHsExpr (OpApp {}) = True
isQuietHsExpr _ = False
pprBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
=> HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprBinds b = pprDeeper (ppr b)
ppr_lexpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
ppr_expr :: forall p. (OutputableBndrId (GhcPass p))
=> HsExpr (GhcPass p) -> SDoc
ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v
ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv)
ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c
ppr_expr (HsIPVar _ v) = ppr v
ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l
ppr_expr (HsLit _ lit) = ppr lit
ppr_expr (HsOverLit _ lit) = ppr lit
ppr_expr (HsPar _ e) = parens (ppr_lexpr e)
ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e)
= vcat [pprWithSourceText stc (text "{-# CORE")
<+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
, ppr_lexpr e]
ppr_expr e@(HsApp {}) = ppr_apps e []
ppr_expr e@(HsAppType {}) = ppr_apps e []
ppr_expr (OpApp _ e1 op e2)
| Just pp_op <- should_print_infix (unLoc op)
= pp_infixly pp_op
| otherwise
= pp_prefixly
where
should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v)
should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c))
should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f)
should_print_infix (HsUnboundVar _ h@TrueExprHole{})
= Just (pprInfixOcc (unboundVarOcc h))
should_print_infix (EWildPat _) = Just (text "`_`")
should_print_infix (HsWrap _ _ e) = should_print_infix e
should_print_infix _ = Nothing
pp_e1 = pprDebugParendExpr opPrec e1
pp_e2 = pprDebugParendExpr opPrec e2
pp_prefixly
= hang (ppr op) 2 (sep [pp_e1, pp_e2])
pp_infixly pp_op
= hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])
ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e
ppr_expr (SectionL _ expr op)
= case unLoc op of
HsVar _ (L _ v) -> pp_infixly v
HsConLikeOut _ c -> pp_infixly (conLikeName c)
HsUnboundVar _ h@TrueExprHole{}
-> pp_infixly (unboundVarOcc h)
_ -> pp_prefixly
where
pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, text "x_ )"])
pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
pp_infixly v = (sep [pp_expr, pprInfixOcc v])
ppr_expr (SectionR _ op expr)
= case unLoc op of
HsVar _ (L _ v) -> pp_infixly v
HsConLikeOut _ c -> pp_infixly (conLikeName c)
HsUnboundVar _ h@TrueExprHole{}
-> pp_infixly (unboundVarOcc h)
_ -> pp_prefixly
where
pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
4 (pp_expr <> rparen)
pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
pp_infixly v = sep [pprInfixOcc v, pp_expr]
ppr_expr (ExplicitTuple _ exprs boxity)
= tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
where
ppr_tup_args [] = []
ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es
punc (Present {} : _) = comma <> space
punc (Missing {} : _) = comma
punc (XTupArg {} : _) = comma <> space
punc [] = empty
ppr_expr (ExplicitSum _ alt arity expr)
= text "(#" <+> ppr_bars (alt 1) <+> ppr expr <+> ppr_bars (arity alt) <+> text "#)"
where
ppr_bars n = hsep (replicate n (char '|'))
ppr_expr (HsLam _ matches)
= pprMatches matches
ppr_expr (HsLamCase _ matches)
= sep [ sep [text "\\case"],
nest 2 (pprMatches matches) ]
ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] }))
= sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],
nest 2 (pprMatches matches) <+> char '}']
ppr_expr (HsCase _ expr matches)
= sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
nest 2 (pprMatches matches) ]
ppr_expr (HsIf _ _ e1 e2 e3)
= sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],
nest 4 (ppr e2),
text "else",
nest 4 (ppr e3)]
ppr_expr (HsMultiIf _ alts)
= hang (text "if") 3 (vcat (map ppr_alt alts))
where ppr_alt (L _ (GRHS _ guards expr)) =
hang vbar 2 (ppr_one one_alt)
where
ppr_one [] = panic "ppr_exp HsMultiIf"
ppr_one (h:t) = hang h 2 (sep t)
one_alt = [ interpp'SP guards
, text "->" <+> pprDeeper (ppr expr) ]
ppr_alt (L _ (XGRHS x)) = ppr x
ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _)))
= sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lexpr expr]
ppr_expr (HsLet _ (L _ binds) expr)
= sep [hang (text "let") 2 (pprBinds binds),
hang (text "in") 2 (ppr expr)]
ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
= hang (ppr con_id) 2 (ppr rbinds)
ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
= hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
ppr_expr (ExprWithTySig sig expr)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
ppr_expr (EWildPat _) = char '_'
ppr_expr (ELazyPat _ e) = char '~' <> ppr e
ppr_expr (EAsPat _ (L _ v) e) = pprPrefixOcc v <> char '@' <> ppr e
ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e
ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr)
= sep [ pprWithSourceText st (text "{-# SCC")
<+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
ppr expr ]
ppr_expr (HsWrap _ co_fn e)
= pprHsWrapper co_fn (\parens -> if parens then pprExpr e
else pprExpr e)
ppr_expr (HsSpliceE _ s) = pprSplice s
ppr_expr (HsBracket _ b) = pprHsBracket b
ppr_expr (HsRnBracketOut _ e []) = ppr e
ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
ppr_expr (HsTcBracketOut _ e []) = ppr e
ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
= hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
ppr_expr (HsProc _ pat (L _ (XCmdTop x)))
= hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x]
ppr_expr (HsStatic _ e)
= hsep [text "static", ppr e]
ppr_expr (HsTick _ tickish exp)
= pprTicks (ppr exp) $
ppr tickish <+> ppr_lexpr exp
ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
= pprTicks (ppr exp) $
hcat [text "bintick<",
ppr tickIdTrue,
text ",",
ppr tickIdFalse,
text ">(",
ppr exp, text ")"]
ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
= pprTicks (ppr exp) $
hcat [text "tickpragma<",
pprExternalSrcLoc externalSrcLoc,
text ">(",
ppr exp,
text ")"]
ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp False)
= hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp True)
= hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp False)
= hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
ppr_expr (HsArrForm _ (L _ (HsVar _ (L _ v))) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
ppr_expr (HsArrForm _ (L _ (HsConLikeOut _ c)) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]]
ppr_expr (HsArrForm _ op _ args)
= hang (text "(|" <+> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
ppr_expr (HsRecFld _ f) = ppr f
ppr_expr (XExpr x) = ppr x
ppr_apps :: (OutputableBndrId (GhcPass p))
=> HsExpr (GhcPass p)
-> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))]
-> SDoc
ppr_apps (HsApp _ (L _ fun) arg) args
= ppr_apps fun (Left arg : args)
ppr_apps (HsAppType arg (L _ fun)) args
= ppr_apps fun (Right arg : args)
ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
where
pp (Left arg) = ppr arg
pp (Right arg)
= char '@' <> ppr arg
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
= ppr (src,(n1,n2),(n3,n4))
pprDebugParendExpr :: (OutputableBndrId (GhcPass p))
=> PprPrec -> LHsExpr (GhcPass p) -> SDoc
pprDebugParendExpr p expr
= getPprStyle (\sty ->
if debugStyle sty then pprParendLExpr p expr
else pprLExpr expr)
pprParendLExpr :: (OutputableBndrId (GhcPass p))
=> PprPrec -> LHsExpr (GhcPass p) -> SDoc
pprParendLExpr p (L _ e) = pprParendExpr p e
pprParendExpr :: (OutputableBndrId (GhcPass p))
=> PprPrec -> HsExpr (GhcPass p) -> SDoc
pprParendExpr p expr
| hsExprNeedsParens p expr = parens (pprExpr expr)
| otherwise = pprExpr expr
hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool
hsExprNeedsParens p = go
where
go (HsVar{}) = False
go (HsUnboundVar{}) = False
go (HsConLikeOut{}) = False
go (HsIPVar{}) = False
go (HsOverLabel{}) = False
go (HsLit _ l) = hsLitNeedsParens p l
go (HsOverLit _ ol) = hsOverLitNeedsParens p ol
go (HsPar{}) = False
go (HsCoreAnn _ _ _ (L _ e)) = go e
go (HsApp{}) = p >= appPrec
go (HsAppType {}) = p >= appPrec
go (OpApp{}) = p >= opPrec
go (NegApp{}) = p > topPrec
go (SectionL{}) = True
go (SectionR{}) = True
go (ExplicitTuple{}) = False
go (ExplicitSum{}) = False
go (HsLam{}) = p > topPrec
go (HsLamCase{}) = p > topPrec
go (HsCase{}) = p > topPrec
go (HsIf{}) = p > topPrec
go (HsMultiIf{}) = p > topPrec
go (HsLet{}) = p > topPrec
go (HsDo _ sc _)
| isListCompExpr sc = False
| otherwise = p > topPrec
go (ExplicitList{}) = False
go (RecordUpd{}) = False
go (ExprWithTySig{}) = p > topPrec
go (ArithSeq{}) = False
go (EWildPat{}) = False
go (ELazyPat{}) = False
go (EAsPat{}) = False
go (EViewPat{}) = True
go (HsSCC{}) = p >= appPrec
go (HsWrap _ _ e) = go e
go (HsSpliceE{}) = False
go (HsBracket{}) = False
go (HsRnBracketOut{}) = False
go (HsTcBracketOut{}) = False
go (HsProc{}) = p > topPrec
go (HsStatic{}) = p >= appPrec
go (HsTick _ _ (L _ e)) = go e
go (HsBinTick _ _ _ (L _ e)) = go e
go (HsTickPragma _ _ _ _ (L _ e)) = go e
go (HsArrApp{}) = True
go (HsArrForm{}) = True
go (RecordCon{}) = False
go (HsRecFld{}) = False
go (XExpr{}) = True
parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr p le@(L loc e)
| hsExprNeedsParens p e = L loc (HsPar NoExt le)
| otherwise = le
isAtomicHsExpr :: HsExpr id -> Bool
isAtomicHsExpr (HsVar {}) = True
isAtomicHsExpr (HsConLikeOut {}) = True
isAtomicHsExpr (HsLit {}) = True
isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsOverLabel {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True
isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e
isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr (HsRecFld{}) = True
isAtomicHsExpr _ = False
type LHsCmd id = Located (HsCmd id)
data HsCmd id
= HsCmdArrApp
(XCmdArrApp id)
(LHsExpr id)
(LHsExpr id)
HsArrAppType
Bool
| HsCmdArrForm
(XCmdArrForm id)
(LHsExpr id)
LexicalFixity
(Maybe Fixity)
[LHsCmdTop id]
| HsCmdApp (XCmdApp id)
(LHsCmd id)
(LHsExpr id)
| HsCmdLam (XCmdLam id)
(MatchGroup id (LHsCmd id))
| HsCmdPar (XCmdPar id)
(LHsCmd id)
| HsCmdCase (XCmdCase id)
(LHsExpr id)
(MatchGroup id (LHsCmd id))
| HsCmdIf (XCmdIf id)
(Maybe (SyntaxExpr id))
(LHsExpr id)
(LHsCmd id)
(LHsCmd id)
| HsCmdLet (XCmdLet id)
(LHsLocalBinds id)
(LHsCmd id)
| HsCmdDo (XCmdDo id)
(Located [CmdLStmt id])
| HsCmdWrap (XCmdWrap id)
HsWrapper
(HsCmd id)
| XCmd (XXCmd id)
type instance XCmdArrApp GhcPs = NoExt
type instance XCmdArrApp GhcRn = NoExt
type instance XCmdArrApp GhcTc = Type
type instance XCmdArrForm (GhcPass _) = NoExt
type instance XCmdApp (GhcPass _) = NoExt
type instance XCmdLam (GhcPass _) = NoExt
type instance XCmdPar (GhcPass _) = NoExt
type instance XCmdCase (GhcPass _) = NoExt
type instance XCmdIf (GhcPass _) = NoExt
type instance XCmdLet (GhcPass _) = NoExt
type instance XCmdDo GhcPs = NoExt
type instance XCmdDo GhcRn = NoExt
type instance XCmdDo GhcTc = Type
type instance XCmdWrap (GhcPass _) = NoExt
type instance XXCmd (GhcPass _) = NoExt
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
deriving Data
type LHsCmdTop p = Located (HsCmdTop p)
data HsCmdTop p
= HsCmdTop (XCmdTop p)
(LHsCmd p)
| XCmdTop (XXCmdTop p)
data CmdTopTc
= CmdTopTc Type
Type
(CmdSyntaxTable GhcTc)
type instance XCmdTop GhcPs = NoExt
type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn
type instance XCmdTop GhcTc = CmdTopTc
type instance XXCmdTop (GhcPass _) = NoExt
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where
ppr cmd = pprCmd cmd
pprLCmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
pprLCmd (L _ c) = pprCmd c
pprCmd :: (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
pprCmd c | isQuietHsCmd c = ppr_cmd c
| otherwise = pprDeeper (ppr_cmd c)
isQuietHsCmd :: HsCmd id -> Bool
isQuietHsCmd (HsCmdPar {}) = True
isQuietHsCmd (HsCmdApp {}) = True
isQuietHsCmd _ = False
ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)
ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)
ppr_cmd (HsCmdApp _ c e)
= let (fun, args) = collect_args c [e] in
hang (ppr_lcmd fun) 2 (sep (map ppr args))
where
collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
ppr_cmd (HsCmdLam _ matches)
= pprMatches matches
ppr_cmd (HsCmdCase _ expr matches)
= sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
nest 2 (pprMatches matches) ]
ppr_cmd (HsCmdIf _ _ e ct ce)
= sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],
nest 4 (ppr ct),
text "else",
nest 4 (ppr ce)]
ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {})))
= sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lcmd cmd]
ppr_cmd (HsCmdLet _ (L _ binds) cmd)
= sep [hang (text "let") 2 (pprBinds binds),
hang (text "in") 2 (ppr cmd)]
ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts
ppr_cmd (HsCmdWrap _ w cmd)
= pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)
= hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
= hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
= hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
, pprCmdArg (unLoc arg2)])
ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
, pprCmdArg (unLoc arg2)])
ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
, pprCmdArg (unLoc arg2)])
ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2])
= hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
, pprCmdArg (unLoc arg2)])
ppr_cmd (HsCmdArrForm _ op _ _ args)
= hang (text "(|" <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
ppr_cmd (XCmd x) = ppr x
pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc
pprCmdArg (HsCmdTop _ cmd)
= ppr_lcmd cmd
pprCmdArg (XCmdTop x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where
ppr = pprCmdArg
type HsRecordBinds p = HsRecFields p (LHsExpr p)
data MatchGroup p body
= MG { mg_ext :: XMG p body
, mg_alts :: Located [LMatch p body]
, mg_origin :: Origin }
| XMatchGroup (XXMatchGroup p body)
data MatchGroupTc
= MatchGroupTc
{ mg_arg_tys :: [Type]
, mg_res_ty :: Type
} deriving Data
type instance XMG GhcPs b = NoExt
type instance XMG GhcRn b = NoExt
type instance XMG GhcTc b = MatchGroupTc
type instance XXMatchGroup (GhcPass _) b = NoExt
type LMatch id body = Located (Match id body)
data Match p body
= Match {
m_ext :: XCMatch p body,
m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)),
m_pats :: [LPat p],
m_grhss :: (GRHSs p body)
}
| XMatch (XXMatch p body)
type instance XCMatch (GhcPass _) b = NoExt
type instance XXMatch (GhcPass _) b = NoExt
instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body)
=> Outputable (Match idR body) where
ppr = pprMatch
isInfixMatch :: Match id body -> Bool
isInfixMatch match = case m_ctxt match of
FunRhs {mc_fixity = Infix} -> True
_ -> False
isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
isEmptyMatchGroup (XMatchGroup{}) = panic "isEmptyMatchGroup"
isSingletonMatchGroup :: [LMatch id body] -> Bool
isSingletonMatchGroup matches
| [L _ match] <- matches
, Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match
= True
| otherwise
= False
matchGroupArity :: MatchGroup id body -> Arity
matchGroupArity (MG { mg_alts = alts })
| L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
| otherwise = panic "matchGroupArity"
matchGroupArity (XMatchGroup{}) = panic "matchGroupArity"
hsLMatchPats :: LMatch id body -> [LPat id]
hsLMatchPats (L _ (Match { m_pats = pats })) = pats
hsLMatchPats (L _ (XMatch _)) = panic "hsLMatchPats"
data GRHSs p body
= GRHSs {
grhssExt :: XCGRHSs p body,
grhssGRHSs :: [LGRHS p body],
grhssLocalBinds :: LHsLocalBinds p
}
| XGRHSs (XXGRHSs p body)
type instance XCGRHSs (GhcPass _) b = NoExt
type instance XXGRHSs (GhcPass _) b = NoExt
type LGRHS id body = Located (GRHS id body)
data GRHS p body = GRHS (XCGRHS p body)
[GuardLStmt p]
body
| XGRHS (XXGRHS p body)
type instance XCGRHS (GhcPass _) b = NoExt
type instance XXGRHS (GhcPass _) b = NoExt
pprMatches :: (OutputableBndrId (GhcPass idR), Outputable body)
=> MatchGroup (GhcPass idR) body -> SDoc
pprMatches MG { mg_alts = matches }
= vcat (map pprMatch (map unLoc (unLoc matches)))
pprMatches (XMatchGroup x) = ppr x
pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
=> MatchGroup (GhcPass idR) body -> SDoc
pprFunBind matches = pprMatches matches
pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
OutputableBndrId (GhcPass p),
Outputable body)
=> LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprPatBind pat (grhss)
= sep [ppr pat,
nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)]
pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body)
=> Match (GhcPass idR) body -> SDoc
pprMatch match
= sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)
, nest 2 (pprGRHSs ctxt (m_grhss match)) ]
where
ctxt = m_ctxt match
(herald, other_pats)
= case ctxt of
FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}
| strictness == SrcStrict -> ASSERT(null $ m_pats match)
(char '!'<>pprPrefixOcc fun, m_pats match)
| fixity == Prefix -> (pprPrefixOcc fun, m_pats match)
| null pats2 -> (pp_infix, [])
| otherwise -> (parens pp_infix, pats2)
where
pp_infix = pprParendLPat opPrec pat1
<+> pprInfixOcc fun
<+> pprParendLPat opPrec pat2
LambdaExpr -> (char '\\', m_pats match)
_ -> if null (m_pats match)
then (empty, [])
else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
(ppr pat1, [])
(pat1:pats1) = m_pats match
(pat2:pats2) = pats1
pprGRHSs :: (OutputableBndrId (GhcPass idR), Outputable body)
=> HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc
pprGRHSs ctxt (GRHSs _ grhss (L _ binds))
= vcat (map (pprGRHS ctxt . unLoc) grhss)
$$ ppUnless (eqEmptyLocalBinds binds)
(text "where" $$ nest 4 (pprBinds binds))
pprGRHSs _ (XGRHSs x) = ppr x
pprGRHS :: (OutputableBndrId (GhcPass idR), Outputable body)
=> HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc
pprGRHS ctxt (GRHS _ [] body)
= pp_rhs ctxt body
pprGRHS ctxt (GRHS _ guards body)
= sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]
pprGRHS _ (XGRHS x) = ppr x
pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
type LStmt id body = Located (StmtLR id id body)
type LStmtLR idL idR body = Located (StmtLR idL idR body)
type Stmt id body = StmtLR id id body
type CmdLStmt id = LStmt id (LHsCmd id)
type CmdStmt id = Stmt id (LHsCmd id)
type ExprLStmt id = LStmt id (LHsExpr id)
type ExprStmt id = Stmt id (LHsExpr id)
type GuardLStmt id = LStmt id (LHsExpr id)
type GuardStmt id = Stmt id (LHsExpr id)
type GhciLStmt id = LStmt id (LHsExpr id)
type GhciStmt id = Stmt id (LHsExpr id)
data StmtLR idL idR body
= LastStmt
(XLastStmt idL idR body)
body
Bool
(SyntaxExpr idR)
| BindStmt (XBindStmt idL idR body)
(LPat idL)
body
(SyntaxExpr idR)
(SyntaxExpr idR)
| ApplicativeStmt
(XApplicativeStmt idL idR body)
[ ( SyntaxExpr idR
, ApplicativeArg idL) ]
(Maybe (SyntaxExpr idR))
| BodyStmt (XBodyStmt idL idR body)
body
(SyntaxExpr idR)
(SyntaxExpr idR)
| LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR)
| ParStmt (XParStmt idL idR body)
[ParStmtBlock idL idR]
(HsExpr idR)
(SyntaxExpr idR)
| TransStmt {
trS_ext :: XTransStmt idL idR body,
trS_form :: TransForm,
trS_stmts :: [ExprLStmt idL],
trS_bndrs :: [(IdP idR, IdP idR)],
trS_using :: LHsExpr idR,
trS_by :: Maybe (LHsExpr idR),
trS_ret :: SyntaxExpr idR,
trS_bind :: SyntaxExpr idR,
trS_fmap :: HsExpr idR
}
| RecStmt
{ recS_ext :: XRecStmt idL idR body
, recS_stmts :: [LStmtLR idL idR body]
, recS_later_ids :: [IdP idR]
, recS_rec_ids :: [IdP idR]
, recS_bind_fn :: SyntaxExpr idR
, recS_ret_fn :: SyntaxExpr idR
, recS_mfix_fn :: SyntaxExpr idR
}
| XStmtLR (XXStmtLR idL idR body)
data RecStmtTc =
RecStmtTc
{ recS_bind_ty :: Type
, recS_later_rets :: [PostTcExpr]
, recS_rec_rets :: [PostTcExpr]
, recS_ret_ty :: Type
}
type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExt
type instance XBindStmt (GhcPass _) GhcPs b = NoExt
type instance XBindStmt (GhcPass _) GhcRn b = NoExt
type instance XBindStmt (GhcPass _) GhcTc b = Type
type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExt
type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExt
type instance XApplicativeStmt (GhcPass _) GhcTc b = Type
type instance XBodyStmt (GhcPass _) GhcPs b = NoExt
type instance XBodyStmt (GhcPass _) GhcRn b = NoExt
type instance XBodyStmt (GhcPass _) GhcTc b = Type
type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExt
type instance XParStmt (GhcPass _) GhcPs b = NoExt
type instance XParStmt (GhcPass _) GhcRn b = NoExt
type instance XParStmt (GhcPass _) GhcTc b = Type
type instance XTransStmt (GhcPass _) GhcPs b = NoExt
type instance XTransStmt (GhcPass _) GhcRn b = NoExt
type instance XTransStmt (GhcPass _) GhcTc b = Type
type instance XRecStmt (GhcPass _) GhcPs b = NoExt
type instance XRecStmt (GhcPass _) GhcRn b = NoExt
type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc
type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExt
data TransForm
= ThenForm
| GroupForm
deriving Data
data ParStmtBlock idL idR
= ParStmtBlock
(XParStmtBlock idL idR)
[ExprLStmt idL]
[IdP idR]
(SyntaxExpr idR)
| XParStmtBlock (XXParStmtBlock idL idR)
type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt
type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt
data ApplicativeArg idL
= ApplicativeArgOne
(XApplicativeArgOne idL)
(LPat idL)
(LHsExpr idL)
Bool
| ApplicativeArgMany
(XApplicativeArgMany idL)
[ExprLStmt idL]
(HsExpr idL)
(LPat idL)
| XApplicativeArg (XXApplicativeArg idL)
type instance XApplicativeArgOne (GhcPass _) = NoExt
type instance XApplicativeArgMany (GhcPass _) = NoExt
type instance XXApplicativeArg (GhcPass _) = NoExt
instance (Outputable (StmtLR idL idL (LHsExpr idL)),
Outputable (XXParStmtBlock idL idR))
=> Outputable (ParStmtBlock idL idR) where
ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
ppr (XParStmtBlock x) = ppr x
instance (idL ~ GhcPass pl,idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR,
Outputable body)
=> Outputable (StmtLR idL idR body) where
ppr stmt = pprStmt stmt
pprStmt :: forall idL idR body . (OutputableBndrId (GhcPass idL),
OutputableBndrId (GhcPass idR),
Outputable body)
=> (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc
pprStmt (LastStmt _ expr ret_stripped _)
= whenPprDebug (text "[last]") <+>
(if ret_stripped then text "return" else empty) <+>
ppr expr
pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr]
pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds]
pprStmt (BodyStmt _ expr _ _) = ppr expr
pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss))
pprStmt (TransStmt { trS_stmts = stmts, trS_by = by
, trS_using = using, trS_form = form })
= sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])
pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
, recS_later_ids = later_ids })
= text "rec" <+>
vcat [ ppr_do_stmts segment
, whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids
, text "later_ids=" <> ppr later_ids])]
pprStmt (ApplicativeStmt _ args mb_join)
= getPprStyle $ \style ->
if userStyle style
then pp_for_user
else pp_debug
where
pp_for_user = vcat $ concatMap flattenArg args
flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args
flattenStmt stmt = [ppr stmt]
flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
flattenArg (_, ApplicativeArgOne _ pat expr isBody)
| isBody =
[ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))]
| otherwise =
[ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))]
flattenArg (_, ApplicativeArgMany _ stmts _ _) =
concatMap flattenStmt stmts
flattenArg (_, XApplicativeArg _) = panic "flattenArg"
pp_debug =
let
ap_expr = sep (punctuate (text " |") (map pp_arg args))
in
if isNothing mb_join
then ap_expr
else text "join" <+> parens ap_expr
pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
pp_arg (_, ApplicativeArgOne _ pat expr isBody)
| isBody =
ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))
| otherwise =
ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))
pp_arg (_, ApplicativeArgMany _ stmts return pat) =
ppr pat <+>
text "<-" <+>
ppr (HsDo (panic "pprStmt") DoExpr (noLoc
(stmts ++
[noLoc (LastStmt noExt (noLoc return) False noSyntaxExpr)])))
pp_arg (_, XApplicativeArg x) = ppr x
pprStmt (XStmtLR x) = ppr x
pprTransformStmt :: (OutputableBndrId (GhcPass p))
=> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
-> Maybe (LHsExpr (GhcPass p)) -> SDoc
pprTransformStmt bndrs using by
= sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))
, nest 2 (ppr using)
, nest 2 (pprBy by)]
pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc
pprTransStmt by using ThenForm
= sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]
pprTransStmt by using GroupForm
= sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]
pprBy :: Outputable body => Maybe body -> SDoc
pprBy Nothing = empty
pprBy (Just e) = text "by" <+> ppr e
pprDo :: (OutputableBndrId (GhcPass p), Outputable body)
=> HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts
pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts
pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts
pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts
pprDo ListComp stmts = brackets $ pprComp stmts
pprDo MonadComp stmts = brackets $ pprComp stmts
pprDo _ _ = panic "pprDo"
ppr_do_stmts :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR),
Outputable body)
=> [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
pprComp :: (OutputableBndrId (GhcPass p), Outputable body)
=> [LStmt (GhcPass p) body] -> SDoc
pprComp quals
| Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals
= if null initStmts
then ppr body
else hang (ppr body <+> vbar) 2 (pprQuals initStmts)
| otherwise
= pprPanic "pprComp" (pprQuals quals)
pprQuals :: (OutputableBndrId (GhcPass p), Outputable body)
=> [LStmt (GhcPass p) body] -> SDoc
pprQuals quals = interpp'SP quals
data HsSplice id
= HsTypedSplice
(XTypedSplice id)
SpliceDecoration
(IdP id)
(LHsExpr id)
| HsUntypedSplice
(XUntypedSplice id)
SpliceDecoration
(IdP id)
(LHsExpr id)
| HsQuasiQuote
(XQuasiQuote id)
(IdP id)
(IdP id)
SrcSpan
FastString
| HsSpliced
(XSpliced id)
ThModFinalizers
(HsSplicedThing id)
| XSplice (XXSplice id)
type instance XTypedSplice (GhcPass _) = NoExt
type instance XUntypedSplice (GhcPass _) = NoExt
type instance XQuasiQuote (GhcPass _) = NoExt
type instance XSpliced (GhcPass _) = NoExt
type instance XXSplice (GhcPass _) = NoExt
data SpliceDecoration
= HasParens
| HasDollar
| NoParens
deriving (Data, Eq, Show)
instance Outputable SpliceDecoration where
ppr x = text $ show x
isTypedSplice :: HsSplice id -> Bool
isTypedSplice (HsTypedSplice {}) = True
isTypedSplice _ = False
newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]
instance Data ThModFinalizers where
gunfold _ z _ = z $ ThModFinalizers []
toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix
dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a]
data HsSplicedThing id
= HsSplicedExpr (HsExpr id)
| HsSplicedTy (HsType id)
| HsSplicedPat (Pat id)
type SplicePointName = Name
data PendingRnSplice
= PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)
data UntypedSpliceFlavour
= UntypedExpSplice
| UntypedPatSplice
| UntypedTypeSplice
| UntypedDeclSplice
deriving Data
data PendingTcSplice
= PendingTcSplice SplicePointName (LHsExpr GhcTc)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsSplicedThing p) where
ppr (HsSplicedExpr e) = ppr_expr e
ppr (HsSplicedTy t) = ppr t
ppr (HsSplicedPat p) = ppr p
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsSplice p) where
ppr s = pprSplice s
pprPendingSplice :: (OutputableBndrId (GhcPass p))
=> SplicePointName -> LHsExpr (GhcPass p) -> SDoc
pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
pprSpliceDecl :: (OutputableBndrId (GhcPass p))
=> HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")"
pprSpliceDecl e ImplicitSplice = ppr_splice_decl e
ppr_splice_decl :: (OutputableBndrId (GhcPass p))
=> HsSplice (GhcPass p) -> SDoc
ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty
ppr_splice_decl e = pprSplice e
pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
pprSplice (HsTypedSplice _ HasParens n e)
= ppr_splice (text "$$(") n e (text ")")
pprSplice (HsTypedSplice _ HasDollar n e)
= ppr_splice (text "$$") n e empty
pprSplice (HsTypedSplice _ NoParens n e)
= ppr_splice empty n e empty
pprSplice (HsUntypedSplice _ HasParens n e)
= ppr_splice (text "$(") n e (text ")")
pprSplice (HsUntypedSplice _ HasDollar n e)
= ppr_splice (text "$") n e empty
pprSplice (HsUntypedSplice _ NoParens n e)
= ppr_splice empty n e empty
pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s
pprSplice (HsSpliced _ _ thing) = ppr thing
pprSplice (XSplice x) = ppr x
ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc
ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
char '[' <> ppr quoter <> vbar <>
ppr quote <> text "|]"
ppr_splice :: (OutputableBndrId (GhcPass p))
=> SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc
ppr_splice herald n e trail
= herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
data HsBracket p
= ExpBr (XExpBr p) (LHsExpr p)
| PatBr (XPatBr p) (LPat p)
| DecBrL (XDecBrL p) [LHsDecl p]
| DecBrG (XDecBrG p) (HsGroup p)
| TypBr (XTypBr p) (LHsType p)
| VarBr (XVarBr p) Bool (IdP p)
| TExpBr (XTExpBr p) (LHsExpr p)
| XBracket (XXBracket p)
type instance XExpBr (GhcPass _) = NoExt
type instance XPatBr (GhcPass _) = NoExt
type instance XDecBrL (GhcPass _) = NoExt
type instance XDecBrG (GhcPass _) = NoExt
type instance XTypBr (GhcPass _) = NoExt
type instance XVarBr (GhcPass _) = NoExt
type instance XTExpBr (GhcPass _) = NoExt
type instance XXBracket (GhcPass _) = NoExt
isTypedBracket :: HsBracket id -> Bool
isTypedBracket (TExpBr {}) = True
isTypedBracket _ = False
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsBracket p) where
ppr = pprHsBracket
pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc
pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e)
pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p)
pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))
pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t)
pprHsBracket (VarBr _ True n)
= char '\'' <> pprPrefixOcc n
pprHsBracket (VarBr _ False n)
= text "''" <> pprPrefixOcc n
pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e)
pprHsBracket (XBracket e) = ppr e
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
pp_body <+> text "|]"
thTyBrackets :: SDoc -> SDoc
thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]")
instance Outputable PendingRnSplice where
ppr (PendingRnSplice _ n e) = pprPendingSplice n e
instance Outputable PendingTcSplice where
ppr (PendingTcSplice n e) = pprPendingSplice n e
data ArithSeqInfo id
= From (LHsExpr id)
| FromThen (LHsExpr id)
(LHsExpr id)
| FromTo (LHsExpr id)
(LHsExpr id)
| FromThenTo (LHsExpr id)
(LHsExpr id)
(LHsExpr id)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ArithSeqInfo p) where
ppr (From e1) = hcat [ppr e1, pp_dotdot]
ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3]
ppr (FromThenTo e1 e2 e3)
= hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
pp_dotdot :: SDoc
pp_dotdot = text " .. "
data HsMatchContext id
= FunRhs { mc_fun :: Located id
, mc_fixity :: LexicalFixity
, mc_strictness :: SrcStrictness
}
| LambdaExpr
| CaseAlt
| IfAlt
| ProcExpr
| PatBindRhs
| PatBindGuards
| RecUpd
| StmtCtxt (HsStmtContext id)
| ThPatSplice
| ThPatQuote
| PatSyn
deriving Functor
deriving instance (Data id) => Data (HsMatchContext id)
instance OutputableBndr id => Outputable (HsMatchContext id) where
ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
ppr LambdaExpr = text "LambdaExpr"
ppr CaseAlt = text "CaseAlt"
ppr IfAlt = text "IfAlt"
ppr ProcExpr = text "ProcExpr"
ppr PatBindRhs = text "PatBindRhs"
ppr PatBindGuards = text "PatBindGuards"
ppr RecUpd = text "RecUpd"
ppr (StmtCtxt _) = text "StmtCtxt _"
ppr ThPatSplice = text "ThPatSplice"
ppr ThPatQuote = text "ThPatQuote"
ppr PatSyn = text "PatSyn"
isPatSynCtxt :: HsMatchContext id -> Bool
isPatSynCtxt ctxt =
case ctxt of
PatSyn -> True
_ -> False
data HsStmtContext id
= ListComp
| MonadComp
| DoExpr
| MDoExpr
| ArrowExpr
| GhciStmtCtxt
| PatGuard (HsMatchContext id)
| ParStmtCtxt (HsStmtContext id)
| TransStmtCtxt (HsStmtContext id)
deriving Functor
deriving instance (Data id) => Data (HsStmtContext id)
isListCompExpr :: HsStmtContext id -> Bool
isListCompExpr ListComp = True
isListCompExpr MonadComp = True
isListCompExpr (ParStmtCtxt c) = isListCompExpr c
isListCompExpr (TransStmtCtxt c) = isListCompExpr c
isListCompExpr _ = False
isMonadFailStmtContext :: HsStmtContext id -> Bool
isMonadFailStmtContext MonadComp = True
isMonadFailStmtContext DoExpr = True
isMonadFailStmtContext MDoExpr = True
isMonadFailStmtContext GhciStmtCtxt = True
isMonadFailStmtContext (ParStmtCtxt ctxt) = isMonadFailStmtContext ctxt
isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt
isMonadFailStmtContext _ = False
matchSeparator :: HsMatchContext id -> SDoc
matchSeparator (FunRhs {}) = text "="
matchSeparator CaseAlt = text "->"
matchSeparator IfAlt = text "->"
matchSeparator LambdaExpr = text "->"
matchSeparator ProcExpr = text "->"
matchSeparator PatBindRhs = text "="
matchSeparator PatBindGuards = text "="
matchSeparator (StmtCtxt _) = text "<-"
matchSeparator RecUpd = text "="
matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
matchSeparator PatSyn = panic "unused"
pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id)
=> HsMatchContext id -> SDoc
pprMatchContext ctxt
| want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
| otherwise = text "a" <+> pprMatchContextNoun ctxt
where
want_an (FunRhs {}) = True
want_an ProcExpr = True
want_an _ = False
pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)
=> HsMatchContext id -> SDoc
pprMatchContextNoun (FunRhs {mc_fun=L _ fun})
= text "equation for"
<+> quotes (ppr fun)
pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun IfAlt = text "multi-way if alternative"
pprMatchContextNoun RecUpd = text "record-update construct"
pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"
pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"
pprMatchContextNoun PatBindRhs = text "pattern binding"
pprMatchContextNoun PatBindGuards = text "pattern binding guards"
pprMatchContextNoun LambdaExpr = text "lambda abstraction"
pprMatchContextNoun ProcExpr = text "arrow abstraction"
pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
$$ pprAStmtContext ctxt
pprMatchContextNoun PatSyn = text "pattern synonym declaration"
pprAStmtContext, pprStmtContext :: (Outputable id,
Outputable (NameOrRdrName id))
=> HsStmtContext id -> SDoc
pprAStmtContext ctxt = article <+> pprStmtContext ctxt
where
pp_an = text "an"
pp_a = text "a"
article = case ctxt of
MDoExpr -> pp_an
GhciStmtCtxt -> pp_an
_ -> pp_a
pprStmtContext GhciStmtCtxt = text "interactive GHCi command"
pprStmtContext DoExpr = text "'do' block"
pprStmtContext MDoExpr = text "'mdo' block"
pprStmtContext ArrowExpr = text "'do' block in an arrow command"
pprStmtContext ListComp = text "list comprehension"
pprStmtContext MonadComp = text "monad comprehension"
pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt
pprStmtContext (ParStmtCtxt c) =
ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])
(pprStmtContext c)
pprStmtContext (TransStmtCtxt c) =
ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
(pprStmtContext c)
instance (Outputable p, Outputable (NameOrRdrName p))
=> Outputable (HsStmtContext p) where
ppr = pprStmtContext
matchContextErrString :: Outputable id
=> HsMatchContext id -> SDoc
matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
matchContextErrString IfAlt = text "multi-way if"
matchContextErrString PatBindRhs = text "pattern binding"
matchContextErrString PatBindGuards = text "pattern binding guards"
matchContextErrString RecUpd = text "record update"
matchContextErrString LambdaExpr = text "lambda"
matchContextErrString ProcExpr = text "proc"
matchContextErrString ThPatSplice = panic "matchContextErrString"
matchContextErrString ThPatQuote = panic "matchContextErrString"
matchContextErrString PatSyn = panic "matchContextErrString"
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command"
matchContextErrString (StmtCtxt DoExpr) = text "'do' block"
matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block"
matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block"
matchContextErrString (StmtCtxt ListComp) = text "list comprehension"
matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension"
pprMatchInCtxt :: (OutputableBndrId (GhcPass idR),
Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),
Outputable body)
=> Match (GhcPass idR) body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
<> colon)
4 (pprMatch match)
pprStmtInCtxt :: (OutputableBndrId (GhcPass idL),
OutputableBndrId (GhcPass idR),
Outputable body)
=> HsStmtContext (IdP (GhcPass idL))
-> StmtLR (GhcPass idL) (GhcPass idR) body
-> SDoc
pprStmtInCtxt ctxt (LastStmt _ e _ _)
| isListCompExpr ctxt
= hang (text "In the expression:") 2 (ppr e)
pprStmtInCtxt ctxt stmt
= hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)
2 (ppr_stmt stmt)
where
ppr_stmt (TransStmt { trS_by = by, trS_using = using
, trS_form = form }) = pprTransStmt by using form
ppr_stmt stmt = pprStmt stmt