X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=cf99e12bcf1b8f95084038c8cece8645fee64e33;hb=0f800dc9f3dc695cd06d0fdd7799a52c37241752;hp=0e55176aa2a7c69193e436a101f84259aef38ad1;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index 0e55176..cf99e12 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -7,55 +7,64 @@ Defines classes for pretty-printing and forcing, both forms of
 ``output.''
 
 \begin{code}
-{-# OPTIONS -fno-prune-tydecls #-}
--- Hopefully temporary; 3.02 complained about not being able
--- to see the consructors for ForeignObj
 
 module Outputable (
-	Outputable(..),			-- Class
+	Outputable(..), OutputableBndr(..),	-- Class
 
-	PprStyle, CodeStyle(..),
-	getPprStyle, withPprStyle, pprDeeper,
-	codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
-	ifPprDebug, ifNotPprForUser,
+	BindingSite(..),
+
+	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
+	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
+	codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
+	ifPprDebug, unqualStyle, 
+	mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
 
 	SDoc, 		-- Abstract
-	interppSP, interpp'SP, pprQuotedList,
+	docToSDoc,
+	interppSP, interpp'SP, pprQuotedList, pprWithCommas,
 	empty, nest,
-	text, char, ptext,
+	text, char, ftext, ptext,
 	int, integer, float, double, rational,
-	parens, brackets, braces, quotes, doubleQuotes,
-	semi, comma, colon, dcolon, space, equals, dot,
+	parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
+	semi, comma, colon, dcolon, space, equals, dot, arrow,
 	lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
 	(<>), (<+>), hcat, hsep, 
 	($$), ($+$), vcat, 
 	sep, cat, 
 	fsep, fcat, 
 	hang, punctuate,
-	speakNth, speakNTimes,
-
-	printSDoc, printErrs, printDump, 
-	printForC, printForAsm, printForIface,
-	pprCode, pprCols,
-	showSDoc, showsPrecSDoc, pprFSAsString,
+	speakNth, speakNTimes, speakN, speakNOf, plural,
 
+	printSDoc, printErrs, printDump,
+	printForC, printForAsm, printForUser,
+	pprCode, mkCodeStyle,
+	showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
+	showSDocUnqual, showsPrecSDoc,
+	pprHsChar, pprHsString,
 
 	-- error handling
-	pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic,
-	trace, panic, panic#, assertPanic
+	pprPanic, assertPprPanic, pprPanic#, pprPgmError, 
+	pprTrace, warnPprTrace,
+	trace, pgmError, panic, panic#, assertPanic
     ) where
 
 #include "HsVersions.h"
 
 
-import IO		( Handle, hPutChar, hPutStr, stderr, stdout )
-import CmdLineOpts	( opt_PprStyle_Debug, opt_PprUserLength )
+import {-# SOURCE #-} 	Module( Module )
+import {-# SOURCE #-} 	OccName( OccName )
+
+import StaticFlags	( opt_PprStyle_Debug, opt_PprUserLength )
+import PackageConfig	( PackageId, packageIdString )
 import FastString
 import qualified Pretty
-import Pretty		( Doc, Mode(..), TextDetails(..), fullRender )
+import Pretty		( Doc, Mode(..) )
 import Panic
-import ST		( runST )
-import Foreign
+
+import DATA_WORD	( Word32 )
+
+import IO		( Handle, stderr, stdout, hFlush )
+import Char             ( ord )
 \end{code}
 
 
@@ -67,23 +76,56 @@ import Foreign
 
 \begin{code}
 data PprStyle
-  = PprUser 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.
 
-  | PprDebug			-- Standard debugging output
+  | PprCode CodeStyle
+		-- Print code; either C or assembler
 
-  | PprInterface		-- Interface generation
-
-  | PprCode CodeStyle		-- Print code; either C or assembler
+  | 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
 
 data Depth = AllTheWay
            | PartWay Int	-- 0 => stop
+
+
+type PrintUnqualified = Module -> OccName -> Bool
+	-- This function tells when it's ok to print 
+	-- a (Global) name unqualified
+
+alwaysQualify,neverQualify :: PrintUnqualified
+alwaysQualify m n = False
+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)
+
+defaultErrStyle :: PprStyle
+-- Default style for error messages
+-- It's a bit of a hack because it doesn't take into account what's in scope
+-- Only used for desugarer warnings, and typechecker errors in interface sigs
+defaultErrStyle 
+  | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
+  | otherwise	       = mkUserStyle alwaysQualify  (PartWay opt_PprUserLength)
+
+mkUserStyle unqual depth |  opt_PprStyle_Debug = PprDebug
+	          	 |  otherwise          = PprUser unqual depth
 \end{code}
 
 Orthogonal to the above printing styles are (possibly) some
@@ -106,16 +148,27 @@ type SDoc = PprStyle -> Doc
 withPprStyle :: PprStyle -> SDoc -> SDoc
 withPprStyle sty d sty' = d sty
 
+withPprStyleDoc :: PprStyle -> SDoc -> Doc
+withPprStyleDoc sty d = d sty
+
 pprDeeper :: SDoc -> SDoc
-pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
-pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
-pprDeeper d other_sty             = d other_sty
+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}
 
 \begin{code}
+unqualStyle :: PprStyle -> PrintUnqualified
+unqualStyle (PprUser    unqual _) m n = unqual m n
+unqualStyle other		  m n = False
+
 codeStyle :: PprStyle -> Bool
 codeStyle (PprCode _)	  = True
 codeStyle _		  = False
@@ -124,23 +177,17 @@ asmStyle :: PprStyle -> Bool
 asmStyle (PprCode AsmStyle)  = True
 asmStyle other               = False
 
-ifaceStyle :: PprStyle -> Bool
-ifaceStyle PprInterface	  = True
-ifaceStyle other	  = False
+dumpStyle :: PprStyle -> Bool
+dumpStyle PprDump = True
+dumpStyle other   = False
 
 debugStyle :: PprStyle -> Bool
 debugStyle PprDebug	  = True
 debugStyle other	  = False
 
 userStyle ::  PprStyle -> Bool
-userStyle (PprUser _) = True
-userStyle other       = False
-\end{code}
-
-\begin{code}
-ifNotPprForUser :: SDoc -> SDoc	-- Returns empty document for User style
-ifNotPprForUser d sty@(PprUser _) = Pretty.empty
-ifNotPprForUser d sty             = d sty
+userStyle (PprUser _ _) = True
+userStyle other         = False
 
 ifPprDebug :: SDoc -> SDoc	  -- Empty for non-debug style
 ifPprDebug d sty@PprDebug = d sty
@@ -148,55 +195,73 @@ ifPprDebug d sty	  = Pretty.empty
 \end{code}
 
 \begin{code}
+-- Unused [7/02 sof]
 printSDoc :: SDoc -> PprStyle -> IO ()
-printSDoc d sty = printDoc PageMode stdout (d sty)
+printSDoc d sty = do
+  Pretty.printDoc PageMode stdout (d sty)
+  hFlush stdout
 
--- I'm not sure whether the direct-IO approach of printDoc
+-- I'm not sure whether the direct-IO approach of Pretty.printDoc
 -- above is better or worse than the put-big-string approach here
-printErrs :: SDoc -> IO ()
-printErrs doc = printDoc PageMode stderr (final_doc user_style)
-	      where
-		final_doc = doc $$ text ""
-		user_style = mkUserStyle (PartWay opt_PprUserLength)
+printErrs :: Doc -> IO ()
+printErrs doc = do Pretty.printDoc PageMode stderr doc
+		   hFlush stderr
 
 printDump :: SDoc -> IO ()
-printDump doc = printDoc PageMode stderr (final_doc PprDebug)
-	      where
-		final_doc = doc $$ text ""
+printDump doc = do
+   Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
+   hFlush stdout
+ where
+   better_doc = doc $$ text ""
 
+printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
+printForUser handle unqual doc 
+  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 
--- printForC, printForAsm doe what they sound like
+-- printForC, printForAsm do what they sound like
 printForC :: Handle -> SDoc -> IO ()
-printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
+printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 
 printForAsm :: Handle -> SDoc -> IO ()
-printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
-
--- printForIface prints all on one line for interface files.
--- It's called repeatedly for successive lines
-printForIface :: Handle -> SDoc -> IO ()
-printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
+printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 
 pprCode :: CodeStyle -> SDoc -> SDoc
 pprCode cs d = withPprStyle (PprCode cs) d
 
+mkCodeStyle :: CodeStyle -> PprStyle
+mkCodeStyle = PprCode
+
 -- Can't make SDoc an instance of Show because SDoc is just a function type
 -- However, Doc *is* an instance of Show
 -- showSDoc just blasts it out as a string
 showSDoc :: SDoc -> String
-showSDoc d = show (d (mkUserStyle AllTheWay))
+showSDoc d = show (d defaultUserStyle)
+
+showSDocForUser :: PrintUnqualified -> SDoc -> String
+showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
+
+showSDocUnqual :: SDoc -> String
+-- Only used in the gruesome HsExpr.isOperator
+showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 
 showsPrecSDoc :: Int -> SDoc -> ShowS
-showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
+showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
+
+showSDocDump :: SDoc -> String
+showSDocDump d = show (d PprDump)
 
-mkUserStyle depth |  opt_PprStyle_Debug = PprDebug
-	          |  otherwise          = PprUser depth
+showSDocDebug :: SDoc -> String
+showSDocDebug d = show (d PprDebug)
 \end{code}
 
 \begin{code}
+docToSDoc :: Doc -> SDoc
+docToSDoc d = \_ -> d
+
 empty sty      = Pretty.empty
 text s sty     = Pretty.text s
 char c sty     = Pretty.char c
+ftext s sty    = Pretty.ftext s
 ptext s sty    = Pretty.ptext s
 int n sty      = Pretty.int n
 integer n sty  = Pretty.integer n
@@ -207,8 +272,17 @@ rational n sty = Pretty.rational n
 parens d sty       = Pretty.parens (d sty)
 braces d sty       = Pretty.braces (d sty)
 brackets d sty     = Pretty.brackets (d sty)
-quotes d sty       = Pretty.quotes (d sty)
 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
+angleBrackets d    = char '<' <> d <> char '>'
+
+-- quotes encloses something in single quotes...
+-- but it omits them if the thing ends in a single quote
+-- so that we don't get `foo''.  Instead we just have foo'.
+quotes d sty = case show pp_d of
+		 ('\'' : _) -> pp_d
+		 other	    -> Pretty.quotes pp_d
+	     where
+	       pp_d = d sty
 
 semi sty   = Pretty.semi
 comma sty  = Pretty.comma
@@ -222,6 +296,7 @@ rbrack sty = Pretty.rbrack
 lbrace sty = Pretty.lbrace
 rbrace sty = Pretty.rbrace
 dcolon sty = Pretty.ptext SLIT("::")
+arrow  sty = Pretty.ptext SLIT("->")
 underscore = char '_'
 dot	   = char '.'
 
@@ -269,6 +344,9 @@ instance Outputable Bool where
 instance Outputable Int where
    ppr n = int n
 
+instance Outputable () where
+   ppr _ = text "()"
+
 instance (Outputable a) => Outputable [a] where
     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 
@@ -276,8 +354,8 @@ instance (Outputable a, Outputable b) => Outputable (a, b) where
     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 
 instance Outputable a => Outputable (Maybe a) where
-  ppr Nothing = text "Nothing"
-  ppr (Just x) = text "Just" <+> ppr x
+  ppr Nothing = ptext SLIT("Nothing")
+  ppr (Just x) = ptext SLIT("Just") <+> ppr x
 
 -- ToDo: may not be used
 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
@@ -286,45 +364,80 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher
 		   ppr y <> comma,
 		   ppr z ])
 
+instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
+	 Outputable (a, b, c, d) where
+    ppr (x,y,z,w) =
+      parens (sep [ppr x <> comma,
+		   ppr y <> comma,
+		   ppr z <> comma,
+		   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}
 
-pprFSAsString :: FastString -> SDoc			-- The Char instance of Show prints
-pprFSAsString fs = text (showList (unpackFS fs) "")	-- strings with double quotes and escapes
 
-instance Show FastString  where
-    showsPrec p fs = showsPrecSDoc p (ppr fs)
+%************************************************************************
+%*									*
+\subsection{The @OutputableBndr@ class}
+%*									*
+%************************************************************************
+
+When we print a binder, we often want to print its type too.
+The @OutputableBndr@ class encapsulates this idea.
+
+@BindingSite@ is used to tell the thing that prints binder what
+language construct is binding the identifier.  This can be used
+to decide how much info to print.
+
+\begin{code}
+data BindingSite = LambdaBind | CaseBind | LetBind
+
+class Outputable a => OutputableBndr a where
+   pprBndr :: BindingSite -> a -> SDoc
+   pprBndr b x = ppr x
 \end{code}
 
 
+
 %************************************************************************
 %*									*
-\subsection{Other helper functions}
+\subsection{Random printing helpers}
 %*									*
 %************************************************************************
 
 \begin{code}
-pprCols = (100 :: Int) -- could make configurable
+-- We have 31-bit Chars and will simply use Show instances
+-- of Char and String.
 
-printDoc :: Mode -> Handle -> Doc -> IO ()
-printDoc mode hdl doc
-  = fullRender mode pprCols 1.5 put done doc
-  where
-    put (Chr c)  next = hPutChar hdl c >> next 
-    put (Str s)  next = hPutStr  hdl s >> next 
-    put (PStr s) next = hPutFS   hdl s >> next 
+pprHsChar :: Char -> SDoc
+pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
+            | otherwise      = text (show c)
 
-    done = hPutChar hdl '\n'
+pprHsString :: FastString -> SDoc
+pprHsString fs = text (show (unpackFS fs))
 \end{code}
 
 
+%************************************************************************
+%*									*
+\subsection{Other helper functions}
+%*									*
+%************************************************************************
+
 \begin{code}
+pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
+pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
+
 interppSP  :: Outputable a => [a] -> SDoc
-interppSP  xs = hsep (map ppr xs)
+interppSP  xs = sep (map ppr xs)
 
 interpp'SP :: Outputable a => [a] -> SDoc
-interpp'SP xs = hsep (punctuate comma (map ppr xs))
+interpp'SP xs = sep (punctuate comma (map ppr xs))
 
 pprQuotedList :: Outputable a => [a] -> SDoc
 -- [x,y,z]  ==>  `x', `y', `z'
@@ -332,8 +445,6 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 \end{code}
 
 
-
-
 %************************************************************************
 %*									*
 \subsection{Printing numbers verbally}
@@ -345,28 +456,44 @@ 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")
 speakNth 4 = ptext SLIT("fourth")
 speakNth 5 = ptext SLIT("fifth")
 speakNth 6 = ptext SLIT("sixth")
-speakNth n = hcat [ int n, text st_nd_rd_th ]
+speakNth n = hcat [ int n, text suffix ]
   where
-    st_nd_rd_th | n_rem_10 == 1 = "st"
-		| n_rem_10 == 2 = "nd"
-		| n_rem_10 == 3 = "rd"
-		| otherwise     = "th"
-
-    n_rem_10 = n `rem` 10
-\end{code}
+    suffix | n <= 20       = "th"	-- 11,12,13 are non-std
+	   | last_dig == 1 = "st"
+	   | last_dig == 2 = "nd"
+	   | last_dig == 3 = "rd"
+	   | otherwise     = "th"
+
+    last_dig = n `rem` 10
+
+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"
 
-\begin{code}
 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}
 
 
@@ -377,23 +504,23 @@ speakNTimes t | t == 1 	   = ptext SLIT("once")
 %************************************************************************
 
 \begin{code}
-pprPanic :: String -> SDoc -> a
-pprPanic heading pretty_msg = panic (show (doc PprDebug))
-			    where
-			      doc = text heading <+> pretty_msg
-
-pprError :: String -> SDoc -> a
-pprError heading pretty_msg = error (heading++ " " ++ (showSDoc pretty_msg))
-
+pprPanic, pprPgmError :: String -> SDoc -> a
 pprTrace :: String -> SDoc -> a -> a
-pprTrace heading pretty_msg = trace (show (doc PprDebug))
-			    where
-			      doc = text heading <+> pretty_msg
+pprPanic    = pprAndThen panic		-- Throw an exn saying "bug in GHC"
+
+pprPgmError = pprAndThen pgmError	-- Throw an exn saying "bug in pgm being compiled"
+					--	(used for unusual pgm errors)
+pprTrace    = pprAndThen trace
 
 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
 			     where
 			       doc = text heading <+> pretty_msg
 
+pprAndThen :: (String -> a) -> String -> SDoc -> a
+pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
+    where
+     doc = sep [text heading, nest 4 pretty_msg]
+
 assertPprPanic :: String -> Int -> SDoc -> a
 assertPprPanic file line msg
   = panic (show (doc PprDebug))
@@ -402,4 +529,12 @@ assertPprPanic file line msg
 		 	   text file, 
 			   text "line", int line], 
 		    msg]
+
+warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
+warnPprTrace False file line msg x = x
+warnPprTrace True  file line msg x
+  = trace (show (doc PprDebug)) x
+  where
+    doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
+	       msg]
 \end{code}