X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=5a4368c09ab6e5dc6fdfe66dfe40d3b6bea3e30a;hb=a8a2fc9c81ec4e8991a9a9f75f26c19d7f88d560;hp=c8345fb6bf9c67166755b125f07eaa64ed674cf7;hpb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index c8345fb..5a4368c 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -15,7 +15,7 @@ module Outputable (
 
 	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
 	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
-	codeStyle, userStyle, debugStyle, asmStyle,
+	codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
 	ifPprDebug, unqualStyle, 
 	mkErrStyle, defaultErrStyle,
 
@@ -55,6 +55,7 @@ import {-# SOURCE #-} 	Module( Module )
 import {-# SOURCE #-} 	OccName( OccName )
 
 import CmdLineOpts	( opt_PprStyle_Debug, opt_PprUserLength )
+import PackageConfig	( PackageId, packageIdString )
 import FastString
 import qualified Pretty
 import Pretty		( Doc, Mode(..) )
@@ -75,14 +76,21 @@ import Char             ( ord )
 
 \begin{code}
 data PprStyle
-  = PprUser PrintUnqualified Depth	-- Pretty-print in a way that will
-					-- make sense to the ordinary user;
-					-- must be very close to Haskell
-					-- syntax, etc.
+  = PprUser PrintUnqualified Depth
+		-- Pretty-print in a way that will make sense to the
+		-- ordinary user; must be very close to Haskell
+		-- syntax, etc.
+		-- Assumes printing tidied code: non-system names are
+		-- printed without uniques.
 
-  | PprCode CodeStyle		-- Print code; either C or assembler
+  | PprCode CodeStyle
+		-- Print code; either C or assembler
 
-  | PprDebug			-- Standard debugging output
+  | PprDump	-- For -ddump-foo; less verbose than PprDebug.
+		-- Does not assume tidied code: non-external names
+		-- are printed with uniques.
+
+  | PprDebug	-- Full debugging output
 
 data CodeStyle = CStyle		-- The format of labels differs for C and assembler
 	       | AsmStyle
@@ -101,6 +109,9 @@ neverQualify  m n = True
 
 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
 
+defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
+		 |  otherwise          = PprDump
+
 mkErrStyle :: PrintUnqualified -> PprStyle
 -- Style for printing error messages
 mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
@@ -162,6 +173,10 @@ asmStyle :: PprStyle -> Bool
 asmStyle (PprCode AsmStyle)  = True
 asmStyle other               = False
 
+dumpStyle :: PprStyle -> Bool
+dumpStyle PprDump = True
+dumpStyle other   = False
+
 debugStyle :: PprStyle -> Bool
 debugStyle PprDebug	  = True
 debugStyle other	  = False
@@ -190,7 +205,7 @@ printErrs doc = do Pretty.printDoc PageMode stderr doc
 
 printDump :: SDoc -> IO ()
 printDump doc = do
-   Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
+   Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
    hFlush stdout
  where
    better_doc = doc $$ text ""
@@ -356,6 +371,9 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 instance Outputable FastString where
     ppr fs = text (unpackFS fs)		-- Prints an unadorned string,
 					-- no double quotes or anything
+
+instance Outputable PackageId where
+   ppr pid = text (packageIdString pid)
 \end{code}