[project @ 2004-02-12 02:04:59 by mthomas]

[ghc-hetmet.git] / ghc / compiler / coreSyn / PprCore.lhs

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 061975e..29a822a 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -9,9 +9,9 @@
 
 \begin{code}
 module PprCore (
-       pprCoreExpr, pprParendExpr, pprIdBndr,
+       pprCoreExpr, pprParendExpr,
        pprCoreBinding, pprCoreBindings, pprCoreAlt,
-       pprIdRules, pprCoreRule
+       pprIdRules
     ) where
 
 #include "HsVersions.h"
@@ -19,7 +19,7 @@ module PprCore (
 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, 
@@ -27,12 +27,12 @@ import Id           ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
                          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, 
@@ -40,10 +40,11 @@ import IdInfo               ( IdInfo, megaSeqIdInfo,
                        )
 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}
 
 %************************************************************************
@@ -138,7 +139,7 @@ ppr_expr add_par expr@(App fun arg)
        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
@@ -235,6 +236,11 @@ ppr_expr add_par (Note InlineCall expr)
 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)
 
@@ -252,8 +258,6 @@ ppr_case_pat con args
 
 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@
@@ -290,6 +294,17 @@ pprTypedBinder binder
        -- 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
 pprIdBndr id = ppr id <+> 
@@ -315,6 +330,7 @@ ppIdInfo :: Id -> IdInfo -> SDoc
 ppIdInfo b info
   = hsep [  ppArityInfo a,
            ppWorkerInfo (workerInfo info),
+           ppCafInfo (cafInfo info),
 #ifdef OLD_STRICTNESS
            ppStrictnessInfo s,
             ppCprInfo m,
@@ -344,8 +360,7 @@ pprIdRule (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 <+>