X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=9f8a16d3af3fedfaa1a798bfbadc0bd20f8bcec7;hb=30b5ebe424ebae69b162ac3fc547eb14d898535f;hp=9eeadaf96a37e40dae36ea4d8f2010ba926757c2;hpb=be33dbc967b4915cfdb0307ae1b7ae3cee651b8c;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 9eeadaf..9f8a16d 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
 %
 %************************************************************************
 %*									*
@@ -9,26 +9,29 @@
 
 \begin{code}
 module PprCore (
-	pprCoreExpr, pprIfaceUnfolding, 
-	pprCoreBinding, pprCoreBindings
+	pprCoreExpr, pprParendExpr, pprIfaceUnfolding, 
+	pprCoreBinding, pprCoreBindings, pprIdBndr,
+	pprCoreRules, pprCoreRule
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
-import CostCentre	( showCostCentre )
-import Id		( idType, getIdInfo, isTupleCon,
-			  DataCon, GenId{-instances-}, Id
-			) 
-import IdInfo		( ppIdInfo, ppStrictnessInfo )
-import Literal		( Literal{-instances-} )
-import Outputable	-- quite a few things
+import CostCentre	( pprCostCentreCore )
+import Id		( idType, idInfo, getInlinePragma, getIdDemandInfo, getIdOccInfo, Id )
+import Var		( isTyVar )
+import IdInfo		( IdInfo,
+			  arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
+			  demandInfo, updateInfo, ppUpdateInfo, specInfo, 
+			  strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
+			  cprInfo, ppCprInfo, lbvarInfo,
+			  workerInfo, ppWorkerInfo
+			)
+import Const		( Con(..), DataCon )
+import DataCon		( isTupleCon, isUnboxedTupleCon )
+import PprType		( pprParendType, pprTyVarBndr )
 import PprEnv
-import PprType		( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
-import PrimOp		( PrimOp{-instances-} )
-import TyVar		( GenTyVar{-instances-} )
-import Unique		( Unique{-instances-} )
-import Util		( panic{-ToDo:rm-} )
+import Outputable
 \end{code}
 
 %************************************************************************
@@ -50,77 +53,43 @@ print something.
 
 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
 
+Un-annotated core dumps
+~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-pprCoreBinding  :: CoreBinding   -> SDoc
-pprCoreBindings :: [CoreBinding] -> SDoc
+pprCoreBindings :: [CoreBind] -> SDoc
+pprCoreBinding  :: CoreBind   -> SDoc
+pprCoreExpr     :: CoreExpr   -> SDoc
+pprParendExpr   :: CoreExpr   -> SDoc
 
-init_ppr_env tvbndr pbdr pocc
-  = initPprEnv
-	(Just ppr) -- literals
-	(Just ppr_con)		-- data cons
-	(Just ppr_prim)		-- primops
-	(Just (\ cc -> text (showCostCentre True cc)))
-
-	(Just tvbndr)	 	-- tyvar binders
-	(Just ppr) 		-- tyvar occs
-	(Just pprParendGenType) -- types
-
-	(Just pbdr) (Just pocc) -- value vars
-  where
-
-    ppr_con con = ppr con
-
-{-	[We now use Con {a,b,c} for Con expressions. SLPJ March 97.]
-	[We can't treat them as ordinary applications because the Con doesn't have
-	 dictionaries in it, whereas the constructor Id does.]
-
-	OLD VERSION: 
-	-- ppr_con is used when printing Con expressions; we add a "!" 
-	-- to distinguish them from ordinary applications.  But not when
-	-- printing for interfaces, where they are treated as ordinary applications
-    ppr_con con | ifaceStyle sty = ppr sty con
-	        | otherwise	 = ppr sty con <> char '!'
--}
-
-	-- We add a "!" to distinguish Primitive applications from ordinary applications.  
-	-- But not when printing for interfaces, where they are treated 
-	-- as ordinary applications
-    ppr_prim prim = getPprStyle (\sty -> if ifaceStyle sty then
-					    ppr prim
-					 else
-					    ppr prim <> char '!')
+pprCoreBindings = pprTopBinds pprCoreEnv
+pprCoreBinding  = pprTopBind pprCoreEnv
+pprCoreExpr     = ppr_expr pprCoreEnv
+pprParendExpr   = ppr_parend_expr pprCoreEnv
 
---------------
-pprCoreBindings binds = vcat (map pprCoreBinding binds)
-
-pprCoreBinding (NonRec binder expr) = ppr_binding (binder, expr)
-
-pprCoreBinding (Rec binds)
-  = vcat [ptext SLIT("Rec {"),
-	  vcat (map ppr_binding binds),
-	  ptext SLIT("end Rec }")]
-
-ppr_binding (binder, expr)
- = sep [pprCoreBinder LetBind binder, 
-        nest 2 (equals <+> pprCoreExpr expr)]
+pprCoreEnv = initCoreEnv pprCoreBinder
 \end{code}
 
-General expression printer
-
+Printer for unfoldings in interfaces
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-pprCoreExpr :: CoreExpr	-> SDoc
-pprCoreExpr = ppr_expr pprCoreEnv
+pprIfaceUnfolding :: CoreExpr -> SDoc
+pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv
+	-- Notice that it's parenthesised
 
-pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
-\end{code}
+pprIfaceArg = ppr_arg pprIfaceEnv
 
-Printer for unfoldings in interfaces
+pprIfaceEnv = initCoreEnv pprIfaceBinder
+\end{code}
 
 \begin{code}
-pprIfaceUnfolding :: CoreExpr -> SDoc
-pprIfaceUnfolding = ppr_expr pprIfaceEnv
+instance Outputable b => Outputable (Bind b) where
+    ppr bind = ppr_bind pprGenericEnv bind
 
-pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder  ppr
+instance Outputable b => Outputable (Expr b) where
+    ppr expr = ppr_expr pprGenericEnv expr
+
+pprGenericEnv :: Outputable b => PprEnv b
+pprGenericEnv = initCoreEnv (\site -> ppr)
 \end{code}
 
 %************************************************************************
@@ -129,79 +98,93 @@ pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder  ppr
 %*									*
 %************************************************************************
 
-\begin{code}
-pprGenEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
-pprGenEnv = init_ppr_env ppr (\_ -> ppr) ppr
 
-pprGenArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
-pprGenArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
-    ppr bind = ppr_bind pprGenEnv bind
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
-    ppr expr = ppr_expr pprGenEnv expr
-
-instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
-    ppr arg = ppr_arg pprGenArgEnv arg
+\begin{code}
+initCoreEnv pbdr
+  = initPprEnv
+	(Just ppr)			-- Constants
+	(Just pprCostCentreCore)	-- Cost centres
 
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
-    ppr alts = ppr_alts pprGenEnv alts
+	(Just ppr) 		-- tyvar occs
+	(Just pprParendType)    -- types
 
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
-    ppr deflt  = ppr_default pprGenEnv deflt
+	(Just pbdr) (Just ppr) -- value vars
+	-- Use pprIdBndr for this last one as a debugging device.
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection{Workhorse routines (...????...)}
+\subsection{The guts}
 %*									*
 %************************************************************************
 
 \begin{code}
+pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
+
+pprTopBind pe (NonRec binder expr)
+ = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
+
+pprTopBind pe (Rec binds)
+  = vcat [ptext SLIT("Rec {"),
+	  vcat (map (ppr_binding_pe pe) binds),
+	  ptext SLIT("end Rec }"),
+	  text ""]
+\end{code}
+
+\begin{code}
+ppr_bind :: PprEnv b -> Bind b -> SDoc
+
 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
 ppr_bind pe (Rec binds)  	  = vcat (map pp binds)
 				  where
 				    pp bind = ppr_binding_pe pe bind <> semi
 
+ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
 ppr_binding_pe pe (val_bdr, expr)
-  = sep [pValBndr pe LetBind val_bdr, 
+  = sep [pBndr pe LetBind val_bdr, 
 	 nest 2 (equals <+> ppr_expr pe expr)]
 \end{code}
 
 \begin{code}
 ppr_parend_expr pe expr
-  = let
-	parenify
-	  = case expr of
-	      Var _ -> id	-- leave unchanged
-	      Lit _ -> id
-	      _	    -> parens	-- wraps in parens
-    in
-    parenify (ppr_expr pe expr)
+  | no_parens = ppr_expr pe expr
+  | otherwise = parens (ppr_expr pe expr)
+  where
+    no_parens = case expr of
+	 	  Var _     	     -> True
+		  Con con []	     -> True
+		  Con (DataCon dc) _ -> isTupleCon dc
+		  _	             -> False
 \end{code}
 
 \begin{code}
-ppr_expr pe (Var name)   = pOcc pe name
-ppr_expr pe (Lit lit)    = pLit pe lit
+ppr_expr :: PprEnv b -> Expr b -> SDoc
+
+ppr_expr pe (Type ty)  = ptext SLIT("TYPE") <+> ppr ty	-- Wierd
+
+ppr_expr pe (Var name) = pOcc pe name
+
+ppr_expr pe (Con con [])
+  = ppr con	-- Nullary constructors too
+
+ppr_expr pe (Con (DataCon dc) args)
+	-- Drop the type arguments and print in (a,b,c) notation
+  | isTupleCon dc
+  = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))))
+  | isUnboxedTupleCon dc
+  = text "(# " <> 
+    hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <>
+    text " #)"
 
 ppr_expr pe (Con con args)
   = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
 
