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

diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index c8345fb..cf99e12 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -14,10 +14,10 @@ module Outputable (
 	BindingSite(..),
 
 	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
-	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
-	codeStyle, userStyle, debugStyle, asmStyle,
+	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
+	codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
 	ifPprDebug, unqualStyle, 
-	mkErrStyle, defaultErrStyle,
+	mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
 
 	SDoc, 		-- Abstract
 	docToSDoc,
@@ -33,12 +33,12 @@ module Outputable (
 	sep, cat, 
 	fsep, fcat, 
 	hang, punctuate,
-	speakNth, speakNTimes,
+	speakNth, speakNTimes, speakN, speakNOf, plural,
 
 	printSDoc, printErrs, printDump,
 	printForC, printForAsm, printForUser,
 	pprCode, mkCodeStyle,
-	showSDoc, showSDocForUser, showSDocDebug,
+	showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
 	showSDocUnqual, showsPrecSDoc,
 	pprHsChar, pprHsString,
 
@@ -54,7 +54,8 @@ module Outputable (
 import {-# SOURCE #-} 	Module( Module )
 import {-# SOURCE #-} 	OccName( OccName )
 
-import CmdLineOpts	( opt_PprStyle_Debug, opt_PprUserLength )
+import StaticFlags	( 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)
@@ -145,6 +156,10 @@ pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
 pprDeeper d other_sty        		 = d other_sty
 
+pprSetDepth :: Int -> SDoc -> SDoc
+pprSetDepth n d (PprUser unqual _) = d (PprUser unqual (PartWay n))
+pprSetDepth n d other_sty	   = d other_sty
+
 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 getPprStyle df sty = df sty sty
 \end{code}
@@ -162,6 +177,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,13 +209,10 @@ 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 ""
-    -- We used to always print in debug style, but I want
-    -- to try the effect of a more user-ish style (unless you
-    -- say -dppr-debug)
 
 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 printForUser handle unqual doc 
@@ -231,6 +247,9 @@ showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 showsPrecSDoc :: Int -> SDoc -> ShowS
 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 
+showSDocDump :: SDoc -> String
+showSDocDump d = show (d PprDump)
+
 showSDocDebug :: SDoc -> String
 showSDocDebug d = show (d PprDebug)
 \end{code}
@@ -354,8 +373,11 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 		   ppr w])
 
 instance Outputable FastString where
-    ppr fs = text (unpackFS fs)		-- Prints an unadorned string,
-					-- no double quotes or anything
+    ppr fs = ftext fs		-- Prints an unadorned string,
+				-- no double quotes or anything
+
+instance Outputable PackageId where
+   ppr pid = text (packageIdString pid)
 \end{code}
 
 
@@ -398,9 +420,6 @@ pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) ::
 
 pprHsString :: FastString -> SDoc
 pprHsString fs = text (show (unpackFS fs))
-
-instance Show FastString  where
-    showsPrec p fs = showsPrecSDoc p (ppr fs)
 \end{code}
 
 
@@ -437,7 +456,6 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 
 \begin{code}
 speakNth :: Int -> SDoc
-
 speakNth 1 = ptext SLIT("first")
 speakNth 2 = ptext SLIT("second")
 speakNth 3 = ptext SLIT("third")
@@ -453,13 +471,29 @@ speakNth n = hcat [ int n, text suffix ]
 	   | otherwise     = "th"
 
     last_dig = n `rem` 10
-\end{code}
 
-\begin{code}
+speakN :: Int -> SDoc
+speakN 0 = ptext SLIT("none")	-- E.g.  "he has none"
+speakN 1 = ptext SLIT("one")	-- E.g.  "he has one"
+speakN 2 = ptext SLIT("two")
+speakN 3 = ptext SLIT("three")
+speakN 4 = ptext SLIT("four")
+speakN 5 = ptext SLIT("five")
+speakN 6 = ptext SLIT("six")
+speakN n = int n
+
+speakNOf :: Int -> SDoc -> SDoc
+speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'	-- E.g. "no arguments"
+speakNOf 1 d = ptext SLIT("one") <+> d			-- E.g. "one argument"
+speakNOf n d = speakN n <+> d <> char 's'		-- E.g. "three arguments"
+
 speakNTimes :: Int {- >=1 -} -> SDoc
 speakNTimes t | t == 1 	   = ptext SLIT("once")
               | t == 2 	   = ptext SLIT("twice")
-              | otherwise  = int t <+> ptext SLIT("times")
+              | otherwise  = speakN t <+> ptext SLIT("times")
+
+plural [x] = empty
+plural xs  = char 's'
 \end{code}