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