-ppr_expr pe (Prim prim args)
-  = pPrim pe prim <+> (sep (map (ppr_arg pe) args))
-
 ppr_expr pe expr@(Lam _ _)
   = let
-	(tyvars, vars, body) = collectBinders expr
+	(bndrs, body) = collectBinders expr
     in
-    hang (hsep [pp_vars SLIT("_/\\_") (pTyVarB  pe) tyvars,
-		pp_vars SLIT("\\")    (pValBndr pe LambdaBind) vars])
+    hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
 	 4 (ppr_expr pe body)
-  where
-    pp_vars lam pp [] = empty
-    pp_vars lam pp vs
-      = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")]
 
 ppr_expr pe expr@(App fun arg)
   = let
@@ -211,125 +194,109 @@ ppr_expr pe expr@(App fun arg)
     in
     hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
 
-ppr_expr pe (Case expr alts)
-  | only_one_alt alts
-    -- johan thinks that single case patterns should be on same line as case,
-    -- and no indent; all sane persons agree with him.
-  = let
-	ppr_bndr = pValBndr pe CaseBind
-	
-	ppr_alt (AlgAlts  [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
-	ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
-	ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l)	   ppr_arrow
-	ppr_alt (AlgAlts  ((con, params, _):[]) NoDefault)
-	  = hsep [pCon pe con,
-		   hsep (map ppr_bndr params),
-		   ppr_arrow]
-
-	ppr_rhs (AlgAlts [] (BindDefault _ expr))   = ppr_expr pe expr
-	ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
-	ppr_rhs (PrimAlts [] (BindDefault _ expr))  = ppr_expr pe expr
-	ppr_rhs (PrimAlts ((_,expr):[]) NoDefault)  = ppr_expr pe expr
-
-
-        ppr_arrow = ptext SLIT(" ->")
-    in 
-    sep
-    [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
-	    (<>) (ppr_rhs alts) (text ";}")]
-
-  | otherwise -- default "case" printing
-  = sep
-    [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
-     nest 2 (ppr_alts pe alts),
-     text "}"]
+ppr_expr pe (Case expr var [(con,args,rhs)])
+  = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
+	      hsep [ptext SLIT("of"),
+		    ppr_bndr var,
+		    char '{',
+		    ppr_case_pat pe con args
+	  ]],
+	 ppr_expr pe rhs,
+	 char '}'
+    ]
   where
