[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 6a1c07f..6f3f1ea 100644 (file)
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -492,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
@@ -1013,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 
@@ -1026,6 +1029,22 @@ 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