[project @ 2001-03-19 16:20:44 by simonpj]

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

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 184d95f..85bab12 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,
-       pprCoreBinding, pprCoreBindings,
-       pprCoreRules, pprCoreRule
+       pprCoreBinding, pprCoreBindings, pprCoreAlt,
+       pprCoreRules, pprCoreRule, pprIdCoreRule
     ) where
 
 #include "HsVersions.h"
@@ -20,14 +20,17 @@ module PprCore (
 import CoreSyn
 import CostCentre      ( pprCostCentreCore )
 import Id              ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
-                         idInfo, idInlinePragma, idDemandInfo, idOccInfo
+                         idInfo, idInlinePragma, idDemandInfo, idOccInfo,
+                         globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId
                        )
 import Var             ( isTyVar )
 import IdInfo          ( IdInfo, megaSeqIdInfo, 
-                         arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
+                         arityInfo, ppArityInfo, 
                          specInfo, cprInfo, ppCprInfo, 
-                         strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
-                         workerInfo, ppWorkerInfo
+                         strictnessInfo, ppStrictnessInfo, cgInfo, pprCgInfo,
+                         cprInfo, ppCprInfo, 
+                         workerInfo, ppWorkerInfo,
+                          tyGenInfo, ppTyGenInfo
                        )
 import DataCon         ( dataConTyCon )
 import TyCon           ( tupleTyConBoxity, isTupleTyCon )
@@ -69,6 +72,7 @@ pprCoreBinding  = pprTopBind pprCoreEnv
 pprCoreExpr     = ppr_noparend_expr pprCoreEnv
 pprParendExpr   = ppr_parend_expr   pprCoreEnv
 pprArg                 = ppr_arg pprCoreEnv
+pprCoreAlt      = ppr_alt pprCoreEnv
 
 pprCoreEnv = initCoreEnv pprCoreBinder
 \end{code}
@@ -162,7 +166,7 @@ ppr_expr add_par pe expr@(Lam _ _)
     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) -> 
@@ -181,9 +185,9 @@ ppr_expr add_par pe expr@(App fun arg)
                             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)])
@@ -204,14 +208,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 '{'],
-        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
  
-    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)
@@ -228,7 +230,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])
-                          4 (ppr_noparend_expr pe rhs),
+                          2 (ppr_noparend_expr pe rhs),
        ptext SLIT("} in")])
      $$
      ppr_noparend_expr pe expr)
@@ -259,7 +261,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 $
-    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
 
@@ -269,12 +271,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 (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
@@ -300,7 +298,7 @@ and @pprCoreExpr@ functions.
 \begin{code}
 -- Used for printing dump info
 pprCoreBinder LetBind binder
-  = vcat [sig, pragmas, ppr binder]
+  = vcat [sig, pprIdDetails binder, pragmas, ppr binder]
   where
     sig     = pprTypedBinder binder
     pragmas = ppIdInfo binder (idInfo binder)
@@ -312,7 +310,7 @@ pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
 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
@@ -324,6 +322,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) -> ...
 
+-- 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`
@@ -334,14 +333,19 @@ pprIdBndr id = ppr id <+>
 
 
 \begin{code}
+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
 ppIdInfo b info
-  = hsep [
-           ppFlavourInfo (flavourInfo info),
-           ppArityInfo a,
+  = hsep [  ppArityInfo a,
+            ppTyGenInfo g,
            ppWorkerInfo (workerInfo info),
            ppStrictnessInfo s,
-           ppCafInfo c,
+--         pprCgInfo c,
             ppCprInfo m,
            pprCoreRules b p
        -- Inline pragma, occ, demand, lbvar info
@@ -350,8 +354,9 @@ ppIdInfo b info
        ]
   where
     a = arityInfo info
+    g = tyGenInfo info
     s = strictnessInfo info
-    c = cafInfo info
+    c = cgInfo info
     m = cprInfo info
     p = specInfo info
 \end{code}
@@ -361,6 +366,9 @@ ppIdInfo b info
 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"))
@@ -369,7 +377,7 @@ pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs)
   = 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}