-    pp_keyword = case alts of
-		  AlgAlts _ _  -> ptext SLIT("case")
-		  PrimAlts _ _ -> ptext SLIT("case#")
+    ppr_bndr = pBndr pe CaseBind
+
+ppr_expr pe (Case expr var alts)
+  = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
+	      ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
+	 nest 4 (sep (punctuate semi (map ppr_alt alts))),
+	 char '}'
+    ]
+  where
+    ppr_bndr = pBndr pe CaseBind
+ 
+    ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
+			            4 (ppr_expr pe rhs)
 
 -- special cases: let ... in let ...
 -- ("disgusting" SLPJ)
 
 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
   = vcat [
-      hsep [ptext SLIT("let {"), pValBndr pe LetBind val_bdr, equals],
+      hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
       nest 2 (ppr_expr pe rhs),
       ptext SLIT("} in"),
       ppr_expr pe body ]
 
 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
-  = ($$)
-      (hang (ptext SLIT("let {"))
-	    2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals])
+  = hang (ptext SLIT("let {"))
+	  2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
 			   4 (ppr_expr pe rhs),
-       ptext SLIT("} in")]))
-      (ppr_expr pe expr)
+       ptext SLIT("} in")])
+    $$
+    ppr_expr pe expr
 
 -- general case (recursive case, too)
 ppr_expr pe (Let bind expr)
   = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
