X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=9161d465dbabfa995c934ca30075940f3d28c376;hb=24ee75415832b05f53726f2bbdf52972b1cfb613;hp=a5f5f3001fc6b20df355b60a1f82182b36f67e4c;hpb=6f1d5899f59f268d5390ec12af9c9f2a529b56ef;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index a5f5f30..9161d46 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -285,8 +285,18 @@ pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc pprLExpr (L _ e) = pprExpr e pprExpr :: OutputableBndr id => HsExpr id -> SDoc -pprExpr e | isAtomicHsExpr e = ppr_expr e -- Never replace 'x' by "..." - | otherwise = pprDeeper (ppr_expr e) +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) @@ -316,8 +326,8 @@ ppr_expr (OpApp e1 op fixity e2) 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]) @@ -325,14 +335,14 @@ ppr_expr (OpApp e1 op fixity 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_ )")]) @@ -343,7 +353,7 @@ ppr_expr (SectionR op expr) 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) @@ -384,10 +394,10 @@ ppr_expr (ExplicitTuple exprs boxity) = 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) @@ -463,8 +473,23 @@ pa_brackets :: SDoc -> SDoc 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 @@ -473,17 +498,19 @@ pprParendExpr expr -- 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 @@ -572,17 +599,7 @@ data HsCmdTop id %************************************************************************ \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} @@ -684,11 +701,9 @@ pprMatch ctxt (Match pats maybe_ty grhss) 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 @@ -928,7 +943,12 @@ data HsStmtContext id 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}