% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-
-HsExpr: Abstract Haskell syntax: expressions
-
\begin{code}
+
+-- | Abstract Haskell syntax for expressions.
module HsExpr where
#include "HsVersions.h"
import HsPat
import HsLit
import HsTypes
-import HsImpExp
import HsBinds
-- others:
%************************************************************************
\begin{code}
+-- * Expressions proper
+
type LHsExpr id = Located (HsExpr id)
-------------------------
--- PostTcExpr is an evidence expression attached to the
--- syntax tree by the type checker (c.f. postTcType)
--- We use a PostTcTable where there are a bunch of pieces of
--- evidence, more than is convenient to keep individually
+-- | PostTcExpr is an evidence expression attached to the syntax tree by the
+-- type checker (c.f. postTcType).
type PostTcExpr = HsExpr Id
+-- | We use a PostTcTable where there are a bunch of pieces of evidence, more
+-- than is convenient to keep individually.
type PostTcTable = [(Name, Id)]
noPostTcExpr :: PostTcExpr
-noPostTcExpr = HsLit (HsString FSLIT("noPostTcExpr"))
+noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
noPostTcTable :: PostTcTable
noPostTcTable = []
-------------------------
--- SyntaxExpr is like PostTcExpr, but it's filled in a little earlier,
+-- | SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier,
-- by the renamer. It's used for rebindable syntax.
--- E.g. (>>=) is filled in before the renamer by the appropriate Name
--- for (>>=), and then instantiated by the type checker with its
--- type args tec
+--
+-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
+-- @(>>=)@, and then instantiated by the type checker with its type args
+-- tec
type SyntaxExpr id = HsExpr id
noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after,
-- (if the syntax slot makes no sense)
-noSyntaxExpr = HsLit (HsString FSLIT("noSyntaxExpr"))
+noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr"))
type SyntaxTable id = [(Name, SyntaxExpr id)]
--- *** Currently used only for CmdTop (sigh) ***
--- * Before the renamer, this list is noSyntaxTable
+-- ^ Currently used only for 'CmdTop' (sigh)
+--
+-- * Before the renamer, this list is 'noSyntaxTable'
--
--- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
+-- * After the renamer, it takes the form @[(std_name, HsVar actual_name)]@
-- For example, for the 'return' op of a monad
--- normal case: (GHC.Base.return, HsVar GHC.Base.return)
--- with rebindable syntax: (GHC.Base.return, return_22)
--- where return_22 is whatever "return" is in scope
--
--- * After the type checker, it takes the form [(std_name, <expression>)]
--- where <expression> is the evidence for the method
+-- * normal case: @(GHC.Base.return, HsVar GHC.Base.return)@
+--
+-- * with rebindable syntax: @(GHC.Base.return, return_22)@
+-- where @return_22@ is whatever @return@ is in scope
+--
+-- * After the type checker, it takes the form @[(std_name, <expression>)]@
+-- where @<expression>@ is the evidence for the method
noSyntaxTable :: SyntaxTable id
noSyntaxTable = []
-------------------------
+-- | A Haskell expression.
data HsExpr id
- = HsVar id -- variable
- | HsIPVar (IPName id) -- implicit parameter
- | HsOverLit (HsOverLit id) -- Overloaded literals
+ = HsVar id -- ^ variable
+ | HsIPVar (IPName id) -- ^ implicit parameter
+ | HsOverLit (HsOverLit id) -- ^ Overloaded literals
- | HsLit HsLit -- Simple (non-overloaded) literals
+ | HsLit HsLit -- ^ Simple (non-overloaded) literals
| HsLam (MatchGroup id) -- Currently always a single match
| SectionR (LHsExpr id) -- operator
(LHsExpr id) -- operand
+ | ExplicitTuple -- Used for explicit tuples and sections thereof
+ [HsTupArg id]
+ Boxity
+
| HsCase (LHsExpr id)
(MatchGroup id)
PostTcType -- type of elements of the parallel array
[LHsExpr id]
- | ExplicitTuple -- tuple
- [LHsExpr id]
- -- NB: Unit is ExplicitTuple []
- -- for tuples, we can get the types
- -- direct from the components
- Boxity
-
-
-- Record construction
| RecordCon (Located id) -- The constructor. After type checking
-- it's the dataConWrapId of the constructor
-- Record update
| RecordUpd (LHsExpr id)
(HsRecordBinds id)
+-- (HsMatchGroup Id) -- Filled in by the type checker to be
+-- -- a match that does the job
[DataCon] -- Filled in by the type checker to the
- -- *non-empty* list of DataCons that have
+ -- _non-empty_ list of DataCons that have
-- all the upd'd fields
[PostTcType] -- Argument types of *input* record type
[PostTcType] -- and *output* record type
| HsBracketOut (HsBracket Name) -- Output of the type checker is
-- the *original*
[PendingSplice] -- renamed expression, plus
- -- *typechecked* splices to be
+ -- _typechecked_ splices to be
-- pasted back in by the desugarer
| HsSpliceE (HsSplice id)
+ | HsQuasiQuoteE (HsQuasiQuote id)
+ -- See Note [Quasi-quote overview] in TcSplice
+
-----------------------------------------------------------
-- Arrow notation extension
| HsWrap HsWrapper -- TRANSLATION
(HsExpr id)
+-- HsTupArg is used for tuple sections
+-- (,a,) is represented by ExplicitTuple [Mising ty1, Present a, Missing ty3]
+-- Which in turn stands for (\x:ty1 \y:ty2. (x,a,y))
+data HsTupArg id
+ = Present (LHsExpr id) -- The argument
+ | Missing PostTcType -- The argument is missing, but this is its type
+
+tupArgPresent :: HsTupArg id -> Bool
+tupArgPresent (Present {}) = True
+tupArgPresent (Missing {}) = False
+
type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
-- pasted back in by the desugarer
\end{code}
ppr_expr (HsPar e) = parens (ppr_lexpr e)
ppr_expr (HsCoreAnn s e)
- = vcat [ptext SLIT("HsCoreAnn") <+> ftext s, ppr_lexpr 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 op) 2 (sep [pp_e1, pp_e2])
pp_infixly v
- = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
+ = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2]
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
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, pprInfix v])
+ 4 (hsep [pp_expr, ptext (sLit "x_ )")])
+ pp_infixly v = (sep [pp_expr, pprHsInfix v])
ppr_expr (SectionR op expr)
= case unLoc op of
where
pp_expr = pprDebugParendExpr expr
- pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")])
+ pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
4 ((<>) pp_expr rparen)
pp_infixly v
- = (sep [pprInfix v, pp_expr])
+ = (sep [pprHsInfix v, pp_expr])
-ppr_expr (HsLam matches :: HsExpr id)
- = pprMatches (LambdaExpr :: HsMatchContext id) matches
+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
+
+--avoid using PatternSignatures for stage1 code portability
+ppr_expr exprType@(HsLam matches)
+ = pprMatches (LambdaExpr `asTypeOf` idType exprType) matches
+ where idType :: HsExpr id -> HsMatchContext id; idType = undefined
-ppr_expr (HsCase expr matches :: HsExpr id)
- = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
- nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches) ]
+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")],
+ = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
nest 4 (ppr e2),
- ptext SLIT("else"),
+ ptext (sLit "else"),
nest 4 (ppr e3)]
-- special case: let ... in let ...
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
- = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
+ = 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)]
+ = 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 (ExplicitPArr _ exprs)
= pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
-ppr_expr (ExplicitTuple exprs boxity)
- = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
-
ppr_expr (RecordCon con_id _ rbinds)
= hang (ppr con_id) 2 (ppr rbinds)
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 (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e
ppr_expr (HsSCC lbl expr)
- = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl),
+ = sep [ ptext (sLit "_scc_") <+> doubleQuotes (ftext lbl),
pprParendExpr expr ]
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
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 (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]
+ = hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
ppr_expr (HsTick tickId vars exp)
- = hcat [ptext SLIT("tick<"),
- ppr tickId,
- ptext SLIT(">("),
- hsep (map pprHsVar vars),
- ppr exp,
- ptext SLIT(")")]
+ = 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)
- = hcat [ptext SLIT("bintick<"),
+ = pprTicks (ppr exp) $
+ hcat [ptext (sLit "bintick<"),
ppr tickIdTrue,
- ptext SLIT(","),
+ ptext (sLit ","),
ppr tickIdFalse,
- ptext SLIT(">("),
- ppr exp,ptext SLIT(")")]
+ ptext (sLit ">("),
+ ppr exp,ptext (sLit ")")]
ppr_expr (HsTickPragma externalSrcLoc exp)
- = hcat [ptext SLIT("tickpragma<"),
+ = pprTicks (ppr exp) $
+ hcat [ptext (sLit "tickpragma<"),
ppr externalSrcLoc,
- ptext SLIT(">("),
+ ptext (sLit ">("),
ppr exp,
- ptext SLIT(")")]
+ ptext (sLit ")")]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
- = hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg]
+ = 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]
+ = 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]
+ = 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]
+ = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
- = sep [pprCmdArg (unLoc arg1), hsep [pprInfix v, pprCmdArg (unLoc 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("|)"))
+ = 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 [])) _ _ _)
pprCmdArg (HsCmdTop cmd _ _ _)
= parens (ppr_lexpr cmd)
--- Put a var in backquotes if it's not an operator already
-pprInfix :: Outputable name => name -> SDoc
-pprInfix v | isOperator ppr_v = ppr_v
- | otherwise = char '`' <> ppr_v <> char '`'
- where ppr_v = ppr v
+instance OutputableBndr id => Outputable (HsCmdTop id) where
+ ppr = pprCmdArg
-- add parallel array brackets around a document
--
pa_brackets :: SDoc -> SDoc
-pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
+pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
\end{code}
HsSyn records exactly where the user put parens, with HsPar.
-- I think that is usually (always?) right
in
case unLoc expr of
- HsLit _ -> pp_as_was
- HsOverLit _ -> pp_as_was
- HsVar _ -> pp_as_was
- HsIPVar _ -> pp_as_was
- ExplicitList _ _ -> pp_as_was
- ExplicitPArr _ _ -> pp_as_was
- ExplicitTuple _ _ -> pp_as_was
- HsPar _ -> pp_as_was
- HsBracket _ -> pp_as_was
- HsBracketOut _ [] -> pp_as_was
+ 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
-- Nothing after typechecking
(GRHSs id)
+isEmptyMatchGroup :: MatchGroup id -> Bool
+isEmptyMatchGroup (MatchGroup ms _) = null ms
+
matchGroupArity :: MatchGroup id -> Arity
matchGroupArity (MatchGroup [] _)
- = panic "matchGroupArity" -- MatchGroup is never empty
+ = panic "matchGroupArity" -- Precondition: MatchGroup is non-empty
matchGroupArity (MatchGroup (match:matches) _)
= ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
-- Assertion just checks that all the matches have the same number of pats
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats
--- GRHSs are used both for pattern bindings and for Matches
+-- | GRHSs are used both for pattern bindings and for Matches
data GRHSs id
- = GRHSs [LGRHS id] -- Guarded RHSs
- (HsLocalBinds id) -- The where clause
+ = GRHSs {
+ grhssGRHSs :: [LGRHS id], -- ^ Guarded RHSs
+ grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause
+ }
type LGRHS id = Located (GRHS id)
+-- | Guarded Right Hand Side.
data GRHS id = GRHS [LStmt id] -- Guards
(LHsExpr id) -- Right hand side
\end{code}
-- Exported to HsBinds, which can't see the defn of HsMatchContext
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
=> LPat bndr -> GRHSs id -> SDoc
-pprPatBind pat (grhss :: GRHSs id)
- = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)]
+pprPatBind pat ty@(grhss)
+ = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
+--avoid using PatternSignatures for stage1 code portability
+ where idType :: GRHSs id -> HsMatchContext id; idType = undefined
pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
-- the names which they group over in statements
-- Recursive statement (see Note [RecStmt] below)
- | RecStmt [LStmtLR idL idR]
- --- The next two fields are only valid after renaming
- [idR] -- The ids are a subset of the variables bound by the
- -- stmts that are used in stmts that follow the RecStmt
-
- [idR] -- Ditto, but these variables are the "recursive" ones,
- -- that are used before they are bound in the stmts of
- -- the RecStmt. From a type-checking point of view,
- -- these ones have to be monomorphic
-
- --- These fields are only valid after typechecking
- [PostTcExpr] -- These expressions correspond 1-to-1 with
- -- the "recursive" [id], and are the
- -- expressions that should be returned by
- -- the recursion.
- -- They may not quite be the Ids themselves,
- -- because the Id may be *polymorphic*, but
- -- the returned thing has to be *monomorphic*.
- (DictBinds idR) -- Method bindings of Ids bound by the
- -- RecStmt, and used afterwards
+ | RecStmt
+ { recS_stmts :: [LStmtLR idL idR]
+
+ -- The next two fields are only valid after renaming
+ , recS_later_ids :: [idR] -- The ids are a subset of the variables bound by the
+ -- stmts that are used in stmts that follow the RecStmt
+
+ , recS_rec_ids :: [idR] -- Ditto, but these variables are the "recursive" ones,
+ -- that are used before they are bound in the stmts of
+ -- the RecStmt.
+
+ -- An Id can be in both groups
+ -- Both sets of Ids are (now) treated monomorphically
+ -- The only reason they are separate is becuase the DsArrows
+ -- code uses them separately, and I don't understand it well
+ -- enough to change it
+
+ -- Rebindable syntax
+ , recS_bind_fn :: SyntaxExpr idR -- The bind function
+ , recS_ret_fn :: SyntaxExpr idR -- The return function
+ , recS_mfix_fn :: SyntaxExpr idR -- The mfix function
+
+ -- These fields are only valid after typechecking
+ , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 with
+ -- recS_rec_ids, and are the
+ -- expressions that should be returned by
+ -- the recursion.
+ -- They may not quite be the Ids themselves,
+ -- because the Id may be *polymorphic*, but
+ -- the returned thing has to be *monomorphic*,
+ -- so they may be type applications
+
+ , recS_dicts :: DictBinds idR -- Method bindings of Ids bound by the
+ -- RecStmt, and used afterwards
+ }
\end{code}
ExprStmts are a bit tricky, because what they mean
Array comprehensions are handled like list comprehensions -=chak
-Note [RecStmt]
-~~~~~~~~~~~~~~
+Note [How RecStmt works]
+~~~~~~~~~~~~~~~~~~~~~~~~
Example:
HsDo [ BindStmt x ex
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 (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
+ where doStmts stmts = ptext (sLit "| ") <> ppr stmts
pprStmt (TransformStmt (stmts, _) usingExpr maybeByExpr)
- = (hsep [stmtsDoc, ptext SLIT("then"), ppr usingExpr, byExprDoc])
+ = (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])
+ 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 segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment))
+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
+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") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
-pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
+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" -- PatGuard, ParStmtCxt
+ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
+-- Print a bunch of do stmts, with explicit braces and semicolons,
+-- so that we are not vulnerable to layout bugs
+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 $
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
- pp_body <+> ptext SLIT("|]")
+ pp_body <+> ptext (sLit "|]")
\end{code}
%************************************************************************
= hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
pp_dotdot :: SDoc
-pp_dotdot = ptext SLIT(" .. ")
+pp_dotdot = ptext (sLit " .. ")
\end{code}
\begin{code}
data HsMatchContext id -- Context of a Match
= FunRhs id Bool -- Function binding for f; True <=> written infix
- | CaseAlt -- Guard on a case alternative
- | LambdaExpr -- Pattern of a lambda
- | ProcExpr -- Pattern of a proc
- | PatBindRhs -- Pattern binding
+ | CaseAlt -- Patterns and guards on a case alternative
+ | LambdaExpr -- Patterns of a lambda
+ | ProcExpr -- Patterns of a proc
+ | PatBindRhs -- Patterns in the *guards* of a pattern binding
| RecUpd -- Record update [used only in DsExpr to
-- tell matchWrapper what sort of
-- runtime error message to generate]
\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 (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")
+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")
+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]
+ = sep [ptext (sLit "a parallel branch of"), pprStmtContext c]
pprStmtContext (TransformStmtCtxt c)
- = sep [ptext SLIT("a transformed branch of"), pprStmtContext c]
+ = sep [ptext (sLit "a transformed branch of"), pprStmtContext c]
pprStmtContext (PatGuard ctxt)
- = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
-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")
+ = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
+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")
{-
-pprMatchRhsContext (FunRhs fun) = ptext SLIT("a right-hand side of function") <+> quotes (ppr fun)
-pprMatchRhsContext CaseAlt = ptext SLIT("the body of a case alternative")
-pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern binding")
-pprMatchRhsContext LambdaExpr = ptext SLIT("the body of a lambda")
-pprMatchRhsContext ProcExpr = ptext SLIT("the body of a proc")
+pprMatchRhsContext (FunRhs fun) = ptext (sLit "a right-hand side of function") <+> quotes (ppr fun)
+pprMatchRhsContext CaseAlt = ptext (sLit "the body of a case alternative")
+pprMatchRhsContext PatBindRhs = ptext (sLit "the right-hand side of a pattern binding")
+pprMatchRhsContext LambdaExpr = ptext (sLit "the body of a lambda")
+pprMatchRhsContext ProcExpr = ptext (sLit "the body of a proc")
pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt
-- Used for the result statement of comprehension
-- e.g. the 'e' in [ e | ... ]
-- or the 'r' in f x = r
pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt
-pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext other
+pprStmtResultContext other = ptext (sLit "the result of") <+> pprStmtContext other
-}
-- Used to generate the string for a *runtime* error message
-matchContextErrString :: Outputable id => HsMatchContext id -> String
-matchContextErrString (FunRhs fun _) = "function " ++ showSDoc (ppr fun)
-matchContextErrString CaseAlt = "case"
-matchContextErrString PatBindRhs = "pattern binding"
-matchContextErrString RecUpd = "record update"
-matchContextErrString LambdaExpr = "lambda"
-matchContextErrString ProcExpr = "proc"
+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 _)) = "pattern guard"
-matchContextErrString (StmtCtxt DoExpr) = "'do' expression"
-matchContextErrString (StmtCtxt (MDoExpr _)) = "'mdo' expression"
-matchContextErrString (StmtCtxt ListComp) = "list comprehension"
-matchContextErrString (StmtCtxt PArrComp) = "array comprehension"
+matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
+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}
projects / ghc-hetmet.git / blobdiff