-- | Lifted concurrency operators and a some useful concurrency abstractions
module GF.Infra.Concurrency(
    module GF.Infra.Concurrency,
    C.forkIO,
    C.MVar,C.modifyMVar,C.modifyMVar_,
    C.Chan
 ) where
import qualified Control.Concurrent as C
import System.IO.Unsafe(unsafeInterleaveIO)
import Control.Monad((<=<))
import Control.Monad.Trans(MonadIO(..))

-- * Futures

newtype Future a = Future {Future a -> IO a
now::IO a}

spawn :: IO a -> IO (Future a)
spawn IO a
io = do MVar a
v <- IO (MVar a)
forall (io :: * -> *) a. MonadIO io => io (MVar a)
newEmptyMVar
              IO () -> IO ThreadId
C.forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar a
v (a -> IO ()) -> IO a -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
io
              Future a -> IO (Future a)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO a -> Future a
forall a. IO a -> Future a
Future (MVar a -> IO a
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar a
v))

parMapM :: (a -> IO b) -> t a -> IO (t b)
parMapM a -> IO b
f = (Future b -> IO b) -> t (Future b) -> IO (t b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Future b -> IO b
forall a. Future a -> IO a
now (t (Future b) -> IO (t b))
-> (t a -> IO (t (Future b))) -> t a -> IO (t b)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (a -> IO (Future b)) -> t a -> IO (t (Future b))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO b -> IO (Future b)
forall a. IO a -> IO (Future a)
spawn (IO b -> IO (Future b)) -> (a -> IO b) -> a -> IO (Future b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
f)

-- * Single-threaded logging

newLog :: (a -> IO b) -> m (a -> m ())
newLog a -> IO b
put =
  do Chan a
logchan <- m (Chan a)
forall (io :: * -> *) a. MonadIO io => io (Chan a)
newChan
     IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
C.forkIO ((a -> IO b) -> [a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> IO b
put ([a] -> IO ()) -> IO [a] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Chan a -> IO [a]
forall (m :: * -> *) a. MonadIO m => Chan a -> m [a]
getChanContents Chan a
logchan)
     (a -> m ()) -> m (a -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Chan a -> a -> m ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan Chan a
logchan)

-- * Lifted concurrency operators

newMVar :: a -> m (MVar a)
newMVar a
x = IO (MVar a) -> m (MVar a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar a) -> m (MVar a)) -> IO (MVar a) -> m (MVar a)
forall a b. (a -> b) -> a -> b
$ a -> IO (MVar a)
forall a. a -> IO (MVar a)
C.newMVar a
x
readMVar :: MVar a -> m a
readMVar MVar a
v = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ MVar a -> IO a
forall a. MVar a -> IO a
C.readMVar MVar a
v
putMVar :: MVar a -> a -> m ()
putMVar MVar a
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
C.putMVar MVar a
v

newEmptyMVar :: MonadIO io => io (C.MVar a)
newEmptyMVar :: io (MVar a)
newEmptyMVar = IO (MVar a) -> io (MVar a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar a)
forall a. IO (MVar a)
C.newEmptyMVar

newChan :: MonadIO io => io (C.Chan a)
newChan :: io (Chan a)
newChan = IO (Chan a) -> io (Chan a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Chan a)
forall a. IO (Chan a)
C.newChan

getChanContents :: Chan a -> m [a]
getChanContents Chan a
ch = IO [a] -> m [a]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [a] -> m [a]) -> IO [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ Chan a -> IO [a]
forall a. Chan a -> IO [a]
C.getChanContents Chan a
ch
writeChan :: Chan a -> a -> m ()
writeChan Chan a
ch = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chan a -> a -> IO ()
forall a. Chan a -> a -> IO ()
C.writeChan Chan a
ch


-- * Delayed IO

lazyIO :: IO a -> IO a
lazyIO = IO a -> IO a
forall a. IO a -> IO a
unsafeInterleaveIO