{-# LANGUAGE ScopedTypeVariables #-}
module What4.Utils.HandleReader where
import Control.Monad (unless)
import Data.IORef
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.IO as Text
import Control.Exception(bracket,catch,IOException)
import Control.Concurrent(ThreadId,forkIO,killThread)
import Control.Concurrent.Chan(Chan,newChan,readChan,writeChan)
import System.IO(Handle,hClose)
import System.IO.Streams( OutputStream, InputStream )
import qualified System.IO.Streams as Streams
teeInputStream :: InputStream a -> OutputStream a -> IO (InputStream a)
teeInputStream :: forall a. InputStream a -> OutputStream a -> IO (InputStream a)
teeInputStream InputStream a
i OutputStream a
o = forall a. IO (Maybe a) -> IO (InputStream a)
Streams.makeInputStream IO (Maybe a)
go
where
go :: IO (Maybe a)
go = do Maybe a
x <- forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream a
i
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write Maybe a
x OutputStream a
o
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe a
x
teeOutputStream :: OutputStream a -> OutputStream a -> IO (OutputStream a)
teeOutputStream :: forall a. OutputStream a -> OutputStream a -> IO (OutputStream a)
teeOutputStream OutputStream a
o OutputStream a
aux = forall a. (Maybe a -> IO ()) -> IO (OutputStream a)
Streams.makeOutputStream Maybe a -> IO ()
go
where
go :: Maybe a -> IO ()
go Maybe a
x =
do forall a. Maybe a -> OutputStream a -> IO ()
Streams.write Maybe a
x OutputStream a
aux
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write Maybe a
x OutputStream a
o
lineBufferedOutputStream :: Text -> OutputStream Text -> IO (OutputStream Text)
lineBufferedOutputStream :: Text -> OutputStream Text -> IO (OutputStream Text)
lineBufferedOutputStream Text
prefix OutputStream Text
out =
do IORef Text
ref <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
forall a. (Maybe a -> IO ()) -> IO (OutputStream a)
Streams.makeOutputStream (IORef Text -> Maybe Text -> IO ()
con IORef Text
ref)
where
newl :: Text
newl = String -> Text
Text.pack String
"\n"
con :: IORef Text -> Maybe Text -> IO ()
con IORef Text
ref Maybe Text
mx =
do Text
start <- forall a. IORef a -> IO a
readIORef IORef Text
ref
case Maybe Text
mx of
Maybe Text
Nothing ->
do forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
start) (forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
start)) OutputStream Text
out)
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write forall a. Maybe a
Nothing OutputStream Text
out
Just Text
x -> IORef Text -> Text -> IO ()
go IORef Text
ref (Text
start forall a. Semigroup a => a -> a -> a
<> Text
x)
go :: IORef Text -> Text -> IO ()
go IORef Text
ref Text
x =
let (Text
ln, Text
x') = (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
x in
if Text -> Bool
Text.null Text
x' then
do forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty) OutputStream Text
out
forall a. IORef a -> a -> IO ()
writeIORef IORef Text
ref Text
x
else
do forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
ln forall a. Semigroup a => a -> a -> a
<> Text
newl)) OutputStream Text
out
IORef Text -> Text -> IO ()
go IORef Text
ref (Int -> Text -> Text
Text.drop Int
1 Text
x')
demuxProcessHandles ::
Handle ->
Handle ->
Handle ->
Maybe (Text, Handle) ->
IO ( OutputStream Text, InputStream Text, HandleReader )
demuxProcessHandles :: Handle
-> Handle
-> Handle
-> Maybe (Text, Handle)
-> IO (OutputStream Text, InputStream Text, HandleReader)
demuxProcessHandles Handle
in_h Handle
out_h Handle
err_h Maybe (Text, Handle)
Nothing =
do OutputStream Text
in_str <- OutputStream ByteString -> IO (OutputStream Text)
Streams.encodeUtf8 forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO (OutputStream ByteString)
Streams.handleToOutputStream Handle
in_h
InputStream Text
out_str <- InputStream ByteString -> IO (InputStream Text)
Streams.decodeUtf8 forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO (InputStream ByteString)
Streams.handleToInputStream Handle
out_h
HandleReader
err_reader <- Handle -> Maybe (OutputStream Text) -> IO HandleReader
startHandleReader Handle
err_h forall a. Maybe a
Nothing
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OutputStream Text
in_str, InputStream Text
out_str, HandleReader
err_reader)
demuxProcessHandles Handle
in_h Handle
out_h Handle
err_h (Just (Text
comment_prefix, Handle
aux_h)) =
do OutputStream Text
aux_str <- forall a. OutputStream a -> IO (OutputStream a)
Streams.lockingOutputStream forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< OutputStream ByteString -> IO (OutputStream Text)
Streams.encodeUtf8 forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO (OutputStream ByteString)
Streams.handleToOutputStream Handle
aux_h
OutputStream Text
in_str <- OutputStream ByteString -> IO (OutputStream Text)
Streams.encodeUtf8 forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO (OutputStream ByteString)
Streams.handleToOutputStream Handle
in_h
InputStream Text
out_str <- InputStream ByteString -> IO (InputStream Text)
Streams.decodeUtf8 forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO (InputStream ByteString)
Streams.handleToInputStream Handle
out_h
OutputStream Text
in_aux <- Text -> OutputStream Text -> IO (OutputStream Text)
lineBufferedOutputStream forall a. Monoid a => a
mempty OutputStream Text
aux_str
OutputStream Text
in_str' <- forall a. OutputStream a -> OutputStream a -> IO (OutputStream a)
teeOutputStream OutputStream Text
in_str OutputStream Text
in_aux
OutputStream Text
out_aux <- Text -> OutputStream Text -> IO (OutputStream Text)
lineBufferedOutputStream Text
comment_prefix OutputStream Text
aux_str
InputStream Text
out_str' <- forall a. InputStream a -> OutputStream a -> IO (InputStream a)
teeInputStream InputStream Text
out_str OutputStream Text
out_aux
HandleReader
err_reader <- Handle -> Maybe (OutputStream Text) -> IO HandleReader
startHandleReader Handle
err_h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> OutputStream Text -> IO (OutputStream Text)
lineBufferedOutputStream Text
comment_prefix OutputStream Text
aux_str
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OutputStream Text
in_str', InputStream Text
out_str', HandleReader
err_reader)
data HandleReader = HandleReader { HandleReader -> Chan (Maybe Text)
hrChan :: !(Chan (Maybe Text))
, HandleReader -> Handle
hrHandle :: !Handle
, HandleReader -> ThreadId
hrThreadId :: !ThreadId
}
streamLines :: Chan (Maybe Text) -> Handle -> Maybe (OutputStream Text) -> IO ()
streamLines :: Chan (Maybe Text) -> Handle -> Maybe (OutputStream Text) -> IO ()
streamLines Chan (Maybe Text)
c Handle
h Maybe (OutputStream Text)
Nothing = forall {b}. IO b
go
where
go :: IO b
go = do Text
ln <- Handle -> IO Text
Text.hGetLine Handle
h
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe Text)
c (forall a. a -> Maybe a
Just Text
ln)
IO b
go
streamLines Chan (Maybe Text)
c Handle
h (Just OutputStream Text
auxstr) = forall {b}. IO b
go
where
go :: IO b
go = do Text
ln <- Handle -> IO Text
Text.hGetLine Handle
h
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Text
ln) OutputStream Text
auxstr
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe Text)
c (forall a. a -> Maybe a
Just Text
ln)
IO b
go
startHandleReader :: Handle -> Maybe (OutputStream Text) -> IO HandleReader
startHandleReader :: Handle -> Maybe (OutputStream Text) -> IO HandleReader
startHandleReader Handle
h Maybe (OutputStream Text)
auxOutput = do
Chan (Maybe Text)
c <- forall a. IO (Chan a)
newChan
let handle_err :: IOException -> IO ()
handle_err (IOException
_e :: IOException) = forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe Text)
c forall a. Maybe a
Nothing
ThreadId
tid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Chan (Maybe Text) -> Handle -> Maybe (OutputStream Text) -> IO ()
streamLines Chan (Maybe Text)
c Handle
h Maybe (OutputStream Text)
auxOutput forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO ()
handle_err
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! HandleReader { hrChan :: Chan (Maybe Text)
hrChan = Chan (Maybe Text)
c
, hrHandle :: Handle
hrHandle = Handle
h
, hrThreadId :: ThreadId
hrThreadId = ThreadId
tid
}
stopHandleReader :: HandleReader -> IO ()
stopHandleReader :: HandleReader -> IO ()
stopHandleReader HandleReader
hr = do
ThreadId -> IO ()
killThread (HandleReader -> ThreadId
hrThreadId HandleReader
hr)
Handle -> IO ()
hClose (HandleReader -> Handle
hrHandle HandleReader
hr)
withHandleReader :: Handle -> Maybe (OutputStream Text) -> (HandleReader -> IO a) -> IO a
withHandleReader :: forall a.
Handle
-> Maybe (OutputStream Text) -> (HandleReader -> IO a) -> IO a
withHandleReader Handle
h Maybe (OutputStream Text)
auxOut = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Handle -> Maybe (OutputStream Text) -> IO HandleReader
startHandleReader Handle
h Maybe (OutputStream Text)
auxOut) HandleReader -> IO ()
stopHandleReader
readNextLine :: HandleReader -> IO (Maybe Text)
readNextLine :: HandleReader -> IO (Maybe Text)
readNextLine HandleReader
hr = do
Maybe Text
mr <- forall a. Chan a -> IO a
readChan (HandleReader -> Chan (Maybe Text)
hrChan HandleReader
hr)
case Maybe Text
mr of
Maybe Text
Nothing -> forall a. Chan a -> a -> IO ()
writeChan (HandleReader -> Chan (Maybe Text)
hrChan HandleReader
hr) forall a. Maybe a
Nothing
Just{} -> forall (m :: Type -> Type) a. Monad m => a -> m a
return()
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Text
mr
readAllLines :: HandleReader -> IO LazyText.Text
readAllLines :: HandleReader -> IO Text
readAllLines HandleReader
hr = Text -> IO Text
go Text
LazyText.empty
where go :: LazyText.Text -> IO LazyText.Text
go :: Text -> IO Text
go Text
prev = do
Maybe Text
mr <- HandleReader -> IO (Maybe Text)
readNextLine HandleReader
hr
case Maybe Text
mr of
Maybe Text
Nothing -> forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
prev
Just Text
e -> Text -> IO Text
go forall a b. (a -> b) -> a -> b
$! Text
prev Text -> Text -> Text
`LazyText.append` (Text -> Text
LazyText.fromStrict Text
e)
Text -> Char -> Text
`LazyText.snoc` Char
'\n'