%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
\begin{code}
module HsExpr where
#include "HsVersions.h"
import HsDecls
import HsPat
import HsLit
import HsTypes
import HsBinds
import Var
import Name
import BasicTypes
import DataCon
import SrcLoc
import Outputable
import FastString
\end{code}
%************************************************************************
%* *
\subsection{Expressions proper}
%* *
%************************************************************************
\begin{code}
type LHsExpr id = Located (HsExpr id)
type PostTcExpr = HsExpr Id
type PostTcTable = [(Name, Id)]
noPostTcExpr :: PostTcExpr
noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
noPostTcTable :: PostTcTable
noPostTcTable = []
type SyntaxExpr id = HsExpr id
noSyntaxExpr :: SyntaxExpr id
noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr"))
type SyntaxTable id = [(Name, SyntaxExpr id)]
noSyntaxTable :: SyntaxTable id
noSyntaxTable = []
data HsExpr id
= HsVar id
| HsIPVar (IPName id)
| HsOverLit (HsOverLit id)
| HsLit HsLit
| HsLam (MatchGroup id)
| HsApp (LHsExpr id) (LHsExpr id)
| OpApp (LHsExpr id)
(LHsExpr id)
Fixity
(LHsExpr id)
| NegApp (LHsExpr id)
(SyntaxExpr id)
| HsPar (LHsExpr id)
| SectionL (LHsExpr id)
(LHsExpr id)
| SectionR (LHsExpr id)
(LHsExpr id)
| ExplicitTuple
[HsTupArg id]
Boxity
| HsCase (LHsExpr id)
(MatchGroup id)
| HsIf (LHsExpr id)
(LHsExpr id)
(LHsExpr id)
| HsLet (HsLocalBinds id)
(LHsExpr id)
| HsDo (HsStmtContext Name)
[LStmt id]
(LHsExpr id)
PostTcType
| ExplicitList
PostTcType
[LHsExpr id]
| ExplicitPArr
PostTcType
[LHsExpr id]
| RecordCon (Located id)
PostTcExpr
(HsRecordBinds id)
| RecordUpd (LHsExpr id)
(HsRecordBinds id)
[DataCon]
[PostTcType]
[PostTcType]
| ExprWithTySig
(LHsExpr id)
(LHsType id)
| ExprWithTySigOut
(LHsExpr id)
(LHsType Name)
| ArithSeq
PostTcExpr
(ArithSeqInfo id)
| PArrSeq
PostTcExpr
(ArithSeqInfo id)
| HsSCC FastString
(LHsExpr id)
| HsCoreAnn FastString
(LHsExpr id)
| HsBracket (HsBracket id)
| HsBracketOut (HsBracket Name)
[PendingSplice]
| HsSpliceE (HsSplice id)
| HsQuasiQuoteE (HsQuasiQuote id)
| HsProc (LPat id)
(LHsCmdTop id)
| HsArrApp
(LHsExpr id)
(LHsExpr id)
PostTcType
HsArrAppType
Bool
| HsArrForm
(LHsExpr id)
(Maybe Fixity)
[LHsCmdTop id]
| HsTick
Int
[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)
data HsTupArg id
= Present (LHsExpr id)
| Missing PostTcType
tupArgPresent :: HsTupArg id -> Bool
tupArgPresent (Present {}) = True
tupArgPresent (Missing {}) = False
type PendingSplice = (Name, LHsExpr Id)
\end{code}
A @Dictionary@, unless of length 0 or 1, becomes a tuple. A
@ClassDictLam dictvars methods expr@ is, therefore:
\begin{verbatim}
\ x -> case x of ( dictvarsandmethodstuple ) -> expr
\end{verbatim}
\begin{code}
instance OutputableBndr id => Outputable (HsExpr id) where
ppr expr = pprExpr expr
\end{code}
\begin{code}
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 :: OutputableBndr id => HsExpr id -> SDoc
ppr_expr (HsVar v) = pprHsVar 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 [nest 2 pp_e1, pprHsInfix 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, pprHsInfix 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 [pprHsInfix v, pp_expr])
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens boxity (fcat (ppr_tup_args 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 exprType@(HsLam matches)
= pprMatches (LambdaExpr `asTypeOf` idType exprType) matches
where idType :: HsExpr id -> HsMatchContext id; idType = undefined
ppr_expr exprType@(HsCase expr matches)
= sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches <+> char '}') ]
where idType :: HsExpr id -> HsMatchContext id; idType = undefined
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 (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 body _) = pprDo do_or_list_comp stmts body
ppr_expr (ExplicitList _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (ExplicitPArr _ exprs)
= pa_brackets (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) = pa_brackets (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),
pprParendExpr expr ]
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
ppr_expr (HsType id) = ppr id
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsBracketOut e []) = ppr e
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> 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 (HsTick tickId vars exp)
= pprTicks (ppr exp) $
hcat [ptext (sLit "tick<"),
ppr tickId,
ptext (sLit ">("),
hsep (map pprHsVar vars),
ppr exp,
ptext (sLit ")")]
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, ptext (sLit "-<"), ppr_lexpr arg]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
= hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
= hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
= hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
ppr_expr (HsArrForm 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 _ (HsArrForm _ Nothing [])) _ _ _)
= ppr_lexpr cmd
pprCmdArg (HsCmdTop cmd _ _ _)
= parens (ppr_lexpr cmd)
instance OutputableBndr id => Outputable (HsCmdTop id) where
ppr = pprCmdArg
pa_brackets :: SDoc -> SDoc
pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
HsSyn records exactly where the user put parens, with HsPar.
So generally speaking we print without adding any parens.
However, some code is internally generated, and in some places
parens are absolutely required; so for these places we use
pprParendExpr (but don't print double parens of course).
For operator applications we don't add parens, because the oprerator
fixities should do the job, except in debug mode (dpprdebug) so we
can see the structure of the parse tree.
\begin{code}
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
= let
pp_as_was = pprLExpr expr
in
case unLoc expr of
ArithSeq {} -> pp_as_was
PArrSeq {} -> pp_as_was
HsLit {} -> pp_as_was
HsOverLit {} -> pp_as_was
HsVar {} -> pp_as_was
HsIPVar {} -> pp_as_was
ExplicitTuple {} -> pp_as_was
ExplicitList {} -> pp_as_was
ExplicitPArr {} -> pp_as_was
HsPar {} -> pp_as_was
HsBracket {} -> pp_as_was
HsBracketOut _ [] -> pp_as_was
HsDo sc _ _ _
| isListCompExpr sc -> pp_as_was
_ -> parens pp_as_was
isAtomicHsExpr :: HsExpr id -> Bool
isAtomicHsExpr (HsVar {}) = True
isAtomicHsExpr (HsLit {}) = True
isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr _ = False
\end{code}
%************************************************************************
%* *
\subsection{Commands (in arrow abstractions)}
%* *
%************************************************************************
We reuse HsExpr to represent these.
\begin{code}
type HsCmd id = HsExpr id
type LHsCmd id = LHsExpr id
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}
The legal constructors for commands are:
= HsArrApp ...
| HsArrForm ...
| HsApp (HsCmd id)
(HsExpr id)
| HsLam (Match id)
| OpApp (HsExpr id)
(HsCmd id)
Fixity
(HsCmd id)
| HsPar (HsCmd id)
| HsCase (HsExpr id)
[Match id]
SrcLoc
| HsIf (HsExpr id)
(HsCmd id)
(HsCmd id)
SrcLoc
| HsLet (HsLocalBinds id)
(HsCmd id)
| HsDo (HsStmtContext Name)
[Stmt id]
PostTcType
SrcLoc
Toplevel command, introducing a new arrow.
This may occur inside a proc (where the stack is empty) or as an
argument of a commandforming operator.
\begin{code}
type LHsCmdTop id = Located (HsCmdTop id)
data HsCmdTop id
= HsCmdTop (LHsCmd id)
[PostTcType]
PostTcType
(SyntaxTable id)
\end{code}
%************************************************************************
%* *
\subsection{Record binds}
%* *
%************************************************************************
\begin{code}
type HsRecordBinds id = HsRecFields id (LHsExpr id)
\end{code}
%************************************************************************
%* *
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
%* *
%************************************************************************
@Match@es are sets of pattern bindings and right hand sides for
functions, patterns or case branches. For example, if a function @g@
is defined as:
\begin{verbatim}
g (x,y) = y
g ((x:ys),y) = y+1,
\end{verbatim}
then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
It is always the case that each element of an @[Match]@ list has the
same number of @pats@s inside it. This corresponds to saying that
a function defined by pattern matching must have the same number of
patterns in each equation.
\begin{code}
data MatchGroup id
= MatchGroup
[LMatch id]
PostTcType
type LMatch id = Located (Match id)
data Match id
= Match
[LPat id]
(Maybe (LHsType id))
(GRHSs id)
isEmptyMatchGroup :: MatchGroup id -> Bool
isEmptyMatchGroup (MatchGroup ms _) = null ms
matchGroupArity :: MatchGroup id -> Arity
matchGroupArity (MatchGroup [] _)
= panic "matchGroupArity"
matchGroupArity (MatchGroup (match:matches) _)
= ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
n_pats
where
n_pats = length (hsLMatchPats match)
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats
data GRHSs id
= GRHSs {
grhssGRHSs :: [LGRHS id],
grhssLocalBinds :: (HsLocalBinds id)
}
type LGRHS id = Located (GRHS id)
data GRHS id = GRHS [LStmt id]
(LHsExpr id)
\end{code}
We know the list must have at least one @Match@ in it.
\begin{code}
pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc
pprMatches ctxt (MatchGroup matches _)
= vcat (map (pprMatch ctxt) (map unLoc matches))
pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc
pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
=> LPat bndr -> GRHSs id -> SDoc
pprPatBind pat ty@(grhss)
= sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
where idType :: GRHSs id -> HsMatchContext id; idType = undefined
pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
pprMatch ctxt (Match pats maybe_ty grhss)
= herald <+> sep [sep (map ppr other_pats),
ppr_maybe_ty,
nest 2 (pprGRHSs ctxt grhss)]
where
(herald, other_pats)
= case ctxt of
FunRhs fun is_infix
| not is_infix -> (ppr fun, pats)
| null pats3 -> (pp_infix, [])
| otherwise -> (parens pp_infix, pats3)
where
(pat1:pat2:pats3) = pats
pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2
LambdaExpr -> (char '\\', pats)
_ -> (empty, pats)
ppr_maybe_ty = case maybe_ty of
Just ty -> dcolon <+> ppr ty
Nothing -> empty
pprGRHSs :: (OutputableBndr idL, OutputableBndr idR)
=> HsMatchContext idL -> GRHSs idR -> SDoc
pprGRHSs ctxt (GRHSs grhss binds)
= vcat (map (pprGRHS ctxt . unLoc) grhss)
$$ if isEmptyLocalBinds binds then empty
else text "where" $$ nest 4 (pprBinds binds)
pprGRHS :: (OutputableBndr idL, OutputableBndr idR)
=> HsMatchContext idL -> GRHS idR -> SDoc
pprGRHS ctxt (GRHS [] expr)
= pp_rhs ctxt expr
pprGRHS ctxt (GRHS guards expr)
= sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
pp_rhs :: OutputableBndr idR => HsMatchContext idL -> LHsExpr idR -> SDoc
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
\end{code}
%************************************************************************
%* *
\subsection{Do stmts and list comprehensions}
%* *
%************************************************************************
\begin{code}
type LStmt id = Located (StmtLR id id)
type LStmtLR idL idR = Located (StmtLR idL idR)
type Stmt id = StmtLR id id
data GroupByClause id
= GroupByNothing (LHsExpr id)
| GroupBySomething (Either (LHsExpr id) (SyntaxExpr id)) (LHsExpr id)
data StmtLR idL idR
= BindStmt (LPat idL)
(LHsExpr idR)
(SyntaxExpr idR)
(SyntaxExpr idR)
| ExprStmt (LHsExpr idR)
(SyntaxExpr idR)
PostTcType
| LetStmt (HsLocalBindsLR idL idR)
| ParStmt [([LStmt idL], [idR])]
| TransformStmt ([LStmt idL], [idR]) (LHsExpr idR) (Maybe (LHsExpr idR))
| GroupStmt ([LStmt idL], [(idR, idR)]) (GroupByClause idR)
| RecStmt
{ recS_stmts :: [LStmtLR idL idR]
, recS_later_ids :: [idR]
, recS_rec_ids :: [idR]
, recS_bind_fn :: SyntaxExpr idR
, recS_ret_fn :: SyntaxExpr idR
, recS_mfix_fn :: SyntaxExpr idR
, recS_rec_rets :: [PostTcExpr]
, recS_dicts :: DictBinds idR
}
\end{code}
ExprStmts are a bit tricky, because what they mean
depends on the context. Consider the following contexts:
A do expression of type (m res_ty)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* ExprStmt E any_ty: do { ....; E; ... }
E :: m any_ty
Translation: E >> ...
A list comprehensions of type [elt_ty]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* ExprStmt E Bool: [ .. | .... E ]
[ .. | ..., E, ... ]
[ .. | .... | ..., E | ... ]
E :: Bool
Translation: if E then fail else ...
A guard list, guarding a RHS of type rhs_ty
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* ExprStmt E Bool: f x | ..., E, ... = ...rhs...
E :: Bool
Translation: if E then fail else ...
Array comprehensions are handled like list comprehensions -=chak
Note [How RecStmt works]
~~~~~~~~~~~~~~~~~~~~~~~~
Example:
HsDo [ BindStmt x ex
, RecStmt [a::forall a. a -> a, b]
[a::Int -> Int, c]
[ BindStmt b (return x)
, LetStmt a = ea
, BindStmt c ec ]
, return (a b) ]
Here, the RecStmt binds a,b,c; but
Only a,b are used in the stmts *following* the RecStmt,
This 'a' is *polymorphic'
Only a,c are used in the stmts *inside* the RecStmt
*before* their bindings
This 'a' is monomorphic
Nota Bene: the two a's have different types, even though they
have the same Name.
Note [Typing a RecStmt]
~~~~~~~~~~~~~~~~~~~~~~~
A (RecStmt stmts) types as if you had written
(v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) ->
do { stmts
; return (v1,..vn, r1, ..., rm) })
where v1..vn are the later_ids
r1..rm are the rec_ids
\begin{code}
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where
ppr stmt = pprStmt stmt
pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc
pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr]
pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds]
pprStmt (ExprStmt expr _ _) = ppr expr
pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss)
where doStmts stmts = ptext (sLit "| ") <> ppr stmts
pprStmt (TransformStmt (stmts, _) usingExpr maybeByExpr)
= (hsep [stmtsDoc, ptext (sLit "then"), ppr usingExpr, byExprDoc])
where stmtsDoc = interpp'SP stmts
byExprDoc = maybe empty (\byExpr -> hsep [ptext (sLit "by"), ppr byExpr]) maybeByExpr
pprStmt (GroupStmt (stmts, _) groupByClause) = (hsep [stmtsDoc, ptext (sLit "then group"), pprGroupByClause groupByClause])
where stmtsDoc = interpp'SP stmts
pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids, recS_later_ids = later_ids })
= ptext (sLit "rec") <+>
vcat [ braces (vcat (map ppr segment))
, ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids
, ptext (sLit "later_ids=") <> ppr later_ids])]
pprGroupByClause :: (OutputableBndr id) => GroupByClause id -> SDoc
pprGroupByClause (GroupByNothing usingExpr) = hsep [ptext (sLit "using"), ppr usingExpr]
pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext (sLit "by"), ppr byExpr, usingExprDoc]
where usingExprDoc = either (\usingExpr -> hsep [ptext (sLit "using"), ppr usingExpr]) (const empty) eitherUsingExpr
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
pprDo ListComp stmts body = pprComp brackets stmts body
pprDo PArrComp stmts body = pprComp pa_brackets stmts body
pprDo _ _ _ = panic "pprDo"
ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
ppr_do_stmts stmts body
= lbrace <+> pprDeeperList vcat ([ ppr s <> semi | s <- stmts] ++ [ppr body])
<+> rbrace
pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
= brack $
hang (ppr body <+> char '|')
4 (interpp'SP quals)
\end{code}
%************************************************************************
%* *
Template Haskell quotation brackets
%* *
%************************************************************************
\begin{code}
data HsSplice id = HsSplice
id
(LHsExpr id)
instance OutputableBndr id => Outputable (HsSplice id) where
ppr = pprSplice
pprSplice :: OutputableBndr id => HsSplice id -> SDoc
pprSplice (HsSplice n e)
= char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e
data HsBracket id = ExpBr (LHsExpr id)
| PatBr (LPat id)
| DecBr (HsGroup id)
| TypBr (LHsType id)
| VarBr id
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 (DecBr d) = thBrackets (char 'd') (ppr d)
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
pprHsBracket (VarBr n) = char '\'' <> ppr n
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
pp_body <+> ptext (sLit "|]")
\end{code}
%************************************************************************
%* *
\subsection{Enumerations and list comprehensions}
%* *
%************************************************************************
\begin{code}
data ArithSeqInfo id
= From (LHsExpr id)
| FromThen (LHsExpr id)
(LHsExpr id)
| FromTo (LHsExpr id)
(LHsExpr id)
| FromThenTo (LHsExpr id)
(LHsExpr id)
(LHsExpr id)
\end{code}
\begin{code}
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 " .. ")
\end{code}
%************************************************************************
%* *
\subsection{HsMatchCtxt}
%* *
%************************************************************************
\begin{code}
data HsMatchContext id
= FunRhs id Bool
| CaseAlt
| LambdaExpr
| ProcExpr
| PatBindRhs
| RecUpd
| StmtCtxt (HsStmtContext id)
deriving ()
data HsStmtContext id
= ListComp
| DoExpr
| GhciStmt
| MDoExpr PostTcTable
| PArrComp
| PatGuard (HsMatchContext id)
| ParStmtCtxt (HsStmtContext id)
| TransformStmtCtxt (HsStmtContext id)
\end{code}
\begin{code}
isDoExpr :: HsStmtContext id -> Bool
isDoExpr DoExpr = True
isDoExpr (MDoExpr _) = True
isDoExpr _ = False
isListCompExpr :: HsStmtContext id -> Bool
isListCompExpr ListComp = True
isListCompExpr PArrComp = True
isListCompExpr _ = False
\end{code}
\begin{code}
matchSeparator :: HsMatchContext id -> SDoc
matchSeparator (FunRhs {}) = ptext (sLit "=")
matchSeparator CaseAlt = ptext (sLit "->")
matchSeparator LambdaExpr = ptext (sLit "->")
matchSeparator ProcExpr = ptext (sLit "->")
matchSeparator PatBindRhs = ptext (sLit "=")
matchSeparator (StmtCtxt _) = ptext (sLit "<-")
matchSeparator RecUpd = panic "unused"
\end{code}
\begin{code}
pprMatchContext :: Outputable id => HsMatchContext id -> SDoc
pprMatchContext (FunRhs fun _) = ptext (sLit "the definition of")
<+> quotes (ppr fun)
pprMatchContext CaseAlt = ptext (sLit "a case alternative")
pprMatchContext RecUpd = ptext (sLit "a record-update construct")
pprMatchContext PatBindRhs = ptext (sLit "a pattern binding")
pprMatchContext LambdaExpr = ptext (sLit "a lambda abstraction")
pprMatchContext ProcExpr = ptext (sLit "an arrow abstraction")
pprMatchContext (StmtCtxt ctxt) = ptext (sLit "a pattern binding in")
$$ pprStmtContext ctxt
pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
pprStmtContext (ParStmtCtxt c)
= sep [ptext (sLit "a parallel branch of"), pprStmtContext c]
pprStmtContext (TransformStmtCtxt c)
= sep [ptext (sLit "a transformed branch of"), pprStmtContext c]
pprStmtContext (PatGuard ctxt)
= ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command")
pprStmtContext DoExpr = ptext (sLit "a 'do' expression")
pprStmtContext (MDoExpr _) = ptext (sLit "an 'mdo' expression")
pprStmtContext ListComp = ptext (sLit "a list comprehension")
pprStmtContext PArrComp = ptext (sLit "an array comprehension")
matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
matchContextErrString (FunRhs fun _) = ptext (sLit "function") <+> ppr fun
matchContextErrString CaseAlt = ptext (sLit "case")
matchContextErrString PatBindRhs = ptext (sLit "pattern binding")
matchContextErrString RecUpd = ptext (sLit "record update")
matchContextErrString LambdaExpr = ptext (sLit "lambda")
matchContextErrString ProcExpr = ptext (sLit "proc")
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command")
matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression")
matchContextErrString (StmtCtxt (MDoExpr _)) = ptext (sLit "'mdo' expression")
matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")
matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension")
\end{code}
\begin{code}
pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR)
=> HsMatchContext idL -> Match idR -> SDoc
pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon)
4 (pprMatch ctxt match)
pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR)
=> HsStmtContext idL -> StmtLR idL idR -> SDoc
pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)
4 (ppr stmt)
\end{code}