X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=7aa2461851ecd132579aabf73144ee5cb4464afc;hb=eca4400fe193c38ecea52894fa659b8388fbb0bc;hp=c8e454da900b0042d4b8df209e2d53e09f26aa65;hpb=1c62b517711ac232a8024d91fd4b317a6804d28e;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index c8e454d..7aa2461 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -17,6 +17,7 @@ module Outputable (
 	ifPprDebug, unqualStyle,
 
 	SDoc, 		-- Abstract
+	docToSDoc,
 	interppSP, interpp'SP, pprQuotedList, pprWithCommas,
 	empty, nest,
 	text, char, ptext,
@@ -49,12 +50,14 @@ module Outputable (
 
 import {-# SOURCE #-} 	Name( Name )
 
-import IO		( Handle, hPutChar, hPutStr, stderr, stdout )
 import CmdLineOpts	( opt_PprStyle_Debug, opt_PprUserLength )
 import FastString
 import qualified Pretty
 import Pretty		( Doc, Mode(..), TextDetails(..), fullRender )
 import Panic
+
+import Word		( Word32 )
+import IO		( Handle, hPutChar, hPutStr, stderr, stdout )
 import Char             ( chr, ord, isDigit )
 \end{code}
 
@@ -222,6 +225,9 @@ 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
@@ -360,7 +366,7 @@ showCharLit c rest
     | c == ord '\r' = "\\r" ++ rest
     | c == ord '\t' = "\\t" ++ rest
     | c == ord '\v' = "\\v" ++ rest
-    | otherwise     = ('\\':) $ shows c $ case rest of
+    | otherwise     = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
         d:_ | isDigit d -> "\\&" ++ rest
         _               -> rest
 
@@ -369,7 +375,8 @@ showCharLit c rest
 -- of Char and String.
 
 pprHsChar :: Int -> SDoc
-pprHsChar c = 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))