{-# LANGUAGE BangPatterns #-}
module System.IO.Streams.List
(
fromList
, toList
, outputToList
, writeList
, chunkList
, concatLists
, listOutputStream
) where
import Control.Concurrent.MVar (modifyMVar, modifyMVar_, newMVar)
import Control.Monad.IO.Class (MonadIO (..))
import Data.IORef (newIORef, readIORef, writeIORef)
import Prelude hiding (read)
import System.IO.Streams.Internal (InputStream, OutputStream, await, connect, fromConsumer, fromGenerator, makeInputStream, read, write, yield)
fromList :: [c] -> IO (InputStream c)
fromList inp = newIORef inp >>= makeInputStream . f
where
f ref = readIORef ref >>= \l ->
case l of
[] -> return Nothing
(x:xs) -> writeIORef ref xs >> return (Just x)
{-# INLINE fromList #-}
listOutputStream :: IO (OutputStream c, IO [c])
listOutputStream = do
r <- newMVar id
c <- fromConsumer $ consumer r
return (c, flush r)
where
consumer r = go
where
go = await >>= (maybe (return $! ()) $ \c -> do
liftIO $ modifyMVar_ r $ \dl -> return (dl . (c:))
go)
flush r = modifyMVar r $ \dl -> return (id, dl [])
{-# INLINE listOutputStream #-}
toList :: InputStream a -> IO [a]
toList is = outputToList (connect is)
{-# INLINE toList #-}
outputToList :: (OutputStream a -> IO b) -> IO [a]
outputToList f = do
(os, getList) <- listOutputStream
_ <- f os
getList
{-# INLINE outputToList #-}
writeList :: [a] -> OutputStream a -> IO ()
writeList xs os = mapM_ (flip write os . Just) xs
{-# INLINE writeList #-}
chunkList :: Int
-> InputStream a
-> IO (InputStream [a])
chunkList n input = if n <= 0
then error $ "chunkList: bad size: " ++ show n
else fromGenerator $ go n id
where
go !k dl | k <= 0 = yield (dl []) >> go n id
| otherwise = do
liftIO (read input) >>= maybe finish chunk
where
finish = let l = dl []
in if null l then return $! () else yield l
chunk x = go (k - 1) (dl . (x:))
concatLists :: InputStream [a] -> IO (InputStream a)
concatLists input = fromGenerator go
where
go = liftIO (read input) >>= maybe (return $! ()) chunk
chunk l = sequence_ (map yield l) >> go