add double colon and double arrow symbols (-fglasgow-exts)

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

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 10ad00c..0a40ab4 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -11,7 +11,7 @@
 module PprCore (
        pprCoreExpr, pprParendExpr,
        pprCoreBinding, pprCoreBindings, pprCoreAlt,
-       pprIdRules
+       pprRules
     ) where
 
 #include "HsVersions.h"
@@ -21,23 +21,22 @@ import CostCentre   ( pprCostCentreCore )
 import Var             ( Var )
 import Id              ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
                          idInfo, idInlinePragma, idOccInfo,
-#ifdef OLD_STRICTNESS
-                         idDemandInfo, 
-#endif
                          globalIdDetails, isGlobalId, isExportedId, 
-                         isSpecPragmaId, idNewDemandInfo
+                         idNewDemandInfo
                        )
 import Var             ( TyVar, isTyVar, tyVarKind )
 import IdInfo          ( IdInfo, megaSeqIdInfo, 
                          arityInfo, ppArityInfo, 
                          specInfo, pprNewStrictness,
                          workerInfo, ppWorkerInfo,
-                         newStrictnessInfo, cafInfo, ppCafInfo,
+                         newStrictnessInfo, cafInfo, ppCafInfo, specInfoRules
+                       )
+
 #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 Type            ( pprParendType, pprType, pprParendKind )
@@ -102,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}
@@ -153,10 +152,10 @@ ppr_expr add_par expr@(App fun arg)
        other -> add_par (hang (pprParendExpr fun) 2 pp_args)
     }
 
--- gaw 2004
 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
   = add_par $
-    sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr,
+    sep [sep [ptext SLIT("case") {- <+> pprParendType ty -} <+> pprCoreExpr expr,
+       -- Printing the result type is excessive!
              hsep [ptext SLIT("of"),
                    ppr_bndr var, 
                    char '{',
@@ -168,10 +167,9 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)])
   where
     ppr_bndr = pprBndr CaseBind
 
--- gaw 2004
 ppr_expr add_par (Case expr var ty alts)
   = add_par $
-    sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> 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 '}'
@@ -306,7 +304,7 @@ pprTyVarBndr tyvar
 pprIdBndr id = ppr id <+> 
               (megaSeqIdInfo (idInfo id) `seq`
                        -- Useful for poking on black holes
-               ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> 
+               brackets (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> 
 #ifdef OLD_STRICTNESS
                            ppr (idDemandInfo id) <+>
 #endif
@@ -319,12 +317,12 @@ 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
 ppIdInfo b info
-  = hsep [  ppArityInfo a,
+  = brackets $
+    vcat [  ppArityInfo a,
            ppWorkerInfo (workerInfo info),
            ppCafInfo (cafInfo info),
 #ifdef OLD_STRICTNESS
@@ -332,7 +330,8 @@ ppIdInfo b info
             ppCprInfo m,
 #endif
            pprNewStrictness (newStrictnessInfo info),
-           vcat (map (pprCoreRule (ppr b)) (rulesRules p))
+           if null rules then empty
+           else ptext SLIT("RULES:") <+> vcat (map pprRule rules)
        -- Inline pragma, occ, demand, lbvar info
        -- printed out with all binders (when debug is on); 
        -- see PprCore.pprIdBndr
@@ -343,26 +342,28 @@ ppIdInfo b info
     s = strictnessInfo info
     m = cprInfo info
 #endif
-    p = specInfo info
+    rules = specInfoRules (specInfo info)
 \end{code}
 
 
 \begin{code}
-pprIdRules :: [IdCoreRule] -> SDoc
-pprIdRules rules = vcat (map pprIdRule rules)
+instance Outputable CoreRule where
+   ppr = pprRule
 
-pprIdRule :: IdCoreRule -> SDoc
-pprIdRule (IdCoreRule id _ rule) = pprCoreRule (ppr id) rule
+pprRules :: [CoreRule] -> SDoc
+pprRules rules = vcat (map pprRule rules)
 
-pprCoreRule :: SDoc -> CoreRule -> SDoc
-pprCoreRule pp_fn (BuiltinRule name _)
-  = ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ftext name)
+pprRule :: CoreRule -> SDoc
+pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
+  = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
 
-pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
+pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
+               ru_bndrs = tpl_vars, ru_args = tpl_args,
+               ru_rhs = rhs })
   = doubleQuotes (ftext name) <+> ppr act <+>
     sep [
          ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
-         nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
+         nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
          nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
     ] <+> semi
 \end{code}