%
% (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
import Data.Data hiding (Fixity)
\end{code}
%************************************************************************
%* *
\subsection{Expressions proper}
%* *
%************************************************************************
\begin{code}
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 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 (Maybe (SyntaxExpr id))
(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)
deriving (Data, Typeable)
data HsTupArg id
= Present (LHsExpr id)
| Missing PostTcType
deriving (Data, Typeable)
tupArgPresent :: HsTupArg id -> Bool
tupArgPresent (Present {}) = True
tupArgPresent (Missing {}) = False
type PendingSplice = (Name, LHsExpr Id)
\end{code}
Note [Rebindable if]
~~~~~~~~~~~~~~~~~~~~
The rebindable syntax for 'if' is a bit special, because when
rebindable syntax is *off* we do not want to treat
(if c then t else e)
as if it was an application (ifThenElse c t e). Why not?
Because we allow an 'if' to return *unboxed* results, thus
if blah then 3# else 4#
whereas that would not be possible using a all to a polymorphic function
(because you can't call a polymorphic function at an unboxed type).
So we use Nothing to mean "use the old built-in typing rule".
\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
deriving (Data, Typeable)
\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 (Maybe (SyntaxExpr id))
(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)
deriving (Data, Typeable)
\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
deriving (Data, Typeable)
type LMatch id = Located (Match id)
data Match id
= Match
[LPat id]
(Maybe (LHsType id))
(GRHSs id)
deriving (Data, Typeable)
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)
} deriving (Data, Typeable)
type LGRHS id = Located (GRHS id)
data GRHS id = GRHS [LStmt id]
(LHsExpr id)
deriving (Data, Typeable)
\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 2 (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)
= 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 -> (ppr fun, pats)
| null pats2 -> (pp_infix, [])
| otherwise -> (parens pp_infix, pats2)
where
pp_infix = pprParendLPat pat1 <+> ppr 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)
=> HsMatchContext idL -> GRHSs idR -> 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)
=> 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 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)]
(Maybe (LHsExpr idR))
(Either
(LHsExpr idR)
(SyntaxExpr 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 :: TcEvBinds
}
deriving (Data, Typeable)
\end{code}
Note [GroupStmt binder map]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The [(idR,idR)] in a GroupStmt behaves as follows:
* Before renaming: []
* After renaming:
[ (x27,x27), ..., (z35,z35) ]
These are the variables
bound by the stmts to the left of the 'group'
and used either in the 'by' clause,
or in the stmts following the 'group'
Each item is a pair of identical variables.
* After typechecking:
[ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ]
Each pair has the same unique, but different *types*.
Note [ExprStmt]
~~~~~~~~~~~~~~~
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 { recS_rec_ids = [a, c]
, recS_stmts = [ BindStmt b (return (a,c))
, LetStmt a = ...b...
, BindStmt c ec ]
, recS_later_ids = [a, b]
, return (a b) ]
Here, the RecStmt binds a,b,c; but
Only a,b are used in the stmts *following* the RecStmt,
Only a,c are used in the stmts *inside* the RecStmt
*before* their bindings
Why do we need *both* rec_ids and later_ids? For monads they could be
combined into a single set of variables, but not for arrows. That
follows from the types of the respective feedback operators:
mfix :: MonadFix m => (a -> m a) -> m a
loop :: ArrowLoop a => a (b,d) (c,d) -> a b c
* For mfix, the 'a' covers the union of the later_ids and the rec_ids
* For 'loop', 'c' is the later_ids and 'd' is the rec_ids
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 _ using by)
= sep (ppr_lc_stmts stmts ++ [pprTransformStmt using by])
pprStmt (GroupStmt stmts _ by using)
= sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using])
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])]
pprTransformStmt :: OutputableBndr id => LHsExpr id -> Maybe (LHsExpr id) -> SDoc
pprTransformStmt using by = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)]
pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
-> Either (LHsExpr id) (SyntaxExpr is)
-> SDoc
pprGroupStmt by using
= sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)]
where
ppr_using (Right _) = empty
ppr_using (Left e) = ptext (sLit "using") <+> ppr e
pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc
pprBy Nothing = empty
pprBy (Just e) = ptext (sLit "by") <+> ppr e
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
pprDo GhciStmt 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 = brackets $ pprComp stmts body
pprDo PArrComp stmts body = pa_brackets $ pprComp 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
ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]
ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts]
pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
pprComp quals body
= hang (ppr body <+> char '|') 2 (interpp'SP quals)
\end{code}
%************************************************************************
%* *
Template Haskell quotation brackets
%* *
%************************************************************************
\begin{code}
data HsSplice id = HsSplice
id
(LHsExpr id)
deriving (Data, Typeable)
instance OutputableBndr id => Outputable (HsSplice id) where
ppr = pprSplice
pprSplice :: OutputableBndr id => HsSplice id -> SDoc
pprSplice (HsSplice n e)
= 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 id
deriving (Data, Typeable)
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 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)
deriving (Data, Typeable)
\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
| LambdaExpr
| CaseAlt
| ProcExpr
| PatBindRhs
| RecUpd
| StmtCtxt (HsStmtContext id)
| ThPatQuote
deriving (Data, Typeable)
data HsStmtContext id
= ListComp
| DoExpr
| GhciStmt
| MDoExpr PostTcTable
| PArrComp
| PatGuard (HsMatchContext id)
| ParStmtCtxt (HsStmtContext id)
| TransformStmtCtxt (HsStmtContext id)
deriving (Data, Typeable)
\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"
matchSeparator ThPatQuote = panic "unused"
\end{code}
\begin{code}
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 RecUpd = ptext (sLit "record-update construct")
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
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 ThPatQuote = panic "matchContextErrString"
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 stmt)
where
ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using
ppr_stmt (TransformStmt _ _ using by) = pprTransformStmt using by
ppr_stmt stmt = pprStmt stmt
\end{code}