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

ppr tidy up

diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index 480d247..a14a279 100644 (file)
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/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

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 053d8e7..70bbf41 100644 (file)
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/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 ()

diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index 04003f9..7a7a65f 100644 (file)
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/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 (