-	   hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
+	 hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
   where
     keyword = case bind of
-		Rec _      -> SLIT("_letrec_ {")
+		Rec _      -> SLIT("__letrec {")
 		NonRec _ _ -> SLIT("let {")
 
-ppr_expr pe (SCC cc expr)
-  = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
-	   ppr_parend_expr pe expr ]
-
-ppr_expr pe (Coerce c ty expr)
-  = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
+ppr_expr pe (Note (SCC cc) expr)
+  = sep [pSCC pe cc, ppr_expr pe expr]
+
+#ifdef DEBUG
+ppr_expr pe (Note (Coerce to_ty from_ty) expr)
+ = getPprStyle $ \ sty ->
+   if debugStyle sty && not (ifaceStyle sty) then
+      sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
+	   ppr_parend_expr pe expr]
+   else
+      sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
+	          ppr_parend_expr pe expr]
+#else
+ppr_expr pe (Note (Coerce to_ty from_ty) expr)
+  = sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
+	 ppr_parend_expr pe expr]
+#endif
+
+ppr_expr pe (Note InlineCall expr)
+  = ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr
+
+ppr_expr pe (Note InlineMe expr)
+  = ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
+
+ppr_expr pe (Note (TermUsg u) expr)
+  = \ sty ->
+    if ifaceStyle sty then
+      ppr_expr pe expr sty
+    else
+      (ppr u <+> ppr_expr pe expr) sty
+
+ppr_case_pat pe con@(DataCon dc) args
+  | isTupleCon dc
+  = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
+  | isUnboxedTupleCon dc
+  = hsep [text "(# " <> 
+	  hsep (punctuate comma (map ppr_bndr args)) <>
+	  text " #)",
+	  arrow]
   where
-    pp_coerce (CoerceIn  v) = (<>) (ptext SLIT("_coerce_in_ "))  (ppr v)
-    pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr v)
-
-only_one_alt (AlgAlts []     (BindDefault _ _)) = True
-only_one_alt (AlgAlts (_:[])  NoDefault) 	= True
-only_one_alt (PrimAlts []    (BindDefault _ _)) = True
-only_one_alt (PrimAlts (_:[]) NoDefault) 	= True
-only_one_alt _					= False 
-\end{code}
+    ppr_bndr = pBndr pe CaseBind
 
-\begin{code}
-ppr_alts pe (AlgAlts alts deflt)
-  = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
+ppr_case_pat pe con args
+  = pCon pe con <+> hsep (map ppr_bndr args) <+> arrow
   where
-    ppr_arrow = ptext SLIT("->")
-    ppr_bndr = pValBndr pe CaseBind
-
-    ppr_alt (con, params, expr)
-      = hang (if isTupleCon con then
-		    hsep [parens (hsep (punctuate comma (map ppr_bndr params))),
-			  ppr_arrow]
-		else
-		    hsep [pCon pe con,
-			  hsep (map ppr_bndr params),
-			   ppr_arrow]
-	       )
-	     4 (ppr_expr pe expr <> semi)
-
-ppr_alts pe (PrimAlts alts deflt)
-  = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
-  where
-    ppr_alt (lit, expr)
-      = hang (hsep [pLit pe lit, ptext SLIT("->")])
-	     4 (ppr_expr pe expr <> semi)
-\end{code}
+    ppr_bndr = pBndr pe CaseBind
 
-\begin{code}
-ppr_default pe NoDefault = empty
-
-ppr_default pe (BindDefault val_bdr expr)
-  = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")])
-	 4 (ppr_expr pe expr <> semi)
-\end{code}
+ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
+ppr_arg pe expr      = ppr_parend_expr pe expr
 
-\begin{code}
-ppr_arg pe (LitArg   lit) = pLit pe lit
-ppr_arg pe (VarArg   v)	  = pOcc pe v
-ppr_arg pe (TyArg    ty)  = ptext SLIT("_@_ ") <> pTy pe ty
+arrow = ptext SLIT("->")
 \end{code}
 
 Other printing bits-and-bobs used with the general @pprCoreBinding@
@@ -341,21 +308,81 @@ pprCoreBinder LetBind binder
   = vcat [sig, pragmas, ppr binder]
   where
     sig     = pprTypedBinder binder
-    pragmas = ppIdInfo False{-no specs, thanks-} (getIdInfo binder)
+    pragmas = ppIdInfo (idInfo binder)
 
-pprCoreBinder LambdaBind binder = pprTypedBinder binder
-pprCoreBinder CaseBind   binder = ppr binder
+-- Lambda bound type variables are preceded by "@"
+pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
 
+-- Case bound things don't get a signature or a herald
+pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
 
 -- Used for printing interface-file unfoldings
-pprIfaceBinder CaseBind binder = ppr binder
+pprIfaceBinder CaseBind binder = pprUntypedBinder binder
 pprIfaceBinder other    binder = pprTypedBinder binder
 
+pprUntypedBinder binder
+  | isTyVar binder = pprTyVarBndr binder
+  | otherwise      = pprIdBndr binder
+
 pprTypedBinder binder
-  = ppr binder <+> ptext SLIT("::") <+> pprParendGenType (idType binder)
+  | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
+  | otherwise	    = pprIdBndr binder <+> dcolon <+> pprParendType (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) -> ...
+
+-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
+pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdOccInfo id) <+> 
+				      ppr (getIdDemandInfo id)) <+> ppr (lbvarInfo (idInfo id))
+\end{code}
+
+
+\begin{code}
+ppIdInfo :: IdInfo -> SDoc
+ppIdInfo info
+  = hsep [
+	    ppFlavourInfo (flavourInfo info),
+	    ppArityInfo a,
+	    ppUpdateInfo u,
+	    ppWorkerInfo (workerInfo info),
+	    ppStrictnessInfo s,
+	    ppr d,
+	    ppCafInfo c,
+            ppCprInfo m,
+	    ppr (lbvarInfo info),
+	    pprIfaceCoreRules p
+	-- Inline pragma printed out with all binders; see PprCore.pprIdBndr
+	]
+  where
+    a = arityInfo info
+    d = demandInfo info
+    s = strictnessInfo info
+    u = updateInfo info
+    c = cafInfo info
+    m = cprInfo info
+    p = specInfo info
+\end{code}
+
+
+\begin{code}
+pprCoreRules :: Id -> CoreRules -> SDoc
+pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules)
+
+pprIfaceCoreRules :: CoreRules -> SDoc
+pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
+
+pprCoreRule :: Maybe Id -> CoreRule -> SDoc
+pprCoreRule maybe_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 pprIfaceArg tpl_args)),
+	  nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
+    ]
+  where
+    pp_fn = case maybe_fn of
+	    	Just id -> ppr id
+		Nothing -> empty		-- Interface file
 \end{code}