X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=11b4df320012f4ca6292d3182498dee2eed6e3ef;hb=b860c96a05d05fc6e4369030311cc361a0fc7b93;hp=bcc3f1075af26f9a84fb00c0cb69355ccdc48162;hpb=d386e0d20c6953b7cba4d53538a1782c4aa9980d;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index bcc3f10..11b4df3 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) @@ -186,6 +189,7 @@ data HsExpr id ----------------------------------------------------------- -- MetaHaskell Extensions + | HsBracket (HsBracket id) | HsBracketOut (HsBracket Name) -- Output of the type checker is the *original* @@ -202,22 +206,6 @@ data HsExpr id -- always has an empty stack --------------------------------------- - -- Hpc Support - - | HsTick - Int -- module-local tick number - (LHsExpr id) -- sub-expression - - | HsBinTick - Int -- module-local tick number for True - Int -- module-local tick number for False - (LHsExpr id) -- sub-expression - - | HsTickPragma -- A pragma introduced tick - (FastString,(Int,Int),(Int,Int)) -- external span for this tick - (LHsExpr id) - - --------------------------------------- -- The following are commands, not expressions proper | HsArrApp -- Arrow tail, or arrow application (f -< arg) @@ -236,13 +224,29 @@ data HsExpr id (Maybe Fixity) -- fixity (filled in by the renamer), for forms that -- were converted from OpApp's by the renamer [LHsCmdTop id] -- argument commands -\end{code} -These constructors only appear temporarily in the parser. -The renamer translates them into the Right Thing. + --------------------------------------- + -- Haskell program coverage (Hpc) Support + + | HsTick + Int -- module-local tick number + [id] -- variables in scope + (LHsExpr id) -- sub-expression + + | HsBinTick + Int -- module-local tick number for True + Int -- module-local tick number for False + (LHsExpr id) -- sub-expression + + | HsTickPragma -- A pragma introduced tick + (FastString,(Int,Int),(Int,Int)) -- external span for this tick + (LHsExpr id) + + --------------------------------------- + -- These constructors only appear temporarily in the parser. + -- The renamer translates them into the Right Thing. -\begin{code} | EWildPat -- wildcard | EAsPat (Located id) -- as pattern @@ -251,11 +255,10 @@ The renamer translates them into the Right Thing. | ELazyPat (LHsExpr id) -- ~ pattern | HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y -\end{code} -Everything from here on appears only in typechecker output. + --------------------------------------- + -- Finally, HsWrap appears only in typechecker output -\begin{code} | HsWrap HsWrapper -- TRANSLATION (HsExpr id) @@ -275,13 +278,30 @@ instance OutputableBndr id => Outputable (HsExpr id) where \end{code} \begin{code} -pprExpr :: OutputableBndr id => HsExpr id -> SDoc +----------------------- +-- pprExpr, pprLExpr, pprBinds call pprDeeper; +-- the underscore versions do not +pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprLExpr (L _ e) = pprExpr e -pprExpr e = pprDeeper (ppr_expr 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) @@ -365,10 +385,10 @@ ppr_expr (HsLet binds expr) ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body ppr_expr (ExplicitList _ exprs) - = brackets (fsep (punctuate comma (map ppr_lexpr exprs))) + = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) - = pa_brackets (fsep (punctuate comma (map ppr_lexpr exprs))) + = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs))) @@ -376,7 +396,7 @@ ppr_expr (ExplicitTuple exprs boxity) 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) @@ -396,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 @@ -407,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, @@ -458,14 +478,13 @@ Parenthesize unless very simple: pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc pprParendExpr expr = let - pp_as_was = ppr_lexpr expr - -- Using ppr_expr here avoids the call to 'deeper' - -- Not sure if that's always right. + pp_as_was = pprLExpr expr + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right in case unLoc expr of - HsLit l -> ppr l - HsOverLit l -> ppr l - + HsLit l -> pp_as_was + HsOverLit l -> pp_as_was HsVar _ -> pp_as_was HsIPVar _ -> pp_as_was ExplicitList _ _ -> pp_as_was @@ -474,8 +493,16 @@ pprParendExpr expr HsPar _ -> pp_as_was HsBracket _ -> pp_as_was HsBracketOut _ [] -> 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} %************************************************************************ @@ -555,15 +582,15 @@ data HsCmdTop id %************************************************************************ \begin{code} -type HsRecordBinds id = [(Located id, LHsExpr id)] +data HsRecordBinds id = HsRecordBinds [(Located id, LHsExpr id)] recBindFields :: HsRecordBinds id -> [id] -recBindFields rbinds = [unLoc field | (field,_) <- rbinds] +recBindFields (HsRecordBinds rbinds) = [unLoc field | (field,_) <- rbinds] pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc -pp_rbinds thing rbinds +pp_rbinds thing (HsRecordBinds rbinds) = hang thing - 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds)))) + 4 (braces (pprDeeperList sep (punctuate comma (map (pp_rbind) rbinds)))) where pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e] \end{code} @@ -668,9 +695,8 @@ pprMatch ctxt (Match pats maybe_ty grhss) pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) - $$ - (if isEmptyLocalBinds binds then empty - else text "where" $$ nest 4 (pprBinds binds)) + $$ if isEmptyLocalBinds binds then empty + else text "where" $$ nest 4 (pprBinds binds) pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc @@ -792,8 +818,8 @@ pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment)) pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc -pprDo DoExpr stmts body = ptext SLIT("do") <+> (vcat (map ppr stmts) $$ ppr body) -pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> (vcat (map ppr stmts) $$ ppr body) +pprDo DoExpr stmts body = ptext SLIT("do") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body]) +pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body]) pprDo ListComp stmts body = pprComp brackets stmts body pprDo PArrComp stmts body = pprComp pa_brackets stmts body pprDo other stmts body = panic "pprDo" -- PatGuard, ParStmtCxt