X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=22ee21ba8a6ca1cc9148ff6a6f7f99571f3b7020;hb=36d22a1cb608e8572776ab6d402fd0c1a9287dc5;hp=061975e599f10538cbc1ca0e24b610955d9d4bea;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 061975e..22ee21b 100644
--- 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,31 +19,31 @@ 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, 
-#endif
 			  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, 
+import Id		( idDemandInfo )
+import IdInfo		( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo ) 
 #endif
-			)
+
 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 +138,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
@@ -152,11 +152,11 @@ ppr_expr add_par expr@(App fun arg)
 	other -> add_par (hang (pprParendExpr fun) 2 pp_args)
     }
 
-ppr_expr add_par (Case expr var [(con,args,rhs)])
+ppr_expr add_par (Case expr var ty [(con,args,rhs)])
   = add_par $
-    sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+    sep [sep [ptext SLIT("case") <+> pprParendType ty <+> pprCoreExpr expr,
 	      hsep [ptext SLIT("of"),
-		    ppr_bndr var,
+		    ppr_bndr var, 
 		    char '{',
 		    ppr_case_pat con args
 	  ]],
@@ -166,9 +166,9 @@ ppr_expr add_par (Case expr var [(con,args,rhs)])
   where
     ppr_bndr = pprBndr CaseBind
 
-ppr_expr add_par (Case expr var alts)
+ppr_expr add_par (Case expr var ty alts)
   = add_par $
-    sep [sep [ptext SLIT("case") <+> 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 '}'
@@ -235,6 +235,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 +257,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@
@@ -271,7 +274,7 @@ pprCoreBinder LetBind binder
     pragmas = ppIdInfo binder (idInfo binder)
 
 -- Lambda bound type variables are preceded by "@"
-pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
+pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
 
 -- Case bound things don't get a signature or a herald
 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
@@ -283,12 +286,17 @@ pprUntypedBinder binder
 pprTypedBinder binder
   | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
   | otherwise	    = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
-	-- The space before the :: is important; it helps the lexer
-	-- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
-	--
-	-- It's important that the type is parenthesised too, at least when
-	-- 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
@@ -313,14 +321,17 @@ pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
 
 ppIdInfo :: Id -> IdInfo -> SDoc
 ppIdInfo b info
-  = hsep [  ppArityInfo a,
+  = brackets $
+    vcat [  ppArityInfo a,
 	    ppWorkerInfo (workerInfo info),
+	    ppCafInfo (cafInfo info),
 #ifdef OLD_STRICTNESS
 	    ppStrictnessInfo s,
             ppCprInfo m,
 #endif
 	    pprNewStrictness (newStrictnessInfo info),
-	    vcat (map (pprCoreRule (ppr b)) (rulesRules p))
+	    if null rules then empty
+	    else ptext SLIT("RULES:") <+> vcat (map (pprCoreRule (ppr b)) rules)
 	-- Inline pragma, occ, demand, lbvar info
 	-- printed out with all binders (when debug is on); 
 	-- see PprCore.pprIdBndr
@@ -331,7 +342,7 @@ ppIdInfo b info
     s = strictnessInfo info
     m = cprInfo info
 #endif
-    p = specInfo info
+    rules = rulesRules (specInfo info)
 \end{code}
 
 
@@ -340,12 +351,11 @@ pprIdRules :: [IdCoreRule] -> SDoc
 pprIdRules rules = vcat (map pprIdRule rules)
 
 pprIdRule :: IdCoreRule -> SDoc
-pprIdRule (id,rule) = pprCoreRule (ppr id) rule
+pprIdRule (IdCoreRule 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 <+>