X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=d96a14ad9b7a2cffa93740cbc56d7cc5ccf313dd;hb=95581e0c3b2d4d6edd33fdd6e135aa3917072c4c;hp=165ce0368cb6da70704e4d365eb01e11b9ecc1a0;hpb=998444dc513e63103f9854543da4f603b2025744;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index 165ce03..d96a14a 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -12,11 +12,12 @@ module Outputable (
 	Outputable(..),			-- Class
 
 	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
-	getPprStyle, withPprStyle, pprDeeper,
-	codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
+	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
+	codeStyle, userStyle, debugStyle, asmStyle,
 	ifPprDebug, unqualStyle,
 
 	SDoc, 		-- Abstract
+	docToSDoc,
 	interppSP, interpp'SP, pprQuotedList, pprWithCommas,
 	empty, nest,
 	text, char, ptext,
@@ -32,9 +33,9 @@ module Outputable (
 	speakNth, speakNTimes,
 
 	printSDoc, printErrs, printDump,
-	printForC, printForAsm, printForIface, printForUser,
-	pprCode, pprCols,
-	showSDoc, showSDocForUser, showSDocDebug, showSDocIface, 
+	printForC, printForAsm, printForUser,
+	pprCode, mkCodeStyle,
+	showSDoc, showSDocForUser, showSDocDebug,
 	showSDocUnqual, showsPrecSDoc,
 	pprHsChar, pprHsString,
 
@@ -56,8 +57,11 @@ import Pretty		( Doc, Mode(..), TextDetails(..), fullRender )
 import Panic
 
 import Word		( Word32 )
-import IO		( Handle, hPutChar, hPutStr, stderr, stdout )
-import Char             ( chr, ord, isDigit )
+import IO		( Handle, stderr, stdout )
+import Char             ( chr )
+#if __GLASGOW_HASKELL__ < 410
+import Char		( ord, isDigit )
+#endif
 \end{code}
 
 
@@ -121,6 +125,9 @@ 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 unqual (PartWay 0)) = Pretty.text "..."
 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
@@ -144,10 +151,6 @@ asmStyle :: PprStyle -> Bool
 asmStyle (PprCode AsmStyle)  = True
 asmStyle other               = False
 
-ifaceStyle :: PprStyle -> Bool
-ifaceStyle (PprInterface _) = True
-ifaceStyle other	    = False
-
 debugStyle :: PprStyle -> Bool
 debugStyle PprDebug	  = True
 debugStyle other	  = False
@@ -163,17 +166,17 @@ ifPprDebug d sty	  = Pretty.empty
 
 \begin{code}
 printSDoc :: SDoc -> PprStyle -> IO ()
-printSDoc d sty = printDoc PageMode stdout (d sty)
+printSDoc d sty = Pretty.printDoc PageMode stdout (d sty)
 
--- 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 :: PrintUnqualified -> SDoc -> IO ()
-printErrs unqual doc = printDoc PageMode stderr (doc style)
+printErrs unqual doc = Pretty.printDoc PageMode stderr (doc style)
 		     where
 		       style = mkUserStyle unqual (PartWay opt_PprUserLength)
 
 printDump :: SDoc -> IO ()
-printDump doc = printDoc PageMode stdout (better_doc defaultUserStyle)
+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
@@ -182,24 +185,21 @@ printDump doc = printDoc PageMode stdout (better_doc defaultUserStyle)
 
 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 printForUser handle unqual doc 
-  = printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
-
--- printForIface prints all on one line for interface files.
--- It's called repeatedly for successive lines
-printForIface :: Handle -> PrintUnqualified -> SDoc -> IO ()
-printForIface handle unqual doc 
-  = printDoc LeftMode handle (doc (PprInterface unqual))
+  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 
 -- 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))
+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
@@ -216,14 +216,14 @@ showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 showsPrecSDoc :: Int -> SDoc -> ShowS
 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 
-showSDocIface :: SDoc -> String
-showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify))
-
 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
@@ -371,8 +371,8 @@ showCharLit c rest
 -- of Char and String.
 
 pprHsChar :: Int -> SDoc
-pprHsChar c | not (inCharRange c) = char '\\' <> show (fromIntegral c :: Word32)
-            | otherwise = text (show (chr c))
+pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32))
+            | otherwise    = text (show (chr c))
 
 pprHsString :: FastString -> SDoc
 pprHsString fs = text (show (unpackFS fs))
@@ -391,18 +391,6 @@ instance Show FastString  where
 %************************************************************************
 
 \begin{code}
-pprCols = (100 :: Int) -- could make configurable
-
-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 
-
-    done = hPutChar hdl '\n'
-
 showDocWith :: Mode -> Doc -> String
 showDocWith mode doc
   = fullRender mode 100 1.5 put "" doc