HsExpr: Abstract Haskell syntax: expressions
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module HsExpr where
#include "HsVersions.h"
data HsExpr id
= HsVar id -- variable
| HsIPVar (IPName id) -- implicit parameter
- | HsOverLit (HsOverLit id) -- Overloaded literals
+ | HsOverLit (HsOverLit id) -- Overloaded literals
+
| HsLit HsLit -- Simple (non-overloaded) literals
| HsLam (MatchGroup id) -- Currently always a single match
| EAsPat (Located id) -- as pattern
(LHsExpr id)
+ | EViewPat (LHsExpr id) -- view pattern
+ (LHsExpr id)
+
| ELazyPat (LHsExpr id) -- ~ pattern
| HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y
isQuietHsExpr (OpApp _ _ _ _) = True
isQuietHsExpr _ = False
-pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc
+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
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
- pp_e1 = pprParendExpr e1 -- Add parens to make precedence clear
- pp_e2 = pprParendExpr e2
+ pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens
+ pp_e2 = pprDebugParendExpr e2 -- to make precedence clear
pp_prefixly
= hang (ppr op) 2 (sep [pp_e1, pp_e2])
pp_infixly v
= sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
-ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
+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 = pprParendExpr expr
+ pp_expr = pprDebugParendExpr expr
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, ptext SLIT("x_ )")])
- pp_infixly v = parens (sep [pp_expr, pprInfix v])
+ pp_infixly v = (sep [pp_expr, pprInfix v])
ppr_expr (SectionR op expr)
= case unLoc op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
- pp_expr = pprParendExpr expr
+ pp_expr = pprDebugParendExpr expr
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")])
4 ((<>) pp_expr rparen)
pp_infixly v
- = parens (sep [pprInfix v, pp_expr])
+ = (sep [pprInfix v, pp_expr])
-ppr_expr (HsLam matches)
- = pprMatches LambdaExpr matches
+ppr_expr (HsLam matches :: HsExpr id)
+ = pprMatches (LambdaExpr :: HsMatchContext id) matches
-ppr_expr (HsCase expr matches)
+ppr_expr (HsCase expr matches :: HsExpr id)
= sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
- nest 2 (pprMatches CaseAlt matches) ]
+ nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches) ]
ppr_expr (HsIf e1 e2 e3)
= sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")],
= tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (RecordCon con_id con_expr rbinds)
- = pp_rbinds (ppr con_id) rbinds
+ = hang (ppr con_id) 2 (ppr rbinds)
ppr_expr (RecordUpd aexp rbinds _ _ _)
- = pp_rbinds (pprParendExpr aexp) rbinds
+ = hang (pprParendExpr aexp) 2 (ppr rbinds)
ppr_expr (ExprWithTySig expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
\end{code}
-Parenthesize unless very simple:
+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 (-dppr-debug) 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
-- I think that is usually (always?) right
in
case unLoc expr of
- HsLit l -> pp_as_was
- HsOverLit l -> 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
- _ -> parens pp_as_was
+ HsLit l -> pp_as_was
+ HsOverLit l -> 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
+ HsDo sc _ _ _
+ | isListCompExpr sc -> pp_as_was
+ _ -> parens pp_as_was
isAtomicHsExpr :: HsExpr id -> Bool -- A single token
isAtomicHsExpr (HsVar {}) = True
%************************************************************************
\begin{code}
-data HsRecordBinds id = HsRecordBinds [(Located id, LHsExpr id)]
-
-recBindFields :: HsRecordBinds id -> [id]
-recBindFields (HsRecordBinds rbinds) = [unLoc field | (field,_) <- rbinds]
-
-pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc
-pp_rbinds thing (HsRecordBinds rbinds)
- = hang thing
- 4 (braces (pprDeeperList sep (punctuate comma (map (pp_rbind) rbinds))))
- where
- pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e]
+type HsRecordBinds id = HsRecFields id (LHsExpr id)
\end{code}
We know the list must have at least one @Match@ in it.
\begin{code}
-pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
+pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc
pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc matches))
-- Don't print the type; it's only
-- a place-holder before typechecking
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
-pprFunBind fun matches = pprMatches (FunRhs fun) matches
+pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc
+pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
=> LPat bndr -> GRHSs id -> SDoc
-pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
+pprPatBind pat (grhss :: GRHSs id) = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)]
-pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
+pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
pprMatch ctxt (Match pats maybe_ty grhss)
- = pp_name ctxt <+> sep [sep (map ppr pats),
- ppr_maybe_ty,
- nest 2 (pprGRHSs ctxt grhss)]
+ = herald <+> sep [sep (map ppr other_pats),
+ ppr_maybe_ty,
+ nest 2 (pprGRHSs ctxt grhss)]
where
- pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will
- -- have printed the signature
- pp_name LambdaExpr = char '\\'
- pp_name other = empty
+ (herald, other_pats)
+ = case ctxt of
+ FunRhs fun is_infix
+ | not is_infix -> (ppr fun, pats)
+ -- f x y z = e
+ -- Not pprBndr; the AbsBinds will
+ -- have printed the signature
+
+ | null pats3 -> (pp_infix, [])
+ -- x &&& y = e
+
+ | otherwise -> (parens pp_infix, pats3)
+ -- (x &&& y) z = e
+ where
+ (pat1:pat2:pats3) = pats
+ pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2
+
+ LambdaExpr -> (char '\\', pats)
+ other -> (empty, pats)
ppr_maybe_ty = case maybe_ty of
Just ty -> dcolon <+> ppr ty
Nothing -> empty
-pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
+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 id => HsMatchContext id -> GRHS id -> SDoc
+pprGRHS :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHS idR -> SDoc
pprGRHS ctxt (GRHS [] expr)
= pp_rhs ctxt expr
%************************************************************************
\begin{code}
-type LStmt id = Located (Stmt id)
+type LStmt id = Located (StmtLR id id)
+type LStmtLR idL idR = Located (StmtLR idL idR)
+
+type Stmt id = StmtLR id id
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax. Otherwise they are unused.
-data Stmt id
- = BindStmt (LPat id)
- (LHsExpr id)
- (SyntaxExpr id) -- The (>>=) operator
- (SyntaxExpr id) -- The fail operator
+data StmtLR idL idR
+ = BindStmt (LPat idL)
+ (LHsExpr idR)
+ (SyntaxExpr idR) -- The (>>=) operator
+ (SyntaxExpr idR) -- The fail operator
-- The fail operator is noSyntaxExpr
-- if the pattern match can't fail
- | ExprStmt (LHsExpr id)
- (SyntaxExpr id) -- The (>>) operator
+ | ExprStmt (LHsExpr idR)
+ (SyntaxExpr idR) -- The (>>) operator
PostTcType -- Element type of the RHS (used for arrows)
- | LetStmt (HsLocalBinds id)
+ | LetStmt (HsLocalBindsLR idL idR)
-- ParStmts only occur in a list comprehension
- | ParStmt [([LStmt id], [id])] -- After renaming, the ids are the binders
- -- bound by the stmts and used subsequently
+ | ParStmt [([LStmt idL], [idR])] -- After renaming, the ids are the binders
+ -- bound by the stmts and used subsequently
-- Recursive statement (see Note [RecStmt] below)
- | RecStmt [LStmt id]
+ | RecStmt [LStmtLR idL idR]
--- The next two fields are only valid after renaming
- [id] -- The ids are a subset of the variables bound by the stmts
+ [idR] -- The ids are a subset of the variables bound by the stmts
-- that are used in stmts that follow the RecStmt
- [id] -- Ditto, but these variables are the "recursive" ones, that
+ [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
-- 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 id) -- Method bindings of Ids bound by the RecStmt,
+ (DictBinds idR) -- Method bindings of Ids bound by the RecStmt,
-- and used afterwards
\end{code}
\begin{code}
-instance OutputableBndr id => Outputable (Stmt id) where
+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
ppr = pprSplice
pprSplice :: OutputableBndr id => HsSplice id -> SDoc
-pprSplice (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e
+pprSplice (HsSplice n e) = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e
data HsBracket id = ExpBr (LHsExpr id) -- [| expr |]
\begin{code}
data HsMatchContext id -- Context of a Match
- = FunRhs id -- Function binding for f
+ = 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
isDoExpr :: HsStmtContext id -> Bool
isDoExpr DoExpr = True
isDoExpr (MDoExpr _) = True
-isDoExpr other = False
+isDoExpr _ = False
+
+isListCompExpr :: HsStmtContext id -> Bool
+isListCompExpr ListComp = True
+isListCompExpr PArrComp = True
+isListCompExpr _ = False
\end{code}
\begin{code}
-matchSeparator (FunRhs _) = ptext SLIT("=")
+matchSeparator (FunRhs {}) = ptext SLIT("=")
matchSeparator CaseAlt = ptext SLIT("->")
matchSeparator LambdaExpr = ptext SLIT("->")
matchSeparator ProcExpr = ptext SLIT("->")
\end{code}
\begin{code}
-pprMatchContext (FunRhs fun) = ptext SLIT("the definition of") <+> quotes (ppr fun)
+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")
-}
-- Used to generate the string for a *runtime* error message
-matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun)
+matchContextErrString (FunRhs fun _) = "function " ++ showSDoc (ppr fun)
matchContextErrString CaseAlt = "case"
matchContextErrString PatBindRhs = "pattern binding"
matchContextErrString RecUpd = "record update"
projects / ghc-hetmet.git / blobdiff