@@ -1,4 +1,4 @@
1−{-# LANGUAGE BangPatterns, CPP #-}
1+{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}
22-- |
33-- Module : Data.Text.IO
44-- Copyright : (c) Bryan O'Sullivan 2009,
@@ -31,6 +31,7 @@ module Data.Text.IO
3131 , putStrLn
3232 ) where
3333
34+import Debug.Trace
3435import Data.Text (Text)
3536import Prelude hiding (appendFile, getContents, getLine, interact, putStr,
3637 putStrLn, readFile, writeFile)
@@ -40,15 +41,22 @@ import qualified Data.ByteString as B
4041import Data.Text.Encoding (decodeUtf8, encodeUtf8)
4142#else
4243import Data.IORef (readIORef, writeIORef)
43−import Data.Text.Fusion (stream)
44+import qualified Data.Text as T
45+import Data.Text.Fusion (stream, unstream)
4446import Data.Text.Fusion.Internal (Step(..), Stream(..))
47+import Data.Text.Fusion.Size (exactSize, maxSize)
48+import Data.Text.Unsafe (inlinePerformIO)
49+import Foreign.Storable (peekElemOff)
4550import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,
46− RawCharBuffer, emptyBuffer, newCharBuffer, writeCharBuf)
47−import GHC.IO.Handle.Internals (wantWritableHandle)
51+ RawCharBuffer, bufferAdjustL, bufferElems, charSize, emptyBuffer, isEmptyBuffer, newCharBuffer, readCharBuf, withRawBuffer,
52+ writeCharBuf)
53+import GHC.IO.Handle.Internals (ioe_EOF, readTextDevice, wantReadableHandle_,
54+ wantWritableHandle)
4855import GHC.IO.Handle.Text (commitBuffer')
4956import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..),
5057 Newline(..))
5158import System.IO (IOMode(..), openFile, withFile)
59+import System.IO.Error (isEOFError)
5260#endif
5361
5462-- | The 'readFile' function reads a file and returns the contents of
@@ -79,7 +87,119 @@ hGetLine :: Handle -> IO Text
7987#if __GLASGOW_HASKELL__ <= 610
8088hGetLine = fmap decodeUtf8 . B.hGetLine
8189#else
82−hGetLine = undefined
90+hGetLine h = wantReadableHandle_ "hGetLine" h go
91+ where go hh@Handle__{..} = readIORef haCharBuffer >>= hGetLineLoop hh []
92+
93+hGetLineLoop :: Handle__ -> [Text] -> CharBuffer -> IO Text
94+hGetLineLoop hh@Handle__{..} ts buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } = do
95+ let findEOL raw r
96+ | r == w = return (False, w)
97+ | otherwise = do
98+ (c,r') <- readCharBuf raw r
99+ if c == '\n'
100+ then return (True, r)
101+ else findEOL raw r'
102+ (eol, off) <- findEOL raw0 r0
103+ (t,r') <- if haInputNL == CRLF
104+ then unpack_nl raw0 r0 off
105+ else do t <- unpack raw0 r0 off
106+ return (t,off)
107+ if eol
108+ then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
109+ return $! T.concat (reverse (t:ts))
110+ else do
111+ let buf1 = bufferAdjustL r' buf
112+ maybe_buf <- maybeFillReadBuffer hh buf1
113+ case maybe_buf of
114+ -- Nothing indicates we caught an EOF, and we may have a
115+ -- partial line to return.
116+ Nothing -> do
117+ -- we reached EOF. There might be a lone \r left
118+ -- in the buffer, so check for that and
119+ -- append it to the line if necessary.
120+ --
121+ let pre | isEmptyBuffer buf1 = T.empty
122+ | otherwise = T.singleton '\r'
123+ writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
124+ let str = T.concat . reverse $ pre:t:ts
125+ if T.null str
126+ then ioe_EOF
127+ else return str
128+ Just new_buf ->
129+ hGetLineLoop hh (t:ts) new_buf
130+
131+-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
132+maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
133+maybeFillReadBuffer handle_ buf
134+ = catch (Just `fmap` getSomeCharacters handle_ buf) $ \e ->
135+ if isEOFError e
136+ then return Nothing
137+ else ioError e
138+
139+unpack :: RawCharBuffer -> Int -> Int -> IO Text
140+unpack !buf !r !w
141+ | charSize /= 4 = sizeError "unpack"
142+ | r == w = return T.empty
143+ | otherwise = withRawBuffer buf go
144+ where
145+ go pbuf = return $! unstream (Stream next r (exactSize (w-r)))
146+ where
147+ next !i | i >= w = Done
148+ | otherwise = Yield (let c = ix i in trace (show (w,i,c)) c) (i+1)
149+ ix i = inlinePerformIO $ peekElemOff pbuf i
150+
151+unpack_nl :: RawCharBuffer -> Int -> Int -> IO (Text, Int)
152+unpack_nl !buf !r !w
153+ | charSize /= 4 = sizeError "unpack_nl"
154+ | r == w = return (T.empty, 0)
155+ | otherwise = withRawBuffer buf $ go
156+ where
157+ go pbuf = do
158+ let t = unstream (Stream next r (maxSize (w-r)))
159+ w' = w - 1
160+ return $ if ix w' == '\r'
161+ then (t,w')
162+ else (t,w)
163+ where
164+ next !i | i >= w = Done
165+ | c == '\r' = let i' = i + 1
166+ in if i' < w
167+ then if ix i' == '\n'
168+ then Yield '\n' (i+2)
169+ else Yield '\n' i'
170+ else Done
171+ | otherwise = Yield c (i+1)
172+ where c = ix i
173+ ix i = inlinePerformIO $ peekElemOff pbuf i
174+
175+sizeError :: String -> a
176+sizeError loc = error $ "Data.Text.IO." ++ loc ++ ": bad internal buffer size"
177+
178+-- This function is completely lifted from GHC.IO.Handle.Text.
179+getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
180+getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
181+ case bufferElems buf of
182+ -- buffer empty: read some more
183+ 0 -> readTextDevice handle_ buf
184+
185+ -- if the buffer has a single '\r' in it and we're doing newline
186+ -- translation: read some more
187+ 1 | haInputNL == CRLF -> do
188+ (c,_) <- readCharBuf bufRaw bufL
189+ if c == '\r'
190+ then do -- shuffle the '\r' to the beginning. This is only safe
191+ -- if we're about to call readTextDevice, otherwise it
192+ -- would mess up flushCharBuffer.
193+ -- See [note Buffer Flushing], GHC.IO.Handle.Types
194+ _ <- writeCharBuf bufRaw 0 '\r'
195+ let buf' = buf{ bufL=0, bufR=1 }
196+ readTextDevice handle_ buf'
197+ else do
198+ return buf
199+
200+ -- buffer has some chars in it already: just return it
201+ _otherwise ->
202+ return buf
83203#endif
84204
85205-- | Write a string to a handle.
@@ -87,6 +207,7 @@ hPutStr :: Handle -> Text -> IO ()
87207#if __GLASGOW_HASKELL__ <= 610
88208hPutStr h = B.hPutStr h . encodeUtf8
89209#else
210+-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
90211hPutStr h t = do
91212 (buffer_mode, nl) <-
92213 wantWritableHandle "hPutStr" h $ \h_ -> do
@@ -193,7 +314,16 @@ putStrLn = hPutStrLn stdout
193314-- Under GHC 6.10 and earlier, the system I\/O libraries do not
194315-- support locale-sensitive I\/O. All data read by functions in this
195316-- module is decoded as UTF-8, and before data is written, it is first
196−-- encoded as UTF-8.
317+-- encoded as UTF-8. If you must use a non-UTF-8 locale on an older
318+-- version of GHC, you will have to perform the transcoding yourself,
319+-- e.g. as follows:
320+--
321+-- > import qualified Data.ByteString as B
322+-- > import Data.Text (Text)
323+-- > import Data.Text.Encoding (encodeUtf16)
324+-- >
325+-- > putStr_Utf16LE :: Text -> IO ()
326+-- > putStr_Utf16LE t = B.putStr (encodeUtf16LE t)
197327--
198328-- Beginning with GHC 6.12, text I\/O is performed using the system or
199329-- handle's current locale.