projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2001-03-03 02:50:04 by chak]
[ghc-hetmet.git]
/
ghc
/
compiler
/
coreSyn
/
PprCore.lhs
diff --git
a/ghc/compiler/coreSyn/PprCore.lhs
b/ghc/compiler/coreSyn/PprCore.lhs
index
0c9ad37
..
4f9a5e1
100644
(file)
--- a/
ghc/compiler/coreSyn/PprCore.lhs
+++ b/
ghc/compiler/coreSyn/PprCore.lhs
@@
-11,8
+11,8
@@
module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprIdBndr,
module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprIdBndr,
- pprCoreBinding, pprCoreBindings,
- pprCoreRules, pprCoreRule
+ pprCoreBinding, pprCoreBindings, pprCoreAlt,
+ pprCoreRules, pprCoreRule, pprIdCoreRule
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
@@
-23,12
+23,13
@@
import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
idInfo, idInlinePragma, idDemandInfo, idOccInfo
)
import Var ( isTyVar )
idInfo, idInlinePragma, idDemandInfo, idOccInfo
)
import Var ( isTyVar )
-import IdInfo ( IdInfo, megaSeqIdInfo, occInfo,
+import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
- demandInfo, specInfo,
+ specInfo, cprInfo, ppCprInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
- cprInfo, ppCprInfo, lbvarInfo,
- workerInfo, ppWorkerInfo
+ cprInfo, ppCprInfo,
+ workerInfo, ppWorkerInfo,
+ tyGenInfo, ppTyGenInfo
)
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
)
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
@@
-70,6
+71,7
@@
pprCoreBinding = pprTopBind pprCoreEnv
pprCoreExpr = ppr_noparend_expr pprCoreEnv
pprParendExpr = ppr_parend_expr pprCoreEnv
pprArg = ppr_arg pprCoreEnv
pprCoreExpr = ppr_noparend_expr pprCoreEnv
pprParendExpr = ppr_parend_expr pprCoreEnv
pprArg = ppr_arg pprCoreEnv
+pprCoreAlt = ppr_alt pprCoreEnv
pprCoreEnv = initCoreEnv pprCoreBinder
\end{code}
pprCoreEnv = initCoreEnv pprCoreBinder
\end{code}
@@
-163,7
+165,7
@@
ppr_expr add_par pe expr@(Lam _ _)
in
add_par $
hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
in
add_par $
hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
- 4 (ppr_noparend_expr pe body)
+ 2 (ppr_noparend_expr pe body)
ppr_expr add_par pe expr@(App fun arg)
= case collectArgs expr of { (fun, args) ->
ppr_expr add_par pe expr@(App fun arg)
= case collectArgs expr of { (fun, args) ->
@@
-182,9
+184,9
@@
ppr_expr add_par pe expr@(App fun arg)
tc = dataConTyCon dc
saturated = length val_args == idArity f
tc = dataConTyCon dc
saturated = length val_args == idArity f
- other -> add_par (hang (pOcc pe f) 4 pp_args)
+ other -> add_par (hang (pOcc pe f) 2 pp_args)
- other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args)
+ other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args)
}
ppr_expr add_par pe (Case expr var [(con,args,rhs)])
}
ppr_expr add_par pe (Case expr var [(con,args,rhs)])
@@
-205,14
+207,12
@@
ppr_expr add_par pe (Case expr var alts)
= add_par $
sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
= add_par $
sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
- nest 4 (sep (punctuate semi (map ppr_alt alts))),
+ nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))),
char '}'
]
where
ppr_bndr = pBndr pe CaseBind
char '}'
]
where
ppr_bndr = pBndr pe CaseBind
- ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
- 4 (ppr_noparend_expr pe rhs)
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
@@
-229,7
+229,7
@@
ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
= add_par
(hang (ptext SLIT("let {"))
2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
= add_par
(hang (ptext SLIT("let {"))
2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
- 4 (ppr_noparend_expr pe rhs),
+ 2 (ppr_noparend_expr pe rhs),
ptext SLIT("} in")])
$$
ppr_noparend_expr pe expr)
ptext SLIT("} in")])
$$
ppr_noparend_expr pe expr)
@@
-260,7
+260,7
@@
ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
#else
ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
= add_par $
#else
ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
= add_par $
- sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
+ sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)],
ppr_parend_expr pe expr]
#endif
ppr_parend_expr pe expr]
#endif
@@
-270,12
+270,8
@@
ppr_expr add_par pe (Note InlineCall expr)
ppr_expr add_par pe (Note InlineMe expr)
= add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
ppr_expr add_par pe (Note InlineMe expr)
= add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
-ppr_expr add_par pe (Note (TermUsg u) expr)
- = getPprStyle $ \ sty ->
- if ifaceStyle sty then
- ppr_expr add_par pe expr
- else
- add_par (ppr u <+> ppr_noparend_expr pe expr)
+ppr_alt pe (con, args, rhs)
+ = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs)
ppr_case_pat pe con@(DataAlt dc) args
| isTupleTyCon tc
ppr_case_pat pe con@(DataAlt dc) args
| isTupleTyCon tc
@@
-313,7
+309,7
@@
pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
pprUntypedBinder binder
pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
pprUntypedBinder binder
- | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
+ | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
| otherwise = pprIdBndr binder
pprTypedBinder binder
| otherwise = pprIdBndr binder
pprTypedBinder binder
@@
-325,6
+321,7
@@
pprTypedBinder binder
-- It's important that the type is parenthesised too, at least when
-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
-- It's important that the type is parenthesised too, at least when
-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
+-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
pprIdBndr id = ppr id <+>
(megaSeqIdInfo (idInfo id) `seq`
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
pprIdBndr id = ppr id <+>
(megaSeqIdInfo (idInfo id) `seq`
@@
-340,6
+337,7
@@
ppIdInfo b info
= hsep [
ppFlavourInfo (flavourInfo info),
ppArityInfo a,
= hsep [
ppFlavourInfo (flavourInfo info),
ppArityInfo a,
+ ppTyGenInfo g,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
ppCafInfo c,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
ppCafInfo c,
@@
-351,6
+349,7
@@
ppIdInfo b info
]
where
a = arityInfo info
]
where
a = arityInfo info
+ g = tyGenInfo info
s = strictnessInfo info
c = cafInfo info
m = cprInfo info
s = strictnessInfo info
c = cafInfo info
m = cprInfo info
@@
-362,6
+361,9
@@
ppIdInfo b info
pprCoreRules :: Id -> CoreRules -> SDoc
pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
pprCoreRules :: Id -> CoreRules -> SDoc
pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
+pprIdCoreRule :: IdCoreRule -> SDoc
+pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
+
pprCoreRule :: SDoc -> CoreRule -> SDoc
pprCoreRule pp_fn (BuiltinRule _)
= ifPprDebug (ptext SLIT("A built in rule"))
pprCoreRule :: SDoc -> CoreRule -> SDoc
pprCoreRule pp_fn (BuiltinRule _)
= ifPprDebug (ptext SLIT("A built in rule"))
@@
-370,7
+372,7
@@
pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs)
= doubleQuotes (ptext name) <+>
sep [
ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
= doubleQuotes (ptext name) <+>
sep [
ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
- nest 4 (pp_fn <+> sep (map pprArg tpl_args)),
- nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs)
+ nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
+ nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
] <+> semi
\end{code}
] <+> semi
\end{code}