[project @ 1997-09-04 19:56:48 by sof]

ppr tidy up

ghc/compiler/simplStg/SimplStg.lhs

@@ -34,7 +34,8 @@ import Id		( nullIdEnv, lookupIdEnv, addOneToIdEnv,
 			)
 import Maybes		( maybeToBool )
 import PprType		( GenType{-instance Outputable-} )
-import Outputable       ( PprStyle, Outputable(..) )
+import ErrUtils		( doIfSet )
+import Outputable       ( PprStyle, Outputable(..), printErrs, pprDumpStyle )
 import Pretty		( Doc, ($$), vcat, text, ptext )
 import UniqSupply	( splitUniqSupply, UniqSupply )
 import Util		( mapAccumL, panic, assertPanic )
@@ -43,7 +44,6 @@ import Util		( mapAccumL, panic, assertPanic )
 \begin{code}
 stg2stg :: [StgToDo]		-- spec of what stg-to-stg passes to do
 	-> FAST_STRING		-- module name (profiling only)
-	-> PprStyle		-- printing style (for debugging only)
 	-> UniqSupply		-- a name supply
 	-> [StgBinding]		-- input...
 	-> IO
@@ -51,16 +51,13 @@ stg2stg :: [StgToDo]		-- spec of what stg-to-stg passes to do
 	     ([CostCentre],	-- local cost-centres that need to be decl'd
 	      [CostCentre]))	-- "extern" cost-centres
 
-stg2stg stg_todos module_name ppr_style us binds
+stg2stg stg_todos module_name us binds
   = case (splitUniqSupply us)	of { (us4now, us4later) ->
 
-    (if do_verbose_stg2stg then
-	hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
-	hPutStr stderr (show
-	(($$) (ptext SLIT("*** Core2Stg:"))
-		 (vcat (map (ppr ppr_style) (setStgVarInfo False binds)))
-	))
-     else return ()) >>
+    doIfSet do_verbose_stg2stg
+	(printErrs (text "VERBOSE STG-TO-STG:" $$
+		    text "*** Core2Stg:" $$
+		    vcat (map (ppr pprDumpStyle) (setStgVarInfo False binds)))) >>
 
 	-- Do the main business!
     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
@@ -110,7 +107,7 @@ stg2stg stg_todos module_name ppr_style us binds
 
     -------------
     stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
-		 then lintStgBindings ppr_style
+		 then lintStgBindings pprDumpStyle
 		 else ( \ whodunnit binds -> binds )
 
     -------------------------------------------
@@ -154,7 +151,7 @@ stg2stg stg_todos module_name ppr_style us binds
 	(if do_verbose_stg2stg then
 	    hPutStr stderr (show
 	    (($$) (text ("*** "++what++":"))
-		     (vcat (map (ppr ppr_style) binds2))
+		     (vcat (map (ppr pprDumpStyle) binds2))
 	    ))
 	 else return ()) >>
 	let

ghc/compiler/stgSyn/StgLint.lhs

@@ -61,7 +61,7 @@ lintStgBindings sty whodunnit binds
 			ptext SLIT("*** Stg Lint Errors: in "),text whodunnit, ptext SLIT(" ***"),
 			msg sty,
 			ptext SLIT("*** Offending Program ***"),
-			vcat (map (pprPlainStgBinding sty) binds),
+			pprStgBindings sty binds,
 			ptext SLIT("*** End of Offense ***")])
   where
     lint_binds :: [StgBinding] -> LintM ()

ghc/compiler/stgSyn/StgSyn.lhs

@@ -30,7 +30,7 @@ module StgSyn (
 	SYN_IE(StgBinding), SYN_IE(StgExpr), SYN_IE(StgRhs),
 	SYN_IE(StgCaseAlts), SYN_IE(StgCaseDefault),
 
-	pprPlainStgBinding,
+	pprStgBinding, pprStgBindings,
 	getArgPrimRep,
 	isLitLitArg,
 	stgArity,
@@ -498,18 +498,18 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's
 hoping he likes terminators instead...  Ditto for case alternatives.
 
 \begin{code}
-pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
+pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
 		PprStyle -> GenStgBinding bndr bdee -> Doc
 
-pprStgBinding sty (StgNonRec bndr rhs)
+pprGenStgBinding sty (StgNonRec bndr rhs)
   = hang (hsep [ppr sty bndr, equals])
     	 4 ((<>) (ppr sty rhs) semi)
 
-pprStgBinding sty (StgCoerceBinding bndr occ)
+pprGenStgBinding sty (StgCoerceBinding bndr occ)
   = hang (hsep [ppr sty bndr, equals, ptext SLIT("{-Coerce-}")])
     	 4 ((<>) (ppr sty occ) semi)
 
-pprStgBinding sty (StgRec pairs)
+pprGenStgBinding sty (StgRec pairs)
   = vcat ((ifPprDebug sty (ptext SLIT("{- StgRec (begin) -}"))) :
 	      (map (ppr_bind sty) pairs) ++ [(ifPprDebug sty (ptext SLIT("{- StgRec (end) -}")))])
   where
@@ -517,8 +517,11 @@ pprStgBinding sty (StgRec pairs)
       = hang (hsep [ppr sty bndr, equals])
 	     4 ((<>) (ppr sty expr) semi)
 
-pprPlainStgBinding :: PprStyle -> StgBinding -> Doc
-pprPlainStgBinding sty b = pprStgBinding sty b
+pprStgBinding  :: PprStyle -> StgBinding   -> Doc
+pprStgBinding sty  bind  = pprGenStgBinding sty bind
+
+pprStgBindings :: PprStyle -> [StgBinding] -> Doc
+pprStgBindings sty binds = vcat (map (pprGenStgBinding sty) binds)
 \end{code}
 
 \begin{code}
@@ -527,7 +530,7 @@ instance (Outputable bdee) => Outputable (GenStgArg bdee) where
 
 instance (Outputable bndr, Outputable bdee, Ord bdee)
 		=> Outputable (GenStgBinding bndr bdee) where
-    ppr = pprStgBinding
+    ppr = pprGenStgBinding
 
 instance (Outputable bndr, Outputable bdee, Ord bdee)
 		=> Outputable (GenStgExpr bndr bdee) where
@@ -594,17 +597,17 @@ pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a
 
 pprStgExpr sty (StgLet bind expr@(StgLet _ _))
   = ($$)
-      (sep [hang (ptext SLIT("let {")) 2 (hsep [pprStgBinding sty bind, ptext SLIT("} in")])])
+      (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding sty bind, ptext SLIT("} in")])])
       (ppr sty expr)
 
 -- general case
 pprStgExpr sty (StgLet bind expr)
-  = sep [hang (ptext SLIT("let {")) 2 (pprStgBinding sty bind),
+  = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding sty bind),
 	   hang (ptext SLIT("} in ")) 2 (ppr sty expr)]
 
 pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
   = sep [hang (ptext SLIT("let-no-escape {"))
-	    	2 (pprStgBinding sty bind),
+	    	2 (pprGenStgBinding sty bind),
 	   hang ((<>) (ptext SLIT("} in "))
 		   (ifPprDebug sty (
 		    nest 4 (