X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=4995d525a49b6328a05a015a05b87b8cddc2b5de;hp=44d9b436c3bd8adca739a2ea071cb68410e7dd1f;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=8181524071b7df3d4982349a43840456ef0747b4 diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 44d9b43..4995d52 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -6,6 +6,13 @@ 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" @@ -326,8 +333,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]) @@ -335,14 +342,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_ )")]) @@ -353,7 +360,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) @@ -394,10 +401,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) @@ -473,8 +480,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 @@ -584,17 +606,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} @@ -669,8 +681,8 @@ pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc m -- 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) @@ -680,14 +692,29 @@ pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] 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 @@ -913,7 +940,7 @@ pp_dotdot = ptext SLIT(" .. ") \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 @@ -947,7 +974,7 @@ 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("->") @@ -957,7 +984,7 @@ matchSeparator RecUpd = panic "unused" \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") @@ -988,7 +1015,7 @@ pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext -} -- 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"