[project @ 2003-12-10 14:15:16 by simonmar]

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

diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index d3fe50a..6f3f1ea 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
@@ -195,16 +197,7 @@ import PrelBase            ( unpackCString# )
 import GHC.Base                ( unpackCString# )
 #endif
 
-#if __GLASGOW_HASKELL__ < 411
-import PrelAddr                ( Addr(..) )
-#else
-import Addr            ( Addr(..) )
-#if __GLASGOW_HASKELL__ < 503
-import Ptr             ( Ptr(..) )
-#else
-import GHC.Ptr         ( Ptr(..) )
-#endif
-#endif
+import PrimPacked      ( Ptr(..) )
 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
 
@@ -499,7 +492,7 @@ no occurrences of @Union@ or @NoDoc@ represents just one layout.
 data Doc
  = Empty                                -- empty
  | NilAbove Doc                         -- text "" $$ x
- | TextBeside TextDetails INT Doc       -- text s <> x  
+ | TextBeside !TextDetails INT Doc       -- text s <> x  
  | Nest INT Doc                         -- nest k x
  | Union Doc Doc                        -- ul `union` ur
  | NoDoc                                -- The empty set of documents
@@ -608,12 +601,12 @@ 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 (A# a)
+  "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
  #-}
 
 nest IBOX(k)  p = mkNest k (reduceDoc p)        -- Externally callable version
@@ -1020,11 +1013,14 @@ 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 LeftMode hdl doc
+  = do { printLeftRender hdl doc; hFlush hdl }
 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 
@@ -1033,10 +1029,28 @@ printDoc mode hdl doc
 
     done = hPutChar hdl '\n'
 
+-- basically a specialised version of fullRender for LeftMode with IO output.
+printLeftRender :: Handle -> Doc -> IO ()
+printLeftRender hdl doc = lay (reduceDoc doc)
+  where
+    lay NoDoc                  = cant_fail
+    lay (Union p q)            = lay (first p q)
+    lay (Nest k p)             = lay p
+    lay Empty                  = hPutChar hdl '\n'
+    lay (NilAbove p)           = hPutChar hdl '\n' >> lay p
+    lay (TextBeside s sl p)    = put s >> lay p
+
+    put (Chr c)    = hPutChar hdl c
+    put (Str s)    = hPutStr  hdl s
+    put (PStr s)   = hPutFS   hdl s
+    put (LStr s l) = hPutLitString hdl s l
+
 #if __GLASGOW_HASKELL__ < 503
 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#)