X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=6e98c2fbcb34cdd05260b9a6c96a7de3f2a2fd50;hb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;hp=d96a14ad9b7a2cffa93740cbc56d7cc5ccf313dd;hpb=0e8e53db37d75d506d3a5b2804342442a5142d59;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index d96a14a..6e98c2f 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -9,21 +9,24 @@ Defines classes for pretty-printing and forcing, both forms of
 \begin{code}
 
 module Outputable (
-	Outputable(..),			-- Class
+	Outputable(..), OutputableBndr(..),	-- Class
+
+	BindingSite(..),
 
 	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
 	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
 	codeStyle, userStyle, debugStyle, asmStyle,
-	ifPprDebug, unqualStyle,
+	ifPprDebug, unqualStyle, 
+	mkErrStyle, defaultErrStyle,
 
 	SDoc, 		-- Abstract
 	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, angleBrackets,
-	semi, comma, colon, dcolon, space, equals, dot,
+	semi, comma, colon, dcolon, space, equals, dot, arrow,
 	lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
 	(<>), (<+>), hcat, hsep, 
 	($$), ($+$), vcat, 
@@ -53,15 +56,13 @@ import {-# SOURCE #-} 	Name( Name )
 import CmdLineOpts	( opt_PprStyle_Debug, opt_PprUserLength )
 import FastString
 import qualified Pretty
-import Pretty		( Doc, Mode(..), TextDetails(..), fullRender )
+import Pretty		( Doc, Mode(..) )
 import Panic
 
-import Word		( Word32 )
-import IO		( Handle, stderr, stdout )
-import Char             ( chr )
-#if __GLASGOW_HASKELL__ < 410
-import Char		( ord, isDigit )
-#endif
+import DATA_WORD	( Word32 )
+
+import IO		( Handle, stderr, stdout, hFlush )
+import Char             ( chr, ord )
 \end{code}
 
 
@@ -78,8 +79,6 @@ data PprStyle
 					-- must be very close to Haskell
 					-- syntax, etc.
 
-  | PprInterface PrintUnqualified	-- Interface generation
-
   | PprCode CodeStyle		-- Print code; either C or assembler
 
   | PprDebug			-- Standard debugging output
@@ -101,6 +100,18 @@ neverQualify  n = True
 
 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
 
+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}
@@ -140,7 +151,6 @@ getPprStyle df sty = df sty sty
 \begin{code}
 unqualStyle :: PprStyle -> Name -> Bool
 unqualStyle (PprUser    unqual _) n = unqual n
-unqualStyle (PprInterface unqual) n = unqual n
 unqualStyle other		  n = False
 
 codeStyle :: PprStyle -> Bool
@@ -165,23 +175,27 @@ ifPprDebug d sty	  = Pretty.empty
 \end{code}
 
 \begin{code}
+-- Unused [7/02 sof]
 printSDoc :: SDoc -> PprStyle -> IO ()
-printSDoc d sty = Pretty.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 Pretty.printDoc
 -- above is better or worse than the put-big-string approach here
-printErrs :: PrintUnqualified -> SDoc -> IO ()
-printErrs unqual doc = Pretty.printDoc PageMode stderr (doc style)
-		     where
-		       style = mkUserStyle unqual (PartWay opt_PprUserLength)
+printErrs :: Doc -> IO ()
+printErrs doc = do Pretty.printDoc PageMode stderr doc
+		   hFlush stderr
 
 printDump :: SDoc -> IO ()
-printDump doc = Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
-  	      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
+printDump doc = do
+   Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
+   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 
@@ -227,6 +241,7 @@ 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
@@ -261,6 +276,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 '.'
 
@@ -339,46 +355,49 @@ 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
+\end{code}
+
+
+%************************************************************************
+%*									*
+\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
 
-#if __GLASGOW_HASKELL__ < 410
--- Assume we have only 8-bit Chars.
-
-pprHsChar :: Int -> SDoc
-pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
-
-pprHsString :: FAST_STRING -> SDoc
-pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
-
-showCharLit :: Int -> String -> String
-showCharLit c rest
-    | c == ord '\"' = "\\\"" ++ rest
-    | c == ord '\'' = "\\\'" ++ rest
-    | c == ord '\\' = "\\\\" ++ rest
-    | c >= 0x20 && c <= 0x7E = chr c : rest
-    | c == ord '\a' = "\\a" ++ rest
-    | c == ord '\b' = "\\b" ++ rest
-    | c == ord '\f' = "\\f" ++ rest
-    | c == ord '\n' = "\\n" ++ rest
-    | c == ord '\r' = "\\r" ++ rest
-    | c == ord '\t' = "\\t" ++ rest
-    | c == ord '\v' = "\\v" ++ rest
-    | otherwise     = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
-        d:_ | isDigit d -> "\\&" ++ rest
-        _               -> rest
-
-#else
+class Outputable a => OutputableBndr a where
+   pprBndr :: BindingSite -> a -> SDoc
+   pprBndr b x = ppr x
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+\subsection{Random printing helpers}
+%*									*
+%************************************************************************
+
+\begin{code}
 -- We have 31-bit Chars and will simply use Show instances
 -- of Char and String.
 
-pprHsChar :: Int -> SDoc
-pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32))
-            | otherwise    = text (show (chr c))
+pprHsChar :: Char -> SDoc
+pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
+            | otherwise      = text (show c)
 
 pprHsString :: FastString -> SDoc
 pprHsString fs = text (show (unpackFS fs))
 
-#endif
-
 instance Show FastString  where
     showsPrec p fs = showsPrecSDoc p (ppr fs)
 \end{code}
@@ -391,19 +410,8 @@ instance Show FastString  where
 %************************************************************************
 
 \begin{code}
-showDocWith :: Mode -> Doc -> String
-showDocWith mode doc
-  = fullRender mode 100 1.5 put "" doc
-  where
-    put (Chr c)   s  = c:s
-    put (Str s1)  s2 = s1 ++ s2
-    put (PStr s1) s2 = _UNPK_ s1 ++ s2
-\end{code}
-
-
-\begin{code}
 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
-pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
+pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 
 interppSP  :: Outputable a => [a] -> SDoc
 interppSP  xs = hsep (map ppr xs)
@@ -435,14 +443,15 @@ 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"
+    suffix | n <= 20       = "th"	-- 11,12,13 are non-std
+	   | last_dig == 1 = "st"
+	   | last_dig == 2 = "nd"
+	   | last_dig == 3 = "rd"
+	   | otherwise     = "th"
 
-    n_rem_10 = n `rem` 10
+    last_dig = n `rem` 10
 \end{code}
 
 \begin{code}