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