module Data.Text.IO
(
readFile
, writeFile
, appendFile
, hGetContents
, hGetLine
, hPutStr
, hPutStrLn
, interact
, getContents
, getLine
, putStr
, putStrLn
) where
import Data.Text (Text)
import Prelude hiding (appendFile, getContents, getLine, interact, putStr,
putStrLn, readFile, writeFile)
import System.IO (Handle, IOMode(..), hPutChar, openFile, stdin, stdout,
withFile)
#if __GLASGOW_HASKELL__ <= 610
import qualified Data.ByteString.Char8 as B
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
#else
import Control.Exception (throw)
import Data.IORef (readIORef, writeIORef)
import qualified Data.Text as T
import Data.Text.Fusion (stream)
import Data.Text.Fusion.Internal (Step(..), Stream(..))
import Data.Text.IO.Internal (hGetLineWith, readChunk)
import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,
RawCharBuffer, emptyBuffer, isEmptyBuffer, newCharBuffer,
writeCharBuf)
import GHC.IO.Handle.Internals (augmentIOError, hClose_help, wantReadableHandle,
wantWritableHandle)
import GHC.IO.Handle.Text (commitBuffer')
import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..),
Newline(..))
import System.IO.Error (isEOFError)
#endif
readFile :: FilePath -> IO Text
readFile name = openFile name ReadMode >>= hGetContents
writeFile :: FilePath -> Text -> IO ()
writeFile p = withFile p WriteMode . flip hPutStr
appendFile :: FilePath -> Text -> IO ()
appendFile p = withFile p AppendMode . flip hPutStr
hGetContents :: Handle -> IO Text
#if __GLASGOW_HASKELL__ <= 610
hGetContents = fmap decodeUtf8 . B.hGetContents
#else
hGetContents h = wantReadableHandle "hGetContents" h $ \hh -> do
(hh',ts) <- readAll hh
return (hh',T.concat ts)
where
readAll hh@Handle__{..} = do
buf <- readIORef haCharBuffer
let readChunks = do
t <- readChunk hh buf
(hh',ts) <- readAll hh
return (hh', t:ts)
readChunks `catch` \e -> do
(hh', _) <- hClose_help hh
if isEOFError e
then return $ if isEmptyBuffer buf
then (hh', [])
else (hh', [T.singleton '\r'])
else throw (augmentIOError e "hGetContents" h)
#endif
hGetLine :: Handle -> IO Text
#if __GLASGOW_HASKELL__ <= 610
hGetLine = fmap decodeUtf8 . B.hGetLine
#else
hGetLine = hGetLineWith T.concat
#endif
hPutStr :: Handle -> Text -> IO ()
#if __GLASGOW_HASKELL__ <= 610
hPutStr h = B.hPutStr h . encodeUtf8
#else
hPutStr h t = do
(buffer_mode, nl) <-
wantWritableHandle "hPutStr" h $ \h_ -> do
bmode <- getSpareBuffer h_
return (bmode, haOutputNL h_)
let str = stream t
case buffer_mode of
(NoBuffering, _) -> hPutChars h str
(LineBuffering, buf) -> writeBlocks h True nl buf str
(BlockBuffering _, buf) -> writeBlocks h False nl buf str
hPutChars :: Handle -> Stream Char -> IO ()
hPutChars h (Stream next0 s0 _len) = loop s0
where
loop !s = case next0 s of
Done -> return ()
Skip s' -> loop s'
Yield x s' -> hPutChar h x >> loop s'
writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> Stream Char
-> IO ()
writeBlocks h lineBuffered nl buf0 (Stream next0 s0 _len) = outer s0 buf0
where
outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
where
inner !s !n =
case next0 s of
Done -> commit n False True >> return ()
Skip s' -> inner s' n
Yield x s'
| n + 1 >= len -> commit n True False >>= outer s
| x == '\n' -> do
n' <- if nl == CRLF
then do n1 <- writeCharBuf raw n '\r'
writeCharBuf raw n1 '\n'
else writeCharBuf raw n x
if lineBuffered
then commit n' True False >>= outer s'
else inner s' n'
| otherwise -> writeCharBuf raw n x >>= inner s'
commit = commitBuffer h raw len
getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
getSpareBuffer Handle__{haCharBuffer=ref,
haBuffers=spare_ref,
haBufferMode=mode}
= do
case mode of
NoBuffering -> return (mode, error "no buffer!")
_ -> do
bufs <- readIORef spare_ref
buf <- readIORef ref
case bufs of
BufferListCons b rest -> do
writeIORef spare_ref rest
return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
BufferListNil -> do
new_buf <- newCharBuffer (bufSize buf) WriteBuffer
return (mode, new_buf)
commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool
-> IO CharBuffer
commitBuffer hdl !raw !sz !count flush release =
wantWritableHandle "commitAndReleaseBuffer" hdl $
commitBuffer' raw sz count flush release
#endif
hPutStrLn :: Handle -> Text -> IO ()
hPutStrLn h t = hPutStr h t >> hPutChar h '\n'
interact :: (Text -> Text) -> IO ()
interact f = putStr . f =<< getContents
getContents :: IO Text
getContents = hGetContents stdin
getLine :: IO Text
getLine = hGetLine stdin
putStr :: Text -> IO ()
putStr = hPutStr stdout
putStrLn :: Text -> IO ()
putStrLn = hPutStrLn stdout