Commit fd86aca8 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Fix whitespace in coreSyn/PprCore.lhs

parent 956911e4
......@@ -6,17 +6,10 @@
Printing of Core syntax
\begin{code}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprRules
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprRules
) where
import CoreSyn
......@@ -39,9 +32,9 @@ import Data.Maybe
\end{code}
%************************************************************************
%* *
%* *
\subsection{Public interfaces for Core printing (excluding instances)}
%* *
%* *
%************************************************************************
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
......@@ -53,7 +46,7 @@ pprCoreExpr :: OutputableBndr b => Expr b -> SDoc
pprParendExpr :: OutputableBndr b => Expr b -> SDoc
pprCoreBindings = pprTopBinds
pprCoreBinding = pprTopBind
pprCoreBinding = pprTopBind
instance OutputableBndr b => Outputable (Bind b) where
ppr bind = ppr_bind bind
......@@ -64,9 +57,9 @@ instance OutputableBndr b => Outputable (Expr b) where
%************************************************************************
%* *
%* *
\subsection{The guts}
%* *
%* *
%************************************************************************
\begin{code}
......@@ -81,23 +74,23 @@ pprTopBind (Rec [])
= ptext (sLit "Rec { }")
pprTopBind (Rec (b:bs))
= vcat [ptext (sLit "Rec {"),
ppr_binding b,
vcat [blankLine $$ ppr_binding b | b <- bs],
ptext (sLit "end Rec }"),
blankLine]
ppr_binding b,
vcat [blankLine $$ ppr_binding b | b <- bs],
ptext (sLit "end Rec }"),
blankLine]
\end{code}
\begin{code}
ppr_bind :: OutputableBndr b => Bind b -> SDoc
ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
ppr_bind (Rec binds) = vcat (map pp binds)
where
pp bind = ppr_binding bind <> semi
ppr_bind (Rec binds) = vcat (map pp binds)
where
pp bind = ppr_binding bind <> semi
ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
ppr_binding (val_bdr, expr)
= pprBndr LetBind val_bdr $$
= pprBndr LetBind val_bdr $$
hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
\end{code}
......@@ -111,79 +104,79 @@ noParens pp = pp
\begin{code}
ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
ppr_expr _ (Var name) = ppr name
ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd
ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd
ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
ppr_expr add_par (Lit lit) = pprLiteral add_par lit
ppr_expr add_par (Cast expr co)
ppr_expr add_par (Cast expr co)
= add_par $
sep [pprParendExpr expr,
ptext (sLit "`cast`") <+> pprCo co]
sep [pprParendExpr expr,
ptext (sLit "`cast`") <+> pprCo co]
where
pprCo co | opt_SuppressCoercions = ptext (sLit "...")
| otherwise = parens
$ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
ppr_expr add_par expr@(Lam _ _)
= let
(bndrs, body) = collectBinders expr
(bndrs, body) = collectBinders expr
in
add_par $
hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
2 (pprCoreExpr body)
2 (pprCoreExpr body)
ppr_expr add_par expr@(App {})
= case collectArgs expr of { (fun, args) ->
= case collectArgs expr of { (fun, args) ->
let
pp_args = sep (map pprArg args)
val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
pp_args = sep (map pprArg args)
val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
in
case fun of
Var f -> case isDataConWorkId_maybe f of
-- Notice that we print the *worker*
-- for tuples in paren'd format.
Just dc | saturated && isTupleTyCon tc
-> tupleParens (tupleTyConSort tc) pp_tup_args
where
tc = dataConTyCon dc
saturated = val_args `lengthIs` idArity f
_ -> add_par (hang (ppr f) 2 pp_args)
_ -> add_par (hang (pprParendExpr fun) 2 pp_args)
Var f -> case isDataConWorkId_maybe f of
-- Notice that we print the *worker*
-- for tuples in paren'd format.
Just dc | saturated && isTupleTyCon tc
-> tupleParens (tupleTyConSort tc) pp_tup_args
where
tc = dataConTyCon dc
saturated = val_args `lengthIs` idArity f
_ -> add_par (hang (ppr f) 2 pp_args)
_ -> add_par (hang (pprParendExpr fun) 2 pp_args)
}
ppr_expr add_par (Case expr var ty [(con,args,rhs)])
| opt_PprCaseAsLet
= add_par $
sep [sep [ ptext (sLit "let")
<+> char '{'
<+> ppr_case_pat con args
<+> ptext (sLit "~")
<+> ppr_bndr var
, ptext (sLit "<-")
<+> ppr_expr id expr
, char '}'
<+> ptext (sLit "in")
]
, pprCoreExpr rhs
]
sep [sep [ ptext (sLit "let")
<+> char '{'
<+> ppr_case_pat con args
<+> ptext (sLit "~")
<+> ppr_bndr var
, ptext (sLit "<-")
<+> ppr_expr id expr
, char '}'
<+> ptext (sLit "in")
]
, pprCoreExpr rhs
]
| otherwise
= add_par $
sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
ifPprDebug (braces (ppr ty)),
sep [ptext (sLit "of") <+> ppr_bndr var,
char '{' <+> ppr_case_pat con args <+> arrow]
],
pprCoreExpr rhs,
char '}'
ifPprDebug (braces (ppr ty)),
sep [ptext (sLit "of") <+> ppr_bndr var,
char '{' <+> ppr_case_pat con args <+> arrow]
],
pprCoreExpr rhs,
char '}'
]
where
ppr_bndr = pprBndr CaseBind
......@@ -191,15 +184,15 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)])
ppr_expr add_par (Case expr var ty alts)
= add_par $
sep [sep [ptext (sLit "case")
<+> pprCoreExpr expr
<+> ifPprDebug (braces (ppr ty)),
ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
char '}'
<+> pprCoreExpr expr
<+> ifPprDebug (braces (ppr ty)),
ptext (sLit "of") <+> ppr_bndr var <+> char '{'],
nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
char '}'
]
where
ppr_bndr = pprBndr CaseBind
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
......@@ -216,8 +209,8 @@ ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
= add_par
(hang (ptext (sLit "let {"))
2 (hsep [ppr_binding (val_bdr,rhs),
ptext (sLit "} in")])
2 (hsep [ppr_binding (val_bdr,rhs),
ptext (sLit "} in")])
$$
pprCoreExpr expr)
-}
......@@ -226,17 +219,17 @@ ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
ppr_expr add_par (Let bind expr)
= add_par $
sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")),
pprCoreExpr expr]
pprCoreExpr expr]
where
keyword = case bind of
Rec _ -> (sLit "letrec {")
NonRec _ _ -> (sLit "let {")
Rec _ -> (sLit "letrec {")
NonRec _ _ -> (sLit "let {")
ppr_expr add_par (Tick tickish expr)
= add_par (sep [ppr tickish, pprCoreExpr expr])
pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
pprCoreAlt (con, args, rhs)
pprCoreAlt (con, args, rhs)
= hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)
ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
......@@ -255,9 +248,9 @@ ppr_case_pat con args
-- | Pretty print the argument in a function application.
pprArg :: OutputableBndr a => Expr a -> SDoc
pprArg (Type ty)
| opt_SuppressTypeApplications = empty
| otherwise = ptext (sLit "@") <+> pprParendType ty
pprArg (Type ty)
| opt_SuppressTypeApplications = empty
| otherwise = ptext (sLit "@") <+> pprParendType ty
pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
pprArg expr = pprParendExpr expr
\end{code}
......@@ -274,17 +267,17 @@ instance OutputableBndr Var where
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
| isTyVar binder = pprKindedTyVarBndr binder
| otherwise = pprTypedLetBinder binder $$
ppIdInfo binder (idInfo binder)
| otherwise = pprTypedLetBinder binder $$
ppIdInfo binder (idInfo binder)
-- Lambda bound type variables are preceded by "@"
pprCoreBinder bind_site bndr
pprCoreBinder bind_site bndr
= getPprStyle $ \ sty ->
pprTypedLamBinder bind_site (debugStyle sty) bndr
pprUntypedBinder :: Var -> SDoc
pprUntypedBinder binder
| isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
| isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
| otherwise = pprIdBndr binder
pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
......@@ -294,7 +287,7 @@ pprTypedLamBinder bind_site debug_on var
| not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info
| opt_SuppressAll = pprUntypedBinder var -- Suppress the signature
| isTyVar var = parens (pprKindedTyVarBndr var)
| otherwise = parens (hang (pprIdBndr var)
| otherwise = parens (hang (pprIdBndr var)
2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
where
unf_info = unfoldingInfo (idInfo var)
......@@ -304,9 +297,9 @@ pprTypedLamBinder bind_site debug_on var
pprTypedLetBinder :: Var -> SDoc
-- Print binder with a type or kind signature (not paren'd)
pprTypedLetBinder binder
| isTyVar binder = pprKindedTyVarBndr binder
| isTyVar binder = pprKindedTyVarBndr binder
| opt_SuppressTypeSignatures = pprIdBndr binder
| otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
| otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
pprKindedTyVarBndr :: TyVar -> SDoc
-- Print a type variable binder with its kind (but not if *)
......@@ -319,7 +312,7 @@ pprIdBndr :: Id -> SDoc
pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo info
pprIdBndrInfo info
| opt_SuppressIdInfo = empty
| otherwise
= megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
......@@ -334,23 +327,23 @@ pprIdBndrInfo info
has_dmd = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
has_lbv = not (hasNoLBVarInfo lbv_info)
doc = showAttributes
[ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
, (has_occ, ptext (sLit "Occ=") <> ppr occ_info)
, (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info)
, (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
]
doc = showAttributes
[ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
, (has_occ, ptext (sLit "Occ=") <> ppr occ_info)
, (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info)
, (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
]
\end{code}
-----------------------------------------------------
-- IdDetails and IdInfo
-- IdDetails and IdInfo
-----------------------------------------------------
\begin{code}
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo id info
| opt_SuppressIdInfo = empty
| opt_SuppressIdInfo = empty
| otherwise
= showAttributes
[ (True, pp_scope <> ppr (idDetails id))
......@@ -359,13 +352,13 @@ ppIdInfo id info
, (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
, (has_unf, ptext (sLit "Unf=") <> ppr unf_info)
, (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
] -- Inline pragma, occ, demand, lbvar info
-- printed out with all binders (when debug is on);
-- see PprCore.pprIdBndr
] -- Inline pragma, occ, demand, lbvar info
-- printed out with all binders (when debug is on);
-- see PprCore.pprIdBndr
where
pp_scope | isGlobalId id = ptext (sLit "GblId")
| isExportedId id = ptext (sLit "LclIdX")
| otherwise = ptext (sLit "LclId")
| isExportedId id = ptext (sLit "LclIdX")
| otherwise = ptext (sLit "LclId")
arity = arityInfo info
has_arity = arity /= 0
......@@ -382,7 +375,7 @@ ppIdInfo id info
rules = specInfoRules (specInfo info)
showAttributes :: [(Bool,SDoc)] -> SDoc
showAttributes stuff
showAttributes stuff
| null docs = empty
| otherwise = brackets (sep (punctuate comma docs))
where
......@@ -390,21 +383,21 @@ showAttributes stuff
\end{code}
-----------------------------------------------------
-- Unfolding and UnfoldingGuidance
-- Unfolding and UnfoldingGuidance
-----------------------------------------------------
\begin{code}
instance Outputable UnfoldingGuidance where
ppr UnfNever = ptext (sLit "NEVER")
ppr (UnfWhen unsat_ok boring_ok)
= ptext (sLit "ALWAYS_IF") <>
= ptext (sLit "ALWAYS_IF") <>
parens (ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <>
ptext (sLit "boring_ok=") <> ppr boring_ok)
ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
= hsep [ ptext (sLit "IF_ARGS"),
brackets (hsep (map int cs)),
int size,
int discount ]
= hsep [ ptext (sLit "IF_ARGS"),
brackets (hsep (map int cs)),
int size,
int discount ]
instance Outputable UnfoldingSource where
ppr InlineCompulsory = ptext (sLit "Compulsory")
......@@ -413,19 +406,19 @@ instance Outputable UnfoldingSource where
ppr InlineRhs = ptext (sLit "<vanilla>")
instance Outputable Unfolding where
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
<+> ppr con <+> brackets (pprWithCommas ppr ops)
ppr (CoreUnfolding { uf_src = src
, uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
, uf_is_conlike=conlike, uf_is_work_free=wf
, uf_expandable=exp, uf_guidance=g, uf_arity=arity})
= ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
, uf_expandable=exp, uf_guidance=g, uf_arity=arity})
= ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
where
pp_info = fsep $ punctuate comma
pp_info = fsep $ punctuate comma
[ ptext (sLit "Src=") <> ppr src
, ptext (sLit "TopLvl=") <> ppr top
, ptext (sLit "TopLvl=") <> ppr top
, ptext (sLit "Arity=") <> int arity
, ptext (sLit "Value=") <> ppr hnf
, ptext (sLit "ConLike=") <> ppr conlike
......@@ -435,8 +428,8 @@ instance Outputable Unfolding where
pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
pp_rhs | isStableSource src = pp_tmpl
| otherwise = empty
-- Don't print the RHS or we get a quadratic
-- blowup in the size of the printout!
-- Don't print the RHS or we get a quadratic
-- blowup in the size of the printout!
\end{code}
-----------------------------------------------------
......@@ -458,7 +451,7 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
ru_bndrs = tpl_vars, ru_args = tpl_args,
ru_rhs = rhs })
= hang (doubleQuotes (ftext name) <+> ppr act)
4 (sep [ptext (sLit "forall") <+>
4 (sep [ptext (sLit "forall") <+>
sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment