import Var
import Name
import BasicTypes
+import DataCon
import SrcLoc
import Outputable
import FastString
-- Record update
| RecordUpd (LHsExpr id)
(HsRecordBinds id)
- PostTcType -- Type of *input* record
- PostTcType -- Type of *result* record (may differ from
- -- type of input record)
+ [DataCon] -- Filled in by the type checker to the *non-empty*
+ -- list of DataCons that have all the upd'd fields
+ [PostTcType] -- Argument types of *input* record type
+ [PostTcType] -- and *output* record type
+ -- For a type family, the arg types are of the *instance* tycon, not the family tycon
| ExprWithTySig -- e :: type
(LHsExpr id)
| HsTick
Int -- module-local tick number
+ [id] -- variables in scope
(LHsExpr id) -- sub-expression
| HsBinTick
\end{code}
\begin{code}
--- pprExpr and pprLExpr call pprDeeper;
+-----------------------
+-- pprExpr, pprLExpr, pprBinds call pprDeeper;
-- the underscore versions do not
-pprExpr :: OutputableBndr id => HsExpr id -> SDoc
-pprExpr e = pprDeeper (ppr_expr e)
-
pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
-pprLExpr e = pprDeeper (ppr_expr (unLoc e))
+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
+-- Parentheses do display something, but it gives little info and
+-- if we go deeper when we go inside them then we get ugly things
+-- like (...)
+isQuietHsExpr (HsPar _) = True
+-- applications don't display anything themselves
+isQuietHsExpr (HsApp _ _) = True
+isQuietHsExpr (OpApp _ _ _ _) = True
+isQuietHsExpr _ = False
pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc
pprBinds b = pprDeeper (ppr b)
+-----------------------
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
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_ )")])
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)
= pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (ExplicitTuple exprs boxity)
- = tupleParens boxity (pprDeeperList sep (punctuate comma (map ppr_lexpr exprs)))
+ = 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
+ppr_expr (RecordUpd aexp rbinds _ _ _)
+ = hang (pprParendExpr aexp) 2 (ppr rbinds)
ppr_expr (ExprWithTySig expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
ppr_expr (HsSCC lbl expr)
= sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ]
-ppr_expr (HsWrap co_fn e) = pprHsWrapper (ppr_expr e) co_fn
+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 (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
-ppr_expr (HsTick tickId exp)
- = hcat [ptext SLIT("tick<"), ppr tickId,ptext SLIT(">("), ppr exp,ptext SLIT(")")]
+ppr_expr (HsTick tickId vars 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<"),
ppr tickIdTrue,
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 -> ppr l
- HsOverLit l -> ppr l
-
- 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
+isAtomicHsExpr (HsLit {}) = True
+isAtomicHsExpr (HsOverLit {}) = True
+isAtomicHsExpr (HsIPVar {}) = True
+isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
+isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
+isAtomicHsExpr e = False
\end{code}
%************************************************************************
%************************************************************************
\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}
-- 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 id) => id -> Bool -> MatchGroup id -> 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)
pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> 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
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
pprGRHSs ctxt (GRHSs grhss binds)
- = pprDeeper
- (vcat (map (pprGRHS ctxt . unLoc) grhss)
- $$
- if isEmptyLocalBinds binds then empty
- else text "where" $$ nest 4 (pprBinds 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
\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