\begin{code}
module PprCore (
- pprCoreExpr, pprParendExpr, pprIdBndr,
+ pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
- pprIdRules, pprCoreRule
+ pprIdRules
) where
#include "HsVersions.h"
import CoreSyn
import CostCentre ( pprCostCentreCore )
import Var ( Var )
-import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
+import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
idInfo, idInlinePragma, idOccInfo,
-#ifdef OLD_STRICTNESS
- idDemandInfo,
-#endif
globalIdDetails, isGlobalId, isExportedId,
isSpecPragmaId, idNewDemandInfo
)
-import Var ( isTyVar )
+import Var ( TyVar, isTyVar, tyVarKind )
import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo,
specInfo, pprNewStrictness,
workerInfo, ppWorkerInfo,
- newStrictnessInfo,
+ newStrictnessInfo, cafInfo, ppCafInfo,
+ )
+
#ifdef OLD_STRICTNESS
- cprInfo, ppCprInfo,
- strictnessInfo, ppStrictnessInfo,
+import Id ( idDemandInfo )
+import IdInfo ( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo )
#endif
- )
+
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
-import PprType ( pprParendType, pprType, pprTyVarBndr )
+import Type ( pprParendType, pprType, pprParendKind )
import BasicTypes ( tupleParens )
import Util ( lengthIs )
import Outputable
+import FastString ( mkFastString )
\end{code}
%************************************************************************
pp_tup_args = sep (punctuate comma (map pprArg val_args))
in
case fun of
- Var f -> case isDataConId_maybe f 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
other -> add_par (hang (pprParendExpr fun) 2 pp_args)
}
-ppr_expr add_par (Case expr var [(con,args,rhs)])
+ppr_expr add_par (Case expr var ty [(con,args,rhs)])
= add_par $
- sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+ sep [sep [ptext SLIT("case") <+> pprParendType ty <+> pprCoreExpr expr,
hsep [ptext SLIT("of"),
- ppr_bndr var,
+ ppr_bndr var,
char '{',
ppr_case_pat con args
]],
where
ppr_bndr = pprBndr CaseBind
-ppr_expr add_par (Case expr var alts)
+ppr_expr add_par (Case expr var ty alts)
= add_par $
- sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+ sep [sep [ptext SLIT("case") <+> pprParendType ty <+> pprCoreExpr expr,
ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
char '}'
ppr_expr add_par (Note InlineMe expr)
= add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
+ppr_expr add_par (Note (CoreNote s) expr)
+ = add_par $
+ sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
+ pprParendExpr expr]
+
pprCoreAlt (con, args, rhs)
= hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
pprArg expr = pprParendExpr expr
-
-arrow = ptext SLIT("->")
\end{code}
Other printing bits-and-bobs used with the general @pprCoreBinding@
pragmas = ppIdInfo binder (idInfo binder)
-- Lambda bound type variables are preceded by "@"
-pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
+pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
-- Case bound things don't get a signature or a herald
pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
pprTypedBinder binder
| isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
| otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
- -- The space before the :: is important; it helps the lexer
- -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
- --
- -- It's important that the type is parenthesised too, at least when
- -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
- -- [Jun 2002: interfaces are now binary, so this doesn't matter]
+
+pprTyVarBndr :: TyVar -> SDoc
+pprTyVarBndr tyvar
+ = getPprStyle $ \ sty ->
+ if debugStyle sty then
+ hsep [ppr tyvar, dcolon, pprParendKind kind]
+ -- See comments with ppDcolon in PprCore.lhs
+ else
+ ppr tyvar
+ where
+ kind = tyVarKind tyvar
-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo b info
- = hsep [ ppArityInfo a,
+ = brackets $
+ vcat [ ppArityInfo a,
ppWorkerInfo (workerInfo info),
+ ppCafInfo (cafInfo info),
#ifdef OLD_STRICTNESS
ppStrictnessInfo s,
ppCprInfo m,
#endif
pprNewStrictness (newStrictnessInfo info),
- vcat (map (pprCoreRule (ppr b)) (rulesRules p))
+ if null rules then empty
+ else ptext SLIT("RULES:") <+> vcat (map (pprCoreRule (ppr b)) rules)
-- Inline pragma, occ, demand, lbvar info
-- printed out with all binders (when debug is on);
-- see PprCore.pprIdBndr
s = strictnessInfo info
m = cprInfo info
#endif
- p = specInfo info
+ rules = rulesRules (specInfo info)
\end{code}
pprIdRules rules = vcat (map pprIdRule rules)
pprIdRule :: IdCoreRule -> SDoc
-pprIdRule (id,rule) = pprCoreRule (ppr id) rule
+pprIdRule (IdCoreRule id _ rule) = pprCoreRule (ppr id) rule
pprCoreRule :: SDoc -> CoreRule -> SDoc
pprCoreRule pp_fn (BuiltinRule name _)
- = ifPprDebug (ptext SLIT("Built in rule for") <+> pp_fn <> colon
- <+> doubleQuotes (ftext name))
+ = ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ftext name)
pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
= doubleQuotes (ftext name) <+> ppr act <+>
projects / ghc-hetmet.git / blobdiff