+
+\begin{code}
+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
+ = 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
+ put (PStr s) next = hPutFS hdl s >> next
+ put (LStr s l) next = hPutLitString hdl s l >> next
+
+ done = hPutChar hdl '\n'
+
+ -- 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#)
+#else
+ = hPutBuf handle (Ptr a#) (I# l#)
+#endif
+
+-- Printing output in LeftMode is performance critical: it's used when
+-- dumping C and assembly output, so we allow ourselves a few dirty
+-- hacks:
+--
+-- (1) we specialise fullRender for LeftMode with IO output.
+--
+-- (2) we add a layer of buffering on top of Handles. Handles
+-- don't perform well with lots of hPutChars, which is mostly
+-- what we're doing here, because Handles have to be thread-safe
+-- and async exception-safe. We only have a single thread and don't
+-- care about exceptions, so we add a layer of fast buffering
+-- over the Handle interface.
+--
+-- (3) a few hacks in layLeft below to convince GHC to generate the right
+-- code.
+
+printLeftRender :: Handle -> Doc -> IO ()
+printLeftRender hdl doc = do
+ b <- newBufHandle hdl
+ layLeft b (reduceDoc doc)
+ bFlush b
+
+-- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
+-- this function with the IO state lambda. Otherwise we end up with
+-- closures in all the case branches.
+layLeft b _ | b `seq` False = undefined -- make it strict in b
+layLeft b NoDoc = cant_fail
+layLeft b (Union p q) = return () >> layLeft b (first p q)
+layLeft b (Nest k p) = return () >> layLeft b p
+layLeft b Empty = bPutChar b '\n'
+layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
+layLeft b (TextBeside s sl p) = put b s >> layLeft b p
+ where
+ put b _ | b `seq` False = undefined
+ put b (Chr c) = bPutChar b c
+ put b (Str s) = bPutStr b s
+ put b (PStr s) = bPutFS b s
+ put b (LStr s l) = bPutLitString b s l
+
+#if __GLASGOW_HASKELL__ < 503
+hPutBuf = hPutBufFull
+#endif
+
+\end{code}