Show types of case result when debug is on

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

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 848ca1b..864f4bd 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -19,19 +19,19 @@ module PprCore (
 import CoreSyn
 import CostCentre      ( pprCostCentreCore )
 import Var             ( Var )
-import Id              ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
-                         idInfo, idInlinePragma, idOccInfo,
-                         globalIdDetails, isGlobalId, isExportedId, 
-                         isSpecPragmaId, idNewDemandInfo
+import Id              ( Id, idType, isDataConWorkId_maybe, idArity,
+                         idInfo, globalIdDetails, isGlobalId, isExportedId 
                        )
 import Var             ( TyVar, isTyVar, tyVarKind )
 import IdInfo          ( IdInfo, megaSeqIdInfo, 
+                         inlinePragInfo, occInfo, newDemandInfo, 
+                         lbvarInfo, hasNoLBVarInfo,
                          arityInfo, ppArityInfo, 
                          specInfo, pprNewStrictness,
                          workerInfo, ppWorkerInfo,
                          newStrictnessInfo, cafInfo, ppCafInfo, specInfoRules
                        )
-
+import NewDemand       ( isTop )
 #ifdef OLD_STRICTNESS
 import Id              ( idDemandInfo )
 import IdInfo          ( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo ) 
@@ -40,7 +40,7 @@ import IdInfo         ( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo )
 import DataCon         ( dataConTyCon )
 import TyCon           ( tupleTyConBoxity, isTupleTyCon )
 import Type            ( pprParendType, pprType, pprParendKind )
-import BasicTypes      ( tupleParens )
+import BasicTypes      ( tupleParens, isNoOcc, isAlwaysActive )
 import Util             ( lengthIs )
 import Outputable
 import FastString       ( mkFastString )
@@ -101,7 +101,7 @@ ppr_bind (Rec binds)               = vcat (map pp binds)
 ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
 ppr_binding (val_bdr, expr)
   = pprBndr LetBind val_bdr $$ 
-    (ppr val_bdr <+> equals <+> pprCoreExpr expr)
+    hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
 \end{code}
 
 \begin{code}
@@ -154,7 +154,8 @@ ppr_expr add_par expr@(App fun arg)
 
 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
   = add_par $
-    sep [sep [ptext SLIT("case") <+> pprParendType ty <+> pprCoreExpr expr,
+    sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+             ifPprDebug (braces (ppr ty)),
              hsep [ptext SLIT("of"),
                    ppr_bndr var, 
                    char '{',
@@ -168,7 +169,9 @@ 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") <+> pprParendType ty <+> pprCoreExpr expr,
+    sep [sep [ptext SLIT("case")
+               <+> pprCoreExpr expr
+               <+> ifPprDebug (braces (ppr ty)),
              ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
         nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
         char '}'
@@ -300,15 +303,28 @@ pprTyVarBndr 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 <+> 
-              (megaSeqIdInfo (idInfo id) `seq`
-                       -- Useful for poking on black holes
-               ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> 
+pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
+
+pprIdBndrInfo info 
+  = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
+  where
+    prag_info = inlinePragInfo info
+    occ_info  = occInfo info
+    dmd_info  = newDemandInfo info
+    lbv_info  = lbvarInfo info
+
+    no_info = isAlwaysActive prag_info && isNoOcc occ_info && 
+             (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
+             hasNoLBVarInfo lbv_info
+
+    doc | no_info = empty
+       | otherwise
+        = brackets $ hcat [ppr prag_info, ppr occ_info, 
+                          ppr dmd_info, ppr lbv_info
 #ifdef OLD_STRICTNESS
-                           ppr (idDemandInfo id) <+>
+                          , ppr (demandInfo id)
 #endif
-                           ppr (idNewDemandInfo id) <+>
-                           ppr (idLBVarInfo id)))
+                         ]
 \end{code}
 
 
@@ -316,7 +332,6 @@ pprIdBndr id = ppr id <+>
 pprIdDetails :: Id -> SDoc
 pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
                | isExportedId id   = ptext SLIT("[Exported]")
-               | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
                | otherwise         = empty
 
 ppIdInfo :: Id -> IdInfo -> SDoc