module HsExpr where
#include "HsVersions.h"
import HsDecls
import HsPat
import HsLit
import PlaceHolder ( PostTc,PostRn,DataId )
import HsTypes
import HsBinds
import TcEvidence
import CoreSyn
import Var
import RdrName
import Name
import BasicTypes
import DataCon
import SrcLoc
import Util
import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
import Type
import Data.Data hiding (Fixity)
type LHsExpr id = Located (HsExpr id)
type PostTcExpr = HsExpr Id
type PostTcTable = [(Name, PostTcExpr)]
noPostTcExpr :: PostTcExpr
noPostTcExpr = HsLit (HsString "" (fsLit "noPostTcExpr"))
noPostTcTable :: PostTcTable
noPostTcTable = []
type SyntaxExpr id = HsExpr id
noSyntaxExpr :: SyntaxExpr id
noSyntaxExpr = HsLit (HsString "" (fsLit "noSyntaxExpr"))
type CmdSyntaxTable id = [(Name, SyntaxExpr id)]
data HsExpr id
= HsVar id
| HsIPVar HsIPName
| HsOverLit (HsOverLit id)
| HsLit HsLit
| HsLam (MatchGroup id (LHsExpr id))
| HsLamCase (PostTc id Type) (MatchGroup id (LHsExpr id))
| HsApp (LHsExpr id) (LHsExpr id)
| OpApp (LHsExpr id)
(LHsExpr id)
(PostRn id Fixity)
(LHsExpr id)
| NegApp (LHsExpr id)
(SyntaxExpr id)
| HsPar (LHsExpr id)
| SectionL (LHsExpr id)
(LHsExpr id)
| SectionR (LHsExpr id)
(LHsExpr id)
| ExplicitTuple
[LHsTupArg id]
Boxity
| HsCase (LHsExpr id)
(MatchGroup id (LHsExpr id))
| HsIf (Maybe (SyntaxExpr id))
(LHsExpr id)
(LHsExpr id)
(LHsExpr id)
| HsMultiIf (PostTc id Type) [LGRHS id (LHsExpr id)]
| HsLet (HsLocalBinds id)
(LHsExpr id)
| HsDo (HsStmtContext Name)
[ExprLStmt id]
(PostTc id Type)
| ExplicitList
(PostTc id Type)
(Maybe (SyntaxExpr id))
[LHsExpr id]
| ExplicitPArr
(PostTc id Type)
[LHsExpr id]
| RecordCon (Located id)
PostTcExpr
(HsRecordBinds id)
| RecordUpd (LHsExpr id)
(HsRecordBinds id)
[DataCon]
[PostTc id Type]
[PostTc id Type]
| ExprWithTySig
(LHsExpr id)
(LHsType id)
(PostRn id [Name])
| ExprWithTySigOut
(LHsExpr id)
(LHsType Name)
| ArithSeq
PostTcExpr
(Maybe (SyntaxExpr id))
(ArithSeqInfo id)
| PArrSeq
PostTcExpr
(ArithSeqInfo id)
| HsSCC FastString
(LHsExpr id)
| HsCoreAnn FastString
(LHsExpr id)
| HsBracket (HsBracket id)
| HsRnBracketOut
(HsBracket Name)
[PendingRnSplice]
| HsTcBracketOut
(HsBracket Name)
[PendingTcSplice]
| HsSpliceE Bool
(HsSplice id)
| HsQuasiQuoteE (HsQuasiQuote id)
| HsProc (LPat id)
(LHsCmdTop id)
| HsStatic (LHsExpr id)
| HsArrApp
(LHsExpr id)
(LHsExpr id)
(PostTc id Type)
HsArrAppType
Bool
| HsArrForm
(LHsExpr id)
(Maybe Fixity)
[LHsCmdTop id]
| HsTick
(Tickish id)
(LHsExpr id)
| HsBinTick
Int
Int
(LHsExpr id)
| HsTickPragma
(FastString,(Int,Int),(Int,Int))
(LHsExpr id)
| EWildPat
| EAsPat (Located id)
(LHsExpr id)
| EViewPat (LHsExpr id)
(LHsExpr id)
| ELazyPat (LHsExpr id)
| HsType (LHsType id)
| HsWrap HsWrapper
(HsExpr id)
| HsUnboundVar RdrName
deriving (Typeable)
deriving instance (DataId id) => Data (HsExpr id)
type LHsTupArg id = Located (HsTupArg id)
data HsTupArg id
= Present (LHsExpr id)
| Missing (PostTc id Type)
deriving (Typeable)
deriving instance (DataId id) => Data (HsTupArg id)
tupArgPresent :: LHsTupArg id -> Bool
tupArgPresent (L _ (Present {})) = True
tupArgPresent (L _ (Missing {})) = False
instance OutputableBndr id => Outputable (HsExpr id) where
ppr expr = pprExpr expr
pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprLExpr (L _ e) = pprExpr e
pprExpr :: OutputableBndr id => HsExpr id -> 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 (OpApp _ _ _ _) = True
isQuietHsExpr _ = False
pprBinds :: (OutputableBndr idL, OutputableBndr idR)
=> HsLocalBindsLR idL idR -> SDoc
pprBinds b = pprDeeper (ppr b)
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc
ppr_expr (HsVar v) = pprPrefixOcc v
ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
ppr_expr (HsPar e) = parens (ppr_lexpr e)
ppr_expr (HsCoreAnn s e)
= vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
ppr_expr (HsApp e1 e2)
= let (fun, args) = collect_args e1 [e2] in
hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
where
collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
ppr_expr (OpApp e1 op _ e2)
= case unLoc op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
pp_e1 = pprDebugParendExpr e1
pp_e2 = pprDebugParendExpr e2
pp_prefixly
= hang (ppr op) 2 (sep [pp_e1, pp_e2])
pp_infixly v
= sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]]
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
ppr_expr (SectionL expr op)
= case unLoc op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
pp_expr = pprDebugParendExpr expr
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, ptext (sLit "x_ )")])
pp_infixly v = (sep [pp_expr, pprInfixOcc v])
ppr_expr (SectionR op expr)
= case unLoc op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
pp_expr = pprDebugParendExpr expr
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
4 (pp_expr <> rparen)
pp_infixly v = sep [pprInfixOcc v, pp_expr]
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens (boxityNormalTupleSort 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
punc (Present {} : _) = comma <> space
punc (Missing {} : _) = comma
punc [] = empty
ppr_expr (HsLam matches)
= pprMatches (LambdaExpr :: HsMatchContext id) matches
ppr_expr (HsLamCase _ matches)
= sep [ sep [ptext (sLit "\\case {")],
nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
ppr_expr (HsCase expr matches)
= sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
ppr_expr (HsIf _ e1 e2 e3)
= sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
nest 4 (ppr e2),
ptext (sLit "else"),
nest 4 (ppr e3)]
ppr_expr (HsMultiIf _ alts)
= sep $ ptext (sLit "if") : map ppr_alt alts
where ppr_alt (L _ (GRHS guards expr)) =
sep [ char '|' <+> interpp'SP guards
, ptext (sLit "->") <+> pprDeeper (ppr expr) ]
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
= sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lexpr expr]
ppr_expr (HsLet binds expr)
= sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
hang (ptext (sLit "in")) 2 (ppr expr)]
ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (ExplicitPArr _ exprs)
= paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (RecordCon con_id _ rbinds)
= hang (ppr con_id) 2 (ppr rbinds)
ppr_expr (RecordUpd aexp rbinds _ _ _)
= hang (pprParendExpr aexp) 2 (ppr rbinds)
ppr_expr (ExprWithTySig expr sig _)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ExprWithTySigOut expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
ppr_expr (PArrSeq _ info) = paBrackets (ppr info)
ppr_expr EWildPat = char '_'
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e
ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e
ppr_expr (HsSCC lbl expr)
= sep [ ptext (sLit "{-# SCC") <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"),
pprParendExpr expr ]
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
ppr_expr (HsType id) = ppr id
ppr_expr (HsSpliceE t s) = pprSplice t s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsRnBracketOut e []) = ppr e
ppr_expr (HsRnBracketOut e ps) = ppr e $$ ptext (sLit "pending(rn)") <+> ppr ps
ppr_expr (HsTcBracketOut e []) = ppr e
ppr_expr (HsTcBracketOut e ps) = ppr e $$ ptext (sLit "pending(tc)") <+> ppr ps
ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
ppr_expr (HsStatic e)
= hsep [ptext (sLit "static"), pprParendExpr e]
ppr_expr (HsTick tickish exp)
= pprTicks (ppr exp) $
ppr tickish <+> ppr exp
ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
= pprTicks (ppr exp) $
hcat [ptext (sLit "bintick<"),
ppr tickIdTrue,
ptext (sLit ","),
ppr tickIdFalse,
ptext (sLit ">("),
ppr exp,ptext (sLit ")")]
ppr_expr (HsTickPragma externalSrcLoc exp)
= pprTicks (ppr exp) $
hcat [ptext (sLit "tickpragma<"),
ppr externalSrcLoc,
ptext (sLit ">("),
ppr exp,
ptext (sLit ")")]
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 v)) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <+> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
ppr_expr (HsUnboundVar nm)
= ppr nm
pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprDebugParendExpr expr
= getPprStyle (\sty ->
if debugStyle sty then pprParendExpr expr
else pprLExpr expr)
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprParendExpr expr
| hsExprNeedsParens (unLoc expr) = parens (pprLExpr expr)
| otherwise = pprLExpr expr
hsExprNeedsParens :: HsExpr id -> Bool
hsExprNeedsParens (ArithSeq {}) = False
hsExprNeedsParens (PArrSeq {}) = False
hsExprNeedsParens (HsLit {}) = False
hsExprNeedsParens (HsOverLit {}) = False
hsExprNeedsParens (HsVar {}) = False
hsExprNeedsParens (HsUnboundVar {}) = False
hsExprNeedsParens (HsIPVar {}) = False
hsExprNeedsParens (ExplicitTuple {}) = False
hsExprNeedsParens (ExplicitList {}) = False
hsExprNeedsParens (ExplicitPArr {}) = False
hsExprNeedsParens (HsPar {}) = False
hsExprNeedsParens (HsBracket {}) = False
hsExprNeedsParens (HsRnBracketOut {}) = False
hsExprNeedsParens (HsTcBracketOut {}) = False
hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False
hsExprNeedsParens _ = True
isAtomicHsExpr :: HsExpr id -> Bool
isAtomicHsExpr (HsVar {}) = True
isAtomicHsExpr (HsLit {}) = True
isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True
isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr _ = False
type LHsCmd id = Located (HsCmd id)
data HsCmd id
= HsCmdArrApp
(LHsExpr id)
(LHsExpr id)
(PostTc id Type)
HsArrAppType
Bool
| HsCmdArrForm
(LHsExpr id)
(Maybe Fixity)
[LHsCmdTop id]
| HsCmdApp (LHsCmd id)
(LHsExpr id)
| HsCmdLam (MatchGroup id (LHsCmd id))
| HsCmdPar (LHsCmd id)
| HsCmdCase (LHsExpr id)
(MatchGroup id (LHsCmd id))
| HsCmdIf (Maybe (SyntaxExpr id))
(LHsExpr id)
(LHsCmd id)
(LHsCmd id)
| HsCmdLet (HsLocalBinds id)
(LHsCmd id)
| HsCmdDo [CmdLStmt id]
(PostTc id Type)
| HsCmdCast TcCoercion
(HsCmd id)
deriving (Typeable)
deriving instance (DataId id) => Data (HsCmd id)
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
deriving (Data, Typeable)
type LHsCmdTop id = Located (HsCmdTop id)
data HsCmdTop id
= HsCmdTop (LHsCmd id)
(PostTc id Type)
(PostTc id Type)
(CmdSyntaxTable id)
deriving (Typeable)
deriving instance (DataId id) => Data (HsCmdTop id)
instance OutputableBndr id => Outputable (HsCmd id) where
ppr cmd = pprCmd cmd
pprLCmd :: OutputableBndr id => LHsCmd id -> SDoc
pprLCmd (L _ c) = pprCmd c
pprCmd :: OutputableBndr id => HsCmd id -> 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 :: OutputableBndr id => LHsCmd id -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)
ppr_cmd :: forall id. OutputableBndr id => HsCmd id -> 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 pprParendExpr 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 (LambdaExpr :: HsMatchContext id) matches
ppr_cmd (HsCmdCase expr matches)
= sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
ppr_cmd (HsCmdIf _ e ct ce)
= sep [hsep [ptext (sLit "if"), nest 2 (ppr e), ptext (sLit "then")],
nest 4 (ppr ct),
ptext (sLit "else"),
nest 4 (ppr ce)]
ppr_cmd (HsCmdLet binds cmd@(L _ (HsCmdLet _ _)))
= sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lcmd cmd]
ppr_cmd (HsCmdLet binds cmd)
= sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
hang (ptext (sLit "in")) 2 (ppr cmd)]
ppr_cmd (HsCmdDo stmts _) = pprDo ArrowExpr stmts
ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd
, ptext (sLit "|>") <+> ppr co ]
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 v)) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
ppr_cmd (HsCmdArrForm op _ args)
= hang (ptext (sLit "(|") <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
pprCmdArg (HsCmdTop cmd@(L _ (HsCmdArrForm _ Nothing [])) _ _ _)
= ppr_lcmd cmd
pprCmdArg (HsCmdTop cmd _ _ _)
= parens (ppr_lcmd cmd)
instance OutputableBndr id => Outputable (HsCmdTop id) where
ppr = pprCmdArg
type HsRecordBinds id = HsRecFields id (LHsExpr id)
data MatchGroup id body
= MG { mg_alts :: [LMatch id body]
, mg_arg_tys :: [PostTc id Type]
, mg_res_ty :: PostTc id Type
, mg_origin :: Origin }
deriving (Typeable)
deriving instance (Data body,DataId id) => Data (MatchGroup id body)
type LMatch id body = Located (Match id body)
data Match id body
= Match
[LPat id]
(Maybe (LHsType id))
(GRHSs id body)
deriving (Typeable)
deriving instance (Data body,DataId id) => Data (Match id body)
isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
matchGroupArity :: MatchGroup id body -> Arity
matchGroupArity (MG { mg_alts = alts })
| (alt1:_) <- alts = length (hsLMatchPats alt1)
| otherwise = panic "matchGroupArity"
hsLMatchPats :: LMatch id body -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats
data GRHSs id body
= GRHSs {
grhssGRHSs :: [LGRHS id body],
grhssLocalBinds :: (HsLocalBinds id)
} deriving (Typeable)
deriving instance (Data body,DataId id) => Data (GRHSs id body)
type LGRHS id body = Located (GRHS id body)
data GRHS id body = GRHS [GuardLStmt id]
body
deriving (Typeable)
deriving instance (Data body,DataId id) => Data (GRHS id body)
pprMatches :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsMatchContext idL -> MatchGroup idR body -> SDoc
pprMatches ctxt (MG { mg_alts = matches })
= vcat (map (pprMatch ctxt) (map unLoc matches))
pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> idL -> Bool -> MatchGroup idR body -> SDoc
pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body)
=> LPat bndr -> GRHSs id body -> SDoc
pprPatBind pat (grhss)
= sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)]
pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsMatchContext idL -> Match idR body -> SDoc
pprMatch ctxt (Match pats maybe_ty grhss)
= sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
, nest 2 ppr_maybe_ty
, nest 2 (pprGRHSs ctxt grhss) ]
where
(herald, other_pats)
= case ctxt of
FunRhs fun is_infix
| not is_infix -> (pprPrefixOcc fun, pats)
| null pats2 -> (pp_infix, [])
| otherwise -> (parens pp_infix, pats2)
where
pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2
LambdaExpr -> (char '\\', pats)
_ -> ASSERT( null pats1 )
(ppr pat1, [])
(pat1:pats1) = pats
(pat2:pats2) = pats1
ppr_maybe_ty = case maybe_ty of
Just ty -> dcolon <+> ppr ty
Nothing -> empty
pprGRHSs :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsMatchContext idL -> GRHSs idR body -> SDoc
pprGRHSs ctxt (GRHSs grhss binds)
= vcat (map (pprGRHS ctxt . unLoc) grhss)
$$ ppUnless (isEmptyLocalBinds binds)
(text "where" $$ nest 4 (pprBinds binds))
pprGRHS :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsMatchContext idL -> GRHS idR body -> SDoc
pprGRHS ctxt (GRHS [] body)
= pp_rhs ctxt body
pprGRHS ctxt (GRHS guards body)
= sep [char '|' <+> interpp'SP guards, pp_rhs ctxt body]
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
body
(SyntaxExpr idR)
| BindStmt (LPat idL)
body
(SyntaxExpr idR)
(SyntaxExpr idR)
| BodyStmt body
(SyntaxExpr idR)
(SyntaxExpr idR)
(PostTc idR Type)
| LetStmt (HsLocalBindsLR idL idR)
| ParStmt [ParStmtBlock idL idR]
(SyntaxExpr idR)
(SyntaxExpr idR)
| TransStmt {
trS_form :: TransForm,
trS_stmts :: [ExprLStmt idL],
trS_bndrs :: [(idR, idR)],
trS_using :: LHsExpr idR,
trS_by :: Maybe (LHsExpr idR),
trS_ret :: SyntaxExpr idR,
trS_bind :: SyntaxExpr idR,
trS_fmap :: SyntaxExpr idR
}
| RecStmt
{ recS_stmts :: [LStmtLR idL idR body]
, recS_later_ids :: [idR]
, recS_rec_ids :: [idR]
, recS_bind_fn :: SyntaxExpr idR
, recS_ret_fn :: SyntaxExpr idR
, recS_mfix_fn :: SyntaxExpr idR
, recS_later_rets :: [PostTcExpr]
, recS_rec_rets :: [PostTcExpr]
, recS_ret_ty :: PostTc idR Type
}
deriving (Typeable)
deriving instance (Data body, DataId idL, DataId idR)
=> Data (StmtLR idL idR body)
data TransForm
= ThenForm
| GroupForm
deriving (Data, Typeable)
data ParStmtBlock idL idR
= ParStmtBlock
[ExprLStmt idL]
[idR]
(SyntaxExpr idR)
deriving( Typeable )
deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)
instance (OutputableBndr idL, OutputableBndr idR)
=> Outputable (ParStmtBlock idL idR) where
ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
instance (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> Outputable (StmtLR idL idR body) where
ppr stmt = pprStmt stmt
pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> (StmtLR idL idR body) -> SDoc
pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr
pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, larrow, ppr expr]
pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds]
pprStmt (BodyStmt expr _ _ _) = ppr expr
pprStmt (ParStmt stmtss _ _) = sep (punctuate (ptext (sLit " | ")) (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 })
= ptext (sLit "rec") <+>
vcat [ ppr_do_stmts segment
, ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids
, ptext (sLit "later_ids=") <> ppr later_ids])]
pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc
pprTransformStmt bndrs using by
= sep [ ptext (sLit "then") <+> ifPprDebug (braces (ppr bndrs))
, nest 2 (ppr using)
, nest 2 (pprBy by)]
pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc
pprTransStmt by using ThenForm
= sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)]
pprTransStmt by using GroupForm
= sep [ ptext (sLit "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) = ptext (sLit "by") <+> ppr e
pprDo :: (OutputableBndr id, Outputable body)
=> HsStmtContext any -> [LStmt id body] -> SDoc
pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo GhciStmtCtxt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
pprDo ListComp stmts = brackets $ pprComp stmts
pprDo PArrComp stmts = paBrackets $ pprComp stmts
pprDo MonadComp stmts = brackets $ pprComp stmts
pprDo _ _ = panic "pprDo"
ppr_do_stmts :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> [LStmtLR idL idR body] -> SDoc
ppr_do_stmts stmts
= lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts))
<+> rbrace
pprComp :: (OutputableBndr id, Outputable body)
=> [LStmt id body] -> SDoc
pprComp quals
| not (null quals)
, L _ (LastStmt body _) <- last quals
= hang (ppr body <+> char '|') 2 (pprQuals (dropTail 1 quals))
| otherwise
= pprPanic "pprComp" (pprQuals quals)
pprQuals :: (OutputableBndr id, Outputable body)
=> [LStmt id body] -> SDoc
pprQuals quals = interpp'SP quals
data HsSplice id
= HsSplice
id
(LHsExpr id)
deriving (Typeable )
data PendingSplice id
= PendSplice Name (LHsExpr id)
deriving( Typeable )
data PendingRnSplice
= PendingRnExpSplice (PendingSplice Name)
| PendingRnPatSplice (PendingSplice Name)
| PendingRnTypeSplice (PendingSplice Name)
| PendingRnDeclSplice (PendingSplice Name)
| PendingRnCrossStageSplice Name
deriving (Data, Typeable)
type PendingTcSplice = PendingSplice Id
deriving instance (DataId id) => Data (HsSplice id)
deriving instance (DataId id) => Data (PendingSplice id)
instance OutputableBndr id => Outputable (HsSplice id) where
ppr (HsSplice n e) = angleBrackets (ppr n <> comma <+> ppr e)
instance OutputableBndr id => Outputable (PendingSplice id) where
ppr (PendSplice n e) = angleBrackets (ppr n <> comma <+> ppr e)
pprUntypedSplice :: OutputableBndr id => HsSplice id -> SDoc
pprUntypedSplice = pprSplice False
pprTypedSplice :: OutputableBndr id => HsSplice id -> SDoc
pprTypedSplice = pprSplice True
pprSplice :: OutputableBndr id => Bool -> HsSplice id -> SDoc
pprSplice is_typed (HsSplice n e)
= (if is_typed then ptext (sLit "$$") else char '$')
<> ifPprDebug (brackets (ppr n)) <> eDoc
where
pp_as_was = pprLExpr e
eDoc = case unLoc e of
HsPar _ -> pp_as_was
HsVar _ -> pp_as_was
_ -> parens pp_as_was
data HsBracket id = ExpBr (LHsExpr id)
| PatBr (LPat id)
| DecBrL [LHsDecl id]
| DecBrG (HsGroup id)
| TypBr (LHsType id)
| VarBr Bool id
| TExpBr (LHsExpr id)
deriving (Typeable)
deriving instance (DataId id) => Data (HsBracket id)
isTypedBracket :: HsBracket id -> Bool
isTypedBracket (TExpBr {}) = True
isTypedBracket _ = False
instance OutputableBndr id => Outputable (HsBracket id) where
ppr = pprHsBracket
pprHsBracket :: OutputableBndr id => HsBracket id -> 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 '\'' <> ppr n
pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n
pprHsBracket (TExpBr e) = thTyBrackets (ppr e)
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
pp_body <+> ptext (sLit "|]")
thTyBrackets :: SDoc -> SDoc
thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]")
instance Outputable PendingRnSplice where
ppr (PendingRnExpSplice s) = ppr s
ppr (PendingRnPatSplice s) = ppr s
ppr (PendingRnTypeSplice s) = ppr s
ppr (PendingRnDeclSplice s) = ppr s
ppr (PendingRnCrossStageSplice name) = ppr name
data ArithSeqInfo id
= From (LHsExpr id)
| FromThen (LHsExpr id)
(LHsExpr id)
| FromTo (LHsExpr id)
(LHsExpr id)
| FromThenTo (LHsExpr id)
(LHsExpr id)
(LHsExpr id)
deriving (Typeable)
deriving instance (DataId id) => Data (ArithSeqInfo id)
instance OutputableBndr id => Outputable (ArithSeqInfo id) 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 = ptext (sLit " .. ")
data HsMatchContext id
= FunRhs id Bool
| LambdaExpr
| CaseAlt
| IfAlt
| ProcExpr
| PatBindRhs
| RecUpd
| StmtCtxt (HsStmtContext id)
| ThPatSplice
| ThPatQuote
| PatSyn
deriving (Data, Typeable)
data HsStmtContext id
= ListComp
| MonadComp
| PArrComp
| DoExpr
| MDoExpr
| ArrowExpr
| GhciStmtCtxt
| PatGuard (HsMatchContext id)
| ParStmtCtxt (HsStmtContext id)
| TransStmtCtxt (HsStmtContext id)
deriving (Data, Typeable)
isListCompExpr :: HsStmtContext id -> Bool
isListCompExpr ListComp = True
isListCompExpr PArrComp = True
isListCompExpr MonadComp = True
isListCompExpr (ParStmtCtxt c) = isListCompExpr c
isListCompExpr (TransStmtCtxt c) = isListCompExpr c
isListCompExpr _ = False
isMonadCompExpr :: HsStmtContext id -> Bool
isMonadCompExpr MonadComp = True
isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt
isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
isMonadCompExpr _ = False
matchSeparator :: HsMatchContext id -> SDoc
matchSeparator (FunRhs {}) = ptext (sLit "=")
matchSeparator CaseAlt = ptext (sLit "->")
matchSeparator IfAlt = ptext (sLit "->")
matchSeparator LambdaExpr = ptext (sLit "->")
matchSeparator ProcExpr = ptext (sLit "->")
matchSeparator PatBindRhs = ptext (sLit "=")
matchSeparator (StmtCtxt _) = ptext (sLit "<-")
matchSeparator RecUpd = panic "unused"
matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
matchSeparator PatSyn = panic "unused"
pprMatchContext :: Outputable id => HsMatchContext id -> SDoc
pprMatchContext ctxt
| want_an ctxt = ptext (sLit "an") <+> pprMatchContextNoun ctxt
| otherwise = ptext (sLit "a") <+> pprMatchContextNoun ctxt
where
want_an (FunRhs {}) = True
want_an ProcExpr = True
want_an _ = False
pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for")
<+> quotes (ppr fun)
pprMatchContextNoun CaseAlt = ptext (sLit "case alternative")
pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative")
pprMatchContextNoun RecUpd = ptext (sLit "record-update construct")
pprMatchContextNoun ThPatSplice = ptext (sLit "Template Haskell pattern splice")
pprMatchContextNoun ThPatQuote = ptext (sLit "Template Haskell pattern quotation")
pprMatchContextNoun PatBindRhs = ptext (sLit "pattern binding")
pprMatchContextNoun LambdaExpr = ptext (sLit "lambda abstraction")
pprMatchContextNoun ProcExpr = ptext (sLit "arrow abstraction")
pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in")
$$ pprStmtContext ctxt
pprMatchContextNoun PatSyn = ptext (sLit "pattern synonym declaration")
pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
pprAStmtContext ctxt = article <+> pprStmtContext ctxt
where
pp_an = ptext (sLit "an")
pp_a = ptext (sLit "a")
article = case ctxt of
MDoExpr -> pp_an
PArrComp -> pp_an
GhciStmtCtxt -> pp_an
_ -> pp_a
pprStmtContext GhciStmtCtxt = ptext (sLit "interactive GHCi command")
pprStmtContext DoExpr = ptext (sLit "'do' block")
pprStmtContext MDoExpr = ptext (sLit "'mdo' block")
pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command")
pprStmtContext ListComp = ptext (sLit "list comprehension")
pprStmtContext MonadComp = ptext (sLit "monad comprehension")
pprStmtContext PArrComp = ptext (sLit "array comprehension")
pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt
pprStmtContext (ParStmtCtxt c)
| opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c]
| otherwise = pprStmtContext c
pprStmtContext (TransStmtCtxt c)
| opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c]
| otherwise = pprStmtContext c
matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
matchContextErrString (FunRhs fun _) = ptext (sLit "function") <+> ppr fun
matchContextErrString CaseAlt = ptext (sLit "case")
matchContextErrString IfAlt = ptext (sLit "multi-way if")
matchContextErrString PatBindRhs = ptext (sLit "pattern binding")
matchContextErrString RecUpd = ptext (sLit "record update")
matchContextErrString LambdaExpr = ptext (sLit "lambda")
matchContextErrString ProcExpr = ptext (sLit "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 _)) = ptext (sLit "pattern guard")
matchContextErrString (StmtCtxt GhciStmtCtxt) = ptext (sLit "interactive GHCi command")
matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block")
matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block")
matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block")
matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")
matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension")
matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension")
pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsMatchContext idL -> Match idR body -> SDoc
pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon)
4 (pprMatch ctxt match)
pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsStmtContext idL -> StmtLR idL idR body -> SDoc
pprStmtInCtxt ctxt (LastStmt e _)
| isListCompExpr ctxt
= hang (ptext (sLit "In the expression:")) 2 (ppr e)
pprStmtInCtxt ctxt stmt
= hang (ptext (sLit "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