module GHC.Hs.Expr where
#include "HsVersions.h"
import GhcPrelude
import GHC.Hs.Decls
import GHC.Hs.Pat
import GHC.Hs.Lit
import GHC.Hs.PlaceHolder ( NameOrRdrName )
import GHC.Hs.Extension
import GHC.Hs.Types
import GHC.Hs.Binds
import TcEvidence
import CoreSyn
import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) )
import Name
import NameSet
import BasicTypes
import ConLike
import SrcLoc
import Util
import Outputable
import FastString
import Type
import TysWiredIn (mkTupleStr)
import TcType (TcType)
import TcRnTypes (TcLclEnv)
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 noExtField (HsString (SourceText "noExpr") (fsLit "noExpr"))
noSyntaxExpr :: SyntaxExpr (GhcPass p)
noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExtField
(HsString NoSourceText
(fsLit "noSyntaxExpr"))
, syn_arg_wraps = []
, syn_res_wrap = WpHole }
mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p)
mkSyntaxExpr expr = SyntaxExpr { syn_expr = expr
, syn_arg_wraps = []
, syn_res_wrap = WpHole }
mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn
mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name
instance OutputableBndrId p
=> Outputable (SyntaxExpr (GhcPass 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 HsExpr p
= HsVar (XVar p)
(Located (IdP p))
| HsUnboundVar (XUnboundVar p)
OccName
| 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) (LHsWcType (NoGhcTc 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)
(LHsSigWcType (NoGhcTc 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)
| 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)
| 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 _) = NoExtField
type instance XUnboundVar (GhcPass _) = NoExtField
type instance XConLikeOut (GhcPass _) = NoExtField
type instance XRecFld (GhcPass _) = NoExtField
type instance XOverLabel (GhcPass _) = NoExtField
type instance XIPVar (GhcPass _) = NoExtField
type instance XOverLitE (GhcPass _) = NoExtField
type instance XLitE (GhcPass _) = NoExtField
type instance XLam (GhcPass _) = NoExtField
type instance XLamCase (GhcPass _) = NoExtField
type instance XApp (GhcPass _) = NoExtField
type instance XAppTypeE (GhcPass _) = NoExtField
type instance XOpApp GhcPs = NoExtField
type instance XOpApp GhcRn = Fixity
type instance XOpApp GhcTc = Fixity
type instance XNegApp (GhcPass _) = NoExtField
type instance XPar (GhcPass _) = NoExtField
type instance XSectionL (GhcPass _) = NoExtField
type instance XSectionR (GhcPass _) = NoExtField
type instance XExplicitTuple (GhcPass _) = NoExtField
type instance XExplicitSum GhcPs = NoExtField
type instance XExplicitSum GhcRn = NoExtField
type instance XExplicitSum GhcTc = [Type]
type instance XCase (GhcPass _) = NoExtField
type instance XIf (GhcPass _) = NoExtField
type instance XMultiIf GhcPs = NoExtField
type instance XMultiIf GhcRn = NoExtField
type instance XMultiIf GhcTc = Type
type instance XLet (GhcPass _) = NoExtField
type instance XDo GhcPs = NoExtField
type instance XDo GhcRn = NoExtField
type instance XDo GhcTc = Type
type instance XExplicitList GhcPs = NoExtField
type instance XExplicitList GhcRn = NoExtField
type instance XExplicitList GhcTc = Type
type instance XRecordCon GhcPs = NoExtField
type instance XRecordCon GhcRn = NoExtField
type instance XRecordCon GhcTc = RecordConTc
type instance XRecordUpd GhcPs = NoExtField
type instance XRecordUpd GhcRn = NoExtField
type instance XRecordUpd GhcTc = RecordUpdTc
type instance XExprWithTySig (GhcPass _) = NoExtField
type instance XArithSeq GhcPs = NoExtField
type instance XArithSeq GhcRn = NoExtField
type instance XArithSeq GhcTc = PostTcExpr
type instance XSCC (GhcPass _) = NoExtField
type instance XCoreAnn (GhcPass _) = NoExtField
type instance XBracket (GhcPass _) = NoExtField
type instance XRnBracketOut (GhcPass _) = NoExtField
type instance XTcBracketOut (GhcPass _) = NoExtField
type instance XSpliceE (GhcPass _) = NoExtField
type instance XProc (GhcPass _) = NoExtField
type instance XStatic GhcPs = NoExtField
type instance XStatic GhcRn = NameSet
type instance XStatic GhcTc = NameSet
type instance XTick (GhcPass _) = NoExtField
type instance XBinTick (GhcPass _) = NoExtField
type instance XTickPragma (GhcPass _) = NoExtField
type instance XWrap (GhcPass _) = NoExtField
type instance XXExpr (GhcPass _) = NoExtCon
type LHsTupArg id = Located (HsTupArg id)
data HsTupArg id
= Present (XPresent id) (LHsExpr id)
| Missing (XMissing id)
| XTupArg (XXTupArg id)
type instance XPresent (GhcPass _) = NoExtField
type instance XMissing GhcPs = NoExtField
type instance XMissing GhcRn = NoExtField
type instance XMissing GhcTc = Type
type instance XXTupArg (GhcPass _) = NoExtCon
tupArgPresent :: LHsTupArg id -> Bool
tupArgPresent (L _ (Present {})) = True
tupArgPresent (L _ (Missing {})) = False
tupArgPresent (L _ (XTupArg {})) = False
instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where
ppr expr = pprExpr expr
pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc
pprLExpr (L _ e) = pprExpr e
pprExpr :: (OutputableBndrId 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 idL, OutputableBndrId idR)
=> HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprBinds b = pprDeeper (ppr b)
ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
ppr_expr :: forall p. (OutputableBndrId p)
=> HsExpr (GhcPass p) -> SDoc
ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v
ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc 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 <- ppr_infix_expr (unLoc op)
= pp_infixly pp_op
| otherwise
= pp_prefixly
where
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)
| Just pp_op <- ppr_infix_expr (unLoc op)
= pp_infixly pp_op
| otherwise
= pp_prefixly
where
pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, text "x_ )"])
pp_infixly v = (sep [pp_expr, v])
ppr_expr (SectionR _ op expr)
| Just pp_op <- ppr_infix_expr (unLoc op)
= pp_infixly pp_op
| otherwise
= pp_prefixly
where
pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
4 (pp_expr <> rparen)
pp_infixly v = sep [v, pp_expr]
ppr_expr (ExplicitTuple _ exprs boxity)
| [dL -> L _ (Present _ expr)] <- exprs
, Boxed <- boxity
= hsep [text (mkTupleStr Boxed 1), ppr expr]
| otherwise
= 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 _ expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
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 (HsRecFld _ f) = ppr f
ppr_expr (XExpr x) = ppr x
ppr_infix_expr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c))
ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f)
ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)
ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e
ppr_infix_expr _ = Nothing
ppr_apps :: (OutputableBndrId p)
=> HsExpr (GhcPass p)
-> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]
-> SDoc
ppr_apps (HsApp _ (L _ fun) arg) args
= ppr_apps fun (Left arg : args)
ppr_apps (HsAppType _ (L _ fun) arg) args
= ppr_apps fun (Right arg : args)
ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (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 p)
=> PprPrec -> LHsExpr (GhcPass p) -> SDoc
pprDebugParendExpr p expr
= getPprStyle (\sty ->
if debugStyle sty then pprParendLExpr p expr
else pprLExpr expr)
pprParendLExpr :: (OutputableBndrId p)
=> PprPrec -> LHsExpr (GhcPass p) -> SDoc
pprParendLExpr p (L _ e) = pprParendExpr p e
pprParendExpr :: (OutputableBndrId 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 _)
| isComprehensionContext sc = False
| otherwise = p > topPrec
go (ExplicitList{}) = False
go (RecordUpd{}) = False
go (ExprWithTySig{}) = p >= sigPrec
go (ArithSeq{}) = False
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 (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 noExtField 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 = NoExtField
type instance XCmdArrApp GhcRn = NoExtField
type instance XCmdArrApp GhcTc = Type
type instance XCmdArrForm (GhcPass _) = NoExtField
type instance XCmdApp (GhcPass _) = NoExtField
type instance XCmdLam (GhcPass _) = NoExtField
type instance XCmdPar (GhcPass _) = NoExtField
type instance XCmdCase (GhcPass _) = NoExtField
type instance XCmdIf (GhcPass _) = NoExtField
type instance XCmdLet (GhcPass _) = NoExtField
type instance XCmdDo GhcPs = NoExtField
type instance XCmdDo GhcRn = NoExtField
type instance XCmdDo GhcTc = Type
type instance XCmdWrap (GhcPass _) = NoExtField
type instance XXCmd (GhcPass _) = NoExtCon
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 = NoExtField
type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn
type instance XCmdTop GhcTc = CmdTopTc
type instance XXCmdTop (GhcPass _) = NoExtCon
instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where
ppr cmd = pprCmd cmd
pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc
pprLCmd (L _ c) = pprCmd c
pprCmd :: (OutputableBndrId 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 p) => LHsCmd (GhcPass p) -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)
ppr_cmd :: forall p. (OutputableBndrId 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 p) => HsCmdTop (GhcPass p) -> SDoc
pprCmdArg (HsCmdTop _ cmd)
= ppr_lcmd cmd
pprCmdArg (XCmdTop x) = ppr x
instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass 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 = NoExtField
type instance XMG GhcRn b = NoExtField
type instance XMG GhcTc b = MatchGroupTc
type instance XXMatchGroup (GhcPass _) b = NoExtCon
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 = NoExtField
type instance XXMatch (GhcPass _) b = NoExtCon
instance (OutputableBndrId pr, Outputable body)
=> Outputable (Match (GhcPass pr) 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 {}) = False
isSingletonMatchGroup :: [LMatch id body] -> Bool
isSingletonMatchGroup matches
| [L _ match] <- matches
, Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match
= True
| otherwise
= False
matchGroupArity :: MatchGroup (GhcPass id) body -> Arity
matchGroupArity (MG { mg_alts = alts })
| L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
| otherwise = panic "matchGroupArity"
matchGroupArity (XMatchGroup nec) = noExtCon nec
hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats (L _ (Match { m_pats = pats })) = pats
hsLMatchPats (L _ (XMatch nec)) = noExtCon nec
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 = NoExtField
type instance XXGRHSs (GhcPass _) b = NoExtCon
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 = NoExtField
type instance XXGRHS (GhcPass _) b = NoExtCon
pprMatches :: (OutputableBndrId 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 idR, Outputable body)
=> MatchGroup (GhcPass idR) body -> SDoc
pprFunBind matches = pprMatches matches
pprPatBind :: forall bndr p body. (OutputableBndrId bndr,
OutputableBndrId 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 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 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 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 = NoExtField
type instance XBindStmt (GhcPass _) GhcPs b = NoExtField
type instance XBindStmt (GhcPass _) GhcRn b = NoExtField
type instance XBindStmt (GhcPass _) GhcTc b = Type
type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField
type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField
type instance XApplicativeStmt (GhcPass _) GhcTc b = Type
type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField
type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField
type instance XBodyStmt (GhcPass _) GhcTc b = Type
type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExtField
type instance XParStmt (GhcPass _) GhcPs b = NoExtField
type instance XParStmt (GhcPass _) GhcRn b = NoExtField
type instance XParStmt (GhcPass _) GhcTc b = Type
type instance XTransStmt (GhcPass _) GhcPs b = NoExtField
type instance XTransStmt (GhcPass _) GhcRn b = NoExtField
type instance XTransStmt (GhcPass _) GhcTc b = Type
type instance XRecStmt (GhcPass _) GhcPs b = NoExtField
type instance XRecStmt (GhcPass _) GhcRn b = NoExtField
type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc
type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExtCon
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) = NoExtField
type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon
data ApplicativeArg idL
= ApplicativeArgOne
{ xarg_app_arg_one :: (XApplicativeArgOne idL)
, app_arg_pattern :: (LPat idL)
, arg_expr :: (LHsExpr idL)
, is_body_stmt :: Bool
, fail_operator :: (SyntaxExpr idL)
}
| ApplicativeArgMany
{ xarg_app_arg_many :: (XApplicativeArgMany idL)
, app_stmts :: [ExprLStmt idL]
, final_expr :: (HsExpr idL)
, bv_pattern :: (LPat idL)
}
| XApplicativeArg (XXApplicativeArg idL)
type instance XApplicativeArgOne (GhcPass _) = NoExtField
type instance XApplicativeArgMany (GhcPass _) = NoExtField
type instance XXApplicativeArg (GhcPass _) = NoExtCon
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 (OutputableBndrId pl, OutputableBndrId pr,
Outputable body)
=> Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where
ppr stmt = pprStmt stmt
pprStmt :: forall idL idR body . (OutputableBndrId idL,
OutputableBndrId 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 nec) = noExtCon nec
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 noExtField (noLoc return) False noSyntaxExpr)])))
pp_arg (_, XApplicativeArg x) = ppr x
pprStmt (XStmtLR x) = ppr x
pprTransformStmt :: (OutputableBndrId 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 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 idL, OutputableBndrId idR,
Outputable body)
=> [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
pprComp :: (OutputableBndrId 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 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)
| HsSplicedT
DelayedSplice
| XSplice (XXSplice id)
type instance XTypedSplice (GhcPass _) = NoExtField
type instance XUntypedSplice (GhcPass _) = NoExtField
type instance XQuasiQuote (GhcPass _) = NoExtField
type instance XSpliced (GhcPass _) = NoExtField
type instance XXSplice (GhcPass _) = NoExtCon
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 DelayedSplice =
DelayedSplice
TcLclEnv
(LHsExpr GhcRn)
TcType
(LHsExpr GhcTcId)
instance Data DelayedSplice where
gunfold _ _ _ = panic "DelayedSplice"
toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix
dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [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 OutputableBndrId p
=> Outputable (HsSplicedThing (GhcPass p)) where
ppr (HsSplicedExpr e) = ppr_expr e
ppr (HsSplicedTy t) = ppr t
ppr (HsSplicedPat p) = ppr p
instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where
ppr s = pprSplice s
pprPendingSplice :: (OutputableBndrId p)
=> SplicePointName -> LHsExpr (GhcPass p) -> SDoc
pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
pprSpliceDecl :: (OutputableBndrId 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 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 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 (HsSplicedT {}) = text "Unevaluated typed splice"
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 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 _) = NoExtField
type instance XPatBr (GhcPass _) = NoExtField
type instance XDecBrL (GhcPass _) = NoExtField
type instance XDecBrG (GhcPass _) = NoExtField
type instance XTypBr (GhcPass _) = NoExtField
type instance XVarBr (GhcPass _) = NoExtField
type instance XTExpBr (GhcPass _) = NoExtField
type instance XXBracket (GhcPass _) = NoExtCon
isTypedBracket :: HsBracket id -> Bool
isTypedBracket (TExpBr {}) = True
isTypedBracket _ = False
instance OutputableBndrId p
=> Outputable (HsBracket (GhcPass p)) where
ppr = pprHsBracket
pprHsBracket :: (OutputableBndrId 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 OutputableBndrId p
=> Outputable (ArithSeqInfo (GhcPass 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)
isComprehensionContext :: HsStmtContext id -> Bool
isComprehensionContext ListComp = True
isComprehensionContext MonadComp = True
isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c
isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c
isComprehensionContext _ = 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
isMonadCompContext :: HsStmtContext id -> Bool
isMonadCompContext MonadComp = True
isMonadCompContext _ = 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 (GhcPass p), Outputable (NameOrRdrName (GhcPass p)))
=> Outputable (HsStmtContext (GhcPass 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 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 idL,
OutputableBndrId idR,
Outputable body)
=> HsStmtContext (IdP (GhcPass idL))
-> StmtLR (GhcPass idL) (GhcPass idR) body
-> SDoc
pprStmtInCtxt ctxt (LastStmt _ e _ _)
| isComprehensionContext 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