X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=44d9b436c3bd8adca739a2ea071cb68410e7dd1f;hb=5b9a21bf48e3197816981575aeb1ab72544ed2ad;hp=2be1ee611c301eeae3479a2f1793fc87dc80d9af;hpb=d38a30cb5e7a946f7a5e02fb6e601d2d37ea4374;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 2be1ee6..44d9b43 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -22,6 +22,7 @@ import HsBinds import Var import Name import BasicTypes +import DataCon import SrcLoc import Outputable import FastString @@ -158,9 +159,11 @@ data HsExpr id -- 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) @@ -228,6 +231,7 @@ data HsExpr id | HsTick Int -- module-local tick number + [id] -- variables in scope (LHsExpr id) -- sub-expression | HsBinTick @@ -274,17 +278,30 @@ instance OutputableBndr id => Outputable (HsExpr id) where \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) @@ -374,12 +391,12 @@ ppr_expr (ExplicitPArr _ exprs) = 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 -ppr_expr (RecordUpd aexp rbinds _ _) +ppr_expr (RecordUpd aexp rbinds _ _ _) = pp_rbinds (pprParendExpr aexp) rbinds ppr_expr (ExprWithTySig expr sig) @@ -399,7 +416,7 @@ ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e 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 @@ -410,8 +427,8 @@ ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps 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, @@ -466,18 +483,28 @@ pprParendExpr expr -- 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} %************************************************************************ @@ -669,11 +696,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 @@ -913,7 +938,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}