@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE BangPatterns, CPP #-}
22-- |
33-- Module : Data.Text.IO
44-- Copyright : (c) Bryan O'Sullivan 2009
@@ -39,7 +39,15 @@ import System.IO (Handle, hPutChar, stdin, stdout)
3939import qualified Data.ByteString as B
4040import Data.Text.Encoding (decodeUtf8, encodeUtf8)
4141#else
42+import Data.IORef (readIORef, writeIORef)
43+import Data.Text.Fusion (stream)
44+import Data.Text.Fusion.Internal (Step(..), Stream(..))
45+import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,
46+ RawCharBuffer, emptyBuffer, newCharBuffer, writeCharBuf)
4247import GHC.IO.Handle.Internals (wantWritableHandle)
48+import GHC.IO.Handle.Text (commitBuffer')
49+import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..),
50+ Newline(..))
4351#endif
4452
4553-- | The 'readFile' function reads a file and returns the contents of
@@ -90,7 +98,78 @@ hPutStr :: Handle -> Text -> IO ()
9098#if __GLASGOW_HASKELL__ <= 610
9199hPutStr h = B.hPutStr h . encodeUtf8
92100#else
93−hPutStr h t = undefined
101+hPutStr h t = do
102+ (buffer_mode, nl) <-
103+ wantWritableHandle "hPutStr" h $ \h_ -> do
104+ bmode <- getSpareBuffer h_
105+ return (bmode, haOutputNL h_)
106+ let str = stream t
107+ case buffer_mode of
108+ (NoBuffering, _) -> hPutChars h str
109+ (LineBuffering, buf) -> writeBlocks h True nl buf str
110+ (BlockBuffering _, buf) -> writeBlocks h False nl buf str
111+
112+hPutChars :: Handle -> Stream Char -> IO ()
113+hPutChars h (Stream next0 s0 _len) = loop s0
114+ where
115+ loop !s = case next0 s of
116+ Done -> return ()
117+ Skip s' -> loop s'
118+ Yield x s' -> hPutChar h x >> loop s'
119+
120+-- This function is largely lifted from GHC.IO.Handle.Text, but
121+-- adapted to a coinductive stream of data instead of an inductive
122+-- list.
123+writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> Stream Char
124+ -> IO ()
125+writeBlocks h lineBuffered nl buf0 (Stream next0 s0 _len) = outer s0 buf0
126+ where
127+ outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
128+ where
129+ inner !s !n =
130+ case next0 s of
131+ Done -> commit n False{-no flush-} True{-release-} >> return ()
132+ Skip s' -> inner s' n
133+ Yield x s'
134+ | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s
135+ | x == '\n' -> do
136+ n' <- if nl == CRLF
137+ then do n1 <- writeCharBuf raw n '\r'
138+ writeCharBuf raw n1 '\n'
139+ else writeCharBuf raw n x
140+ if lineBuffered
141+ then commit n' True{-needs flush-} False >>= outer s'
142+ else inner s' n'
143+ | otherwise -> writeCharBuf raw n x >>= inner s'
144+ commit = commitBuffer h raw len
145+
146+-- This function is completely lifted from GHC.IO.Handle.Text.
147+getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
148+getSpareBuffer Handle__{haCharBuffer=ref,
149+ haBuffers=spare_ref,
150+ haBufferMode=mode}
151+ = do
152+ case mode of
153+ NoBuffering -> return (mode, error "no buffer!")
154+ _ -> do
155+ bufs <- readIORef spare_ref
156+ buf <- readIORef ref
157+ case bufs of
158+ BufferListCons b rest -> do
159+ writeIORef spare_ref rest
160+ return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
161+ BufferListNil -> do
162+ new_buf <- newCharBuffer (bufSize buf) WriteBuffer
163+ return (mode, new_buf)
164+
165+
166+-- This function is completely lifted from GHC.IO.Handle.Text.
167+commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool
168+ -> IO CharBuffer
169+commitBuffer hdl !raw !sz !count flush release =
170+ wantWritableHandle "commitAndReleaseBuffer" hdl $
171+ commitBuffer' raw sz count flush release
172+{-# NOINLINE commitBuffer #-}
94173#endif
95174
96175-- | Write a string to a handle, followed by a newline.
@@ -98,7 +177,7 @@ hPutStrLn :: Handle -> Text -> IO ()
98177#if __GLASGOW_HASKELL__ <= 610
99178hPutStrLn h t = B.hPutStrLn h (encodeUtf8 t) >> hPutChar h '\n'
100179#else
101−hPutStrLn h t = undefined
180+hPutStrLn h t = hPutStr h t >> hPutChar h '\n'
102181#endif
103182
104183-- | The 'interact' function takes a function of type @Text -> Text@