239c508 · text · git.iko.soy

git.iko.soy/text

on master help sign in

Implement hGetLine.

239c508Bryan O'Sullivan17 years ago

Data/Text/IO.hs+136−6

compare with master

unifiedsplit

@@ -1,4 +1,4 @@

1−{-# LANGUAGE BangPatterns, CPP #-}

1+{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}

2-- |

3-- Module : Data.Text.IO

4-- Copyright : (c) Bryan O'Sullivan 2009,

@@ -31,6 +31,7 @@ module Data.Text.IO

31 , putStrLn

32 ) where

34+import Debug.Trace

34import Data.Text (Text)

35import Data.Text (Text)

35import Prelude hiding (appendFile, getContents, getLine, interact, putStr,

36import Prelude hiding (appendFile, getContents, getLine, interact, putStr,

36 putStrLn, readFile, writeFile)

37 putStrLn, readFile, writeFile)

@@ -40,15 +41,22 @@ import qualified Data.ByteString as B

40import Data.Text.Encoding (decodeUtf8, encodeUtf8)

41import Data.Text.Encoding (decodeUtf8, encodeUtf8)

41#else

42#else

42import Data.IORef (readIORef, writeIORef)

43import Data.IORef (readIORef, writeIORef)

44+import qualified Data.Text as T

43−import Data.Text.Fusion (stream)

45+import Data.Text.Fusion (stream, unstream)

44import Data.Text.Fusion.Internal (Step(..), Stream(..))

46import 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)

45import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,

50import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,

46− RawCharBuffer, emptyBuffer, newCharBuffer, writeCharBuf)

51+ RawCharBuffer, bufferAdjustL, bufferElems, charSize, emptyBuffer, isEmptyBuffer, newCharBuffer, readCharBuf, withRawBuffer,

52+ writeCharBuf)

53+import GHC.IO.Handle.Internals (ioe_EOF, readTextDevice, wantReadableHandle_,

47−import GHC.IO.Handle.Internals (wantWritableHandle)

54+ wantWritableHandle)

48import GHC.IO.Handle.Text (commitBuffer')

55import GHC.IO.Handle.Text (commitBuffer')

49import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..),

56import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..),

50 Newline(..))

57 Newline(..))

51import System.IO (IOMode(..), openFile, withFile)

58import System.IO (IOMode(..), openFile, withFile)

59+import System.IO.Error (isEOFError)

52#endif

60#endif

54-- | The 'readFile' function reads a file and returns the contents of

62-- | The 'readFile' function reads a file and returns the contents of

@@ -79,7 +87,119 @@ hGetLine :: Handle -> IO Text

79#if __GLASGOW_HASKELL__ <= 610

87#if __GLASGOW_HASKELL__ <= 610

80hGetLine = fmap decodeUtf8 . B.hGetLine

88hGetLine = fmap decodeUtf8 . B.hGetLine

81#else

89#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

83#endif

203#endif

204

85-- | Write a string to a handle.

205-- | Write a string to a handle.

@@ -87,6 +207,7 @@ hPutStr :: Handle -> Text -> IO ()

87#if __GLASGOW_HASKELL__ <= 610

207#if __GLASGOW_HASKELL__ <= 610

88hPutStr h = B.hPutStr h . encodeUtf8

208hPutStr h = B.hPutStr h . encodeUtf8

89#else

209#else

210+-- This function is lifted almost verbatim from GHC.IO.Handle.Text.

90hPutStr h t = do

211hPutStr h t = do

91 (buffer_mode, nl) <-

212 (buffer_mode, nl) <-

92 wantWritableHandle "hPutStr" h $ \h_ -> do

213 wantWritableHandle "hPutStr" h $ \h_ -> do

@@ -193,7 +314,16 @@ putStrLn = hPutStrLn stdout

193-- Under GHC 6.10 and earlier, the system I\/O libraries do not

314-- Under GHC 6.10 and earlier, the system I\/O libraries do not

194-- support locale-sensitive I\/O. All data read by functions in this

315-- support locale-sensitive I\/O. All data read by functions in this

195-- module is decoded as UTF-8, and before data is written, it is first

316-- 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)

197--

327--

198-- Beginning with GHC 6.12, text I\/O is performed using the system or

328-- Beginning with GHC 6.12, text I\/O is performed using the system or

199-- handle's current locale.

329-- handle's current locale.

Data/Text/Unsafe.hs+24−1

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}

1-- |

2-- |

2-- Module : Data.Text.Unsafe

3-- Module : Data.Text.Unsafe

3-- Copyright : (c) Bryan O'Sullivan 2009

4-- Copyright : (c) Bryan O'Sullivan 2009

@@ -11,7 +12,8 @@

11-- use in heavily tested code.

12-- use in heavily tested code.

12module Data.Text.Unsafe

13module Data.Text.Unsafe

13 (

14 (

15+ inlinePerformIO

14− iter

16+ , iter

15 , iter_

17 , iter_

16 , reverseIter

18 , reverseIter

17 , unsafeHead

19 , unsafeHead

@@ -23,6 +25,14 @@ import Data.Text.Internal (Text(..))

23import Data.Text.UnsafeChar (unsafeChr)

25import Data.Text.UnsafeChar (unsafeChr)

24import Data.Text.Encoding.Utf16 (chr2)

26import Data.Text.Encoding.Utf16 (chr2)

25import qualified Data.Text.Array as A

27import qualified Data.Text.Array as A

28+#if defined(__GLASGOW_HASKELL__)

29+# if __GLASGOW_HASKELL__ >= 611

30+import GHC.IO (IO(IO))

31+# else

32+import GHC.IOBase (IO(IO))

33+# endif

34+import GHC.Base (realWorld#)

35+#endif

27-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'

37-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'

28-- omits the check for the empty case, so there is an obligation on

38-- omits the check for the empty case, so there is an obligation on

@@ -77,3 +87,16 @@ reverseIter (Text arr off len) i

77 j = assert (i >= 0) $ off + i

87 j = assert (i >= 0) $ off + i

78 k = j - 1

88 k = j - 1

79{-# INLINE reverseIter #-}

89{-# INLINE reverseIter #-}

90+

91+-- | Just like unsafePerformIO, but we inline it. Big performance gains as

92+-- it exposes lots of things to further inlining. /Very unsafe/. In

93+-- particular, you should do no memory allocation inside an

94+-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.

95+--

96+{-# INLINE inlinePerformIO #-}

97+inlinePerformIO :: IO a -> a

98+#if defined(__GLASGOW_HASKELL__)

99+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r

100+#else

101+inlinePerformIO = unsafePerformIO

102+#endif