[project @ 2003-10-09 11:58:39 by simonpj]

[ghc-hetmet.git] / ghc / compiler / utils / Pretty.lhs

diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index 6f4f614..a3cb532 100644 (file)
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -178,9 +178,11 @@ module Pretty (
 #include "HsVersions.h"
 
 import FastString
-import GlaExts
-import Numeric (fromRat)
 import PrimPacked      ( strLength )
+
+import GLAEXTS
+
+import Numeric (fromRat)
 import IO
 
 #if __GLASGOW_HASKELL__ < 503
@@ -189,7 +191,13 @@ import IOExts              ( hPutBufFull )
 import System.IO       ( hPutBuf )
 #endif
 
-import PrimPacked      ( strLength )
+#if __GLASGOW_HASKELL__ < 503
+import PrelBase                ( unpackCString# )
+#else
+import GHC.Base                ( unpackCString# )
+#endif
+
+import PrimPacked      ( Ptr(..) )
 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
 
@@ -593,7 +601,13 @@ isEmpty _     = False
 char  c = textBeside_ (Chr c) 1# Empty
 text  s = case length   s of {IBOX(sl) -> textBeside_ (Str s)  sl Empty}
 ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
-ptext (A# s) = case strLength (A# s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
+ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
+
+-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
+-- intermediate packing/unpacking of the string.
+{-# RULES 
+  "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
+ #-}
 
 nest IBOX(k)  p = mkNest k (reduceDoc p)        -- Externally callable version
 
@@ -999,11 +1013,12 @@ spaces n       = ' ' : spaces (n MINUS ILIT(1))
 \end{code}
 
 \begin{code}
-pprCols = (100 :: Int) -- could make configurable
+pprCols = (120 :: Int) -- could make configurable
 
 printDoc :: Mode -> Handle -> Doc -> IO ()
 printDoc mode hdl doc
-  = fullRender mode pprCols 1.5 put done doc
+  = do { fullRender mode pprCols 1.5 put done doc ;
+        hFlush hdl }
   where
     put (Chr c)  next = hPutChar hdl c >> next 
     put (Str s)  next = hPutStr  hdl s >> next 
@@ -1016,6 +1031,8 @@ printDoc mode hdl doc
 hPutBuf = hPutBufFull
 #endif
 
+  -- some versions of hPutBuf will barf if the length is zero
+hPutLitString handle a# 0# = return ()
 hPutLitString handle a# l#
 #if __GLASGOW_HASKELL__ < 411
   = hPutBuf handle (A# a#) (I# l#)