git.iko.soy/text
on a80bdad help sign in
text/Data/Text/IO/Internal.hs
165 lines 6.2 kB history raw
1{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}
2-- |
3-- Module : Data.Text.IO.Internal
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
5-- (c) 2009 Simon Marlow
6-- License : BSD-style
7-- Maintainer : bos@serpentine.com
8-- Stability : experimental
9-- Portability : GHC
10--
11-- Low-level support for text I\/O.
13module Data.Text.IO.Internal
14 (
15#if __GLASGOW_HASKELL__ >= 612
16 hGetLineWith
17 , readChunk
18#endif
19 ) where
21#if __GLASGOW_HASKELL__ >= 612
22import Data.IORef (readIORef, writeIORef)
23import Data.Text (Text)
24import Data.Text.Fusion (unstream)
25import Data.Text.Fusion.Internal (Step(..), Stream(..))
26import Data.Text.Fusion.Size (exactSize, maxSize)
27import Data.Text.Unsafe (inlinePerformIO)
28import Foreign.Storable (peekElemOff)
29import GHC.IO.Buffer (Buffer(..), CharBuffer, RawCharBuffer, bufferAdjustL,
30 bufferElems, charSize, isEmptyBuffer, readCharBuf,
31 withRawBuffer, writeCharBuf)
32import GHC.IO.Handle.Internals (ioe_EOF, readTextDevice, wantReadableHandle_)
33import GHC.IO.Handle.Types (Handle__(..), Newline(..))
34import System.IO (Handle)
35import System.IO.Error (isEOFError)
36import qualified Data.Text as T
38-- | Read a single line of input from a handle, constructing a list of
39-- decoded chunks as we go. When we're done, transform them into the
40-- destination type.
41hGetLineWith :: ([Text] -> t) -> Handle -> IO t
42hGetLineWith f h = wantReadableHandle_ "hGetLine" h go
43 where
44 go hh@Handle__{..} = readIORef haCharBuffer >>= fmap f . hGetLineLoop hh []
46hGetLineLoop :: Handle__ -> [Text] -> CharBuffer -> IO [Text]
47hGetLineLoop hh@Handle__{..} = go where
48 go ts buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } = do
49 let findEOL raw r | r == w = return (False, w)
50 | otherwise = do
51 (c,r') <- readCharBuf raw r
52 if c == '\n'
53 then return (True, r)
54 else findEOL raw r'
55 (eol, off) <- findEOL raw0 r0
56 (t,r') <- if haInputNL == CRLF
57 then unpack_nl raw0 r0 off
58 else do t <- unpack raw0 r0 off
59 return (t,off)
60 if eol
61 then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
62 return $ reverse (t:ts)
63 else do
64 let buf1 = bufferAdjustL r' buf
65 maybe_buf <- maybeFillReadBuffer hh buf1
66 case maybe_buf of
67 -- Nothing indicates we caught an EOF, and we may have a
68 -- partial line to return.
69 Nothing -> do
70 -- we reached EOF. There might be a lone \r left
71 -- in the buffer, so check for that and
72 -- append it to the line if necessary.
73 let pre | isEmptyBuffer buf1 = T.empty
74 | otherwise = T.singleton '\r'
75 writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
76 let str = reverse . filter (not . T.null) $ pre:t:ts
77 if null str
78 then ioe_EOF
79 else return str
80 Just new_buf -> go (t:ts) new_buf
82-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
83maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
84maybeFillReadBuffer handle_ buf
85 = catch (Just `fmap` getSomeCharacters handle_ buf) $ \e ->
86 if isEOFError e
87 then return Nothing
88 else ioError e
90unpack :: RawCharBuffer -> Int -> Int -> IO Text
91unpack !buf !r !w
92 | charSize /= 4 = sizeError "unpack"
93 | r >= w = return T.empty
94 | otherwise = withRawBuffer buf go
95 where
96 go pbuf = return $! unstream (Stream next r (exactSize (w-r)))
97 where
98 next !i | i >= w = Done
99 | otherwise = Yield (ix i) (i+1)
100 ix i = inlinePerformIO $ peekElemOff pbuf i
102unpack_nl :: RawCharBuffer -> Int -> Int -> IO (Text, Int)
103unpack_nl !buf !r !w
104 | charSize /= 4 = sizeError "unpack_nl"
105 | r >= w = return (T.empty, 0)
106 | otherwise = withRawBuffer buf $ go
107 where
108 go pbuf = do
109 let !t = unstream (Stream next r (maxSize (w-r)))
110 w' = w - 1
111 return $ if ix w' == '\r'
112 then (t,w')
113 else (t,w)
114 where
115 next !i | i >= w = Done
116 | c == '\r' = let i' = i + 1
117 in if i' < w
118 then if ix i' == '\n'
119 then Yield '\n' (i+2)
120 else Yield '\n' i'
121 else Done
122 | otherwise = Yield c (i+1)
123 where c = ix i
124 ix i = inlinePerformIO $ peekElemOff pbuf i
126-- This function is completely lifted from GHC.IO.Handle.Text.
127getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
128getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
129 case bufferElems buf of
130 -- buffer empty: read some more
131 0 -> {-# SCC "readTextDevice" #-} readTextDevice handle_ buf
133 -- if the buffer has a single '\r' in it and we're doing newline
134 -- translation: read some more
135 1 | haInputNL == CRLF -> do
136 (c,_) <- readCharBuf bufRaw bufL
137 if c == '\r'
138 then do -- shuffle the '\r' to the beginning. This is only safe
139 -- if we're about to call readTextDevice, otherwise it
140 -- would mess up flushCharBuffer.
141 -- See [note Buffer Flushing], GHC.IO.Handle.Types
142 _ <- writeCharBuf bufRaw 0 '\r'
143 let buf' = buf{ bufL=0, bufR=1 }
144 readTextDevice handle_ buf'
145 else do
146 return buf
148 -- buffer has some chars in it already: just return it
149 _otherwise -> {-# SCC "otherwise" #-} return buf
151-- | Read a single chunk of strict text from a buffer. Used by both
152-- the strict and lazy implementations of hGetContents.
153readChunk :: Handle__ -> CharBuffer -> IO Text
154readChunk hh@Handle__{..} buf = do
155 buf'@Buffer{..} <- getSomeCharacters hh buf
156 (t,r) <- if haInputNL == CRLF
157 then unpack_nl bufRaw bufL bufR
158 else do t <- unpack bufRaw bufL bufR
159 return (t,bufR)
160 writeIORef haCharBuffer (bufferAdjustL r buf')
161 return t
163sizeError :: String -> a
164sizeError loc = error $ "Data.Text.IO." ++ loc ++ ": bad internal buffer size"
165#endif