#include "HsVersions.h"
import FastString
-import GlaExts
-import Numeric (fromRat)
import PrimPacked ( strLength )
+
+import GLAEXTS
+
+import Numeric (fromRat)
import IO
#if __GLASGOW_HASKELL__ < 503
import GHC.Base ( unpackCString# )
#endif
-import PrimPacked ( strLength )
-
-#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
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
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
\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
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#)