{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Schedule.Concurrently where
import Control.Concurrent
import Control.Monad (void)
import Data.IORef
import Control.Monad.Trans.Class
import Control.Monad.Trans.MSF.Except
import Control.Monad.Trans.MSF.Maybe
import Control.Monad.Trans.MSF.Writer
import FRP.Rhine.Clock
import FRP.Rhine.Schedule
concurrently ::
( Clock IO cl1
, Clock IO cl2
, Time cl1 ~ Time cl2
) =>
Schedule IO cl1 cl2
concurrently :: forall cl1 cl2.
(Clock IO cl1, Clock IO cl2, Time cl1 ~ Time cl2) =>
Schedule IO cl1 cl2
concurrently = forall (m :: Type -> Type) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 -> do
MVar (Time cl2)
iMVar <- forall a. IO (MVar a)
newEmptyMVar
MVar (Time cl2, Either (Tag cl1) (Tag cl2))
mvar <- forall a. IO (MVar a)
newEmptyMVar
ThreadId
_ <- forall {cl} {c}.
Clock IO cl =>
cl
-> (Tag cl -> c)
-> MVar (Time cl)
-> MVar (Time cl, c)
-> IO ThreadId
launchSubthread cl1
cl1 forall a b. a -> Either a b
Left MVar (Time cl2)
iMVar MVar (Time cl2, Either (Tag cl1) (Tag cl2))
mvar
ThreadId
_ <- forall {cl} {c}.
Clock IO cl =>
cl
-> (Tag cl -> c)
-> MVar (Time cl)
-> MVar (Time cl, c)
-> IO ThreadId
launchSubthread cl2
cl2 forall a b. b -> Either a b
Right MVar (Time cl2)
iMVar MVar (Time cl2, Either (Tag cl1) (Tag cl2))
mvar
Time cl2
initTime <- forall a. MVar a -> IO a
takeMVar MVar (Time cl2)
iMVar
Time cl2
_ <- forall a. MVar a -> IO a
takeMVar MVar (Time cl2)
iMVar
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Time cl2, Either (Tag cl1) (Tag cl2))
mvar, Time cl2
initTime)
where
launchSubthread :: cl
-> (Tag cl -> c)
-> MVar (Time cl)
-> MVar (Time cl, c)
-> IO ThreadId
launchSubthread cl
cl Tag cl -> c
leftright MVar (Time cl)
iMVar MVar (Time cl, c)
mvar = IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
(MSF IO () (Time cl, Tag cl)
runningClock, Time cl
initTime) <- forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
cl
forall a. MVar a -> a -> IO ()
putMVar MVar (Time cl)
iMVar Time cl
initTime
forall (m :: Type -> Type). Monad m => MSF m () () -> m ()
reactimate forall a b. (a -> b) -> a -> b
$ MSF IO () (Time cl, Tag cl)
runningClock forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr Tag cl -> c
leftright) forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM (forall a. MVar a -> a -> IO ()
putMVar MVar (Time cl, c)
mvar)
concurrentlyWriter ::
( Monoid w
, Clock (WriterT w IO) cl1
, Clock (WriterT w IO) cl2
, Time cl1 ~ Time cl2
) =>
Schedule (WriterT w IO) cl1 cl2
concurrentlyWriter :: forall w cl1 cl2.
(Monoid w, Clock (WriterT w IO) cl1, Clock (WriterT w IO) cl2,
Time cl1 ~ Time cl2) =>
Schedule (WriterT w IO) cl1 cl2
concurrentlyWriter = forall (m :: Type -> Type) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 -> do
MVar (Time cl2, w)
iMVar <- forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. IO (MVar a)
newEmptyMVar
MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
mvar <- forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. IO (MVar a)
newEmptyMVar
ThreadId
_ <- forall {t :: (Type -> Type) -> Type -> Type} {b} {cl} {b}.
(MonadTrans t, Clock (WriterT b IO) cl) =>
cl
-> (Tag cl -> b)
-> MVar (Time cl, b)
-> MVar ((Time cl, b), b)
-> t IO ThreadId
launchSubthread cl1
cl1 forall a b. a -> Either a b
Left MVar (Time cl2, w)
iMVar MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
mvar
ThreadId
_ <- forall {t :: (Type -> Type) -> Type -> Type} {b} {cl} {b}.
(MonadTrans t, Clock (WriterT b IO) cl) =>
cl
-> (Tag cl -> b)
-> MVar (Time cl, b)
-> MVar ((Time cl, b), b)
-> t IO ThreadId
launchSubthread cl2
cl2 forall a b. b -> Either a b
Right MVar (Time cl2, w)
iMVar MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
mvar
(Time cl2
initTime, w
w1) <- forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Time cl2, w)
iMVar
(Time cl2
_, w
w2) <- forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Time cl2, w)
iMVar
forall (m :: Type -> Type) w. Monad m => w -> WriterT w m ()
tell w
w1
forall (m :: Type -> Type) w. Monad m => w -> WriterT w m ()
tell w
w2
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM (forall w (m :: Type -> Type) a. m (a, w) -> WriterT w m a
WriterT forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
mvar), Time cl2
initTime)
where
launchSubthread :: cl
-> (Tag cl -> b)
-> MVar (Time cl, b)
-> MVar ((Time cl, b), b)
-> t IO ThreadId
launchSubthread cl
cl Tag cl -> b
leftright MVar (Time cl, b)
iMVar MVar ((Time cl, b), b)
mvar = forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
((MSF (WriterT b IO) () (Time cl, Tag cl)
runningClock, Time cl
initTime), b
w) <- forall w (m :: Type -> Type) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
cl
forall a. MVar a -> a -> IO ()
putMVar MVar (Time cl, b)
iMVar (Time cl
initTime, b
w)
forall (m :: Type -> Type). Monad m => MSF m () () -> m ()
reactimate forall a b. (a -> b) -> a -> b
$
forall (m :: Type -> Type) s a b.
(Functor m, Monad m) =>
MSF (WriterT s m) a b -> MSF m a (s, b)
runWriterS MSF (WriterT b IO) () (Time cl, Tag cl)
runningClock forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> proc (b
w', (Time cl
time, Tag cl
tag_)) ->
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM (forall a. MVar a -> a -> IO ()
putMVar MVar ((Time cl, b), b)
mvar) -< ((Time cl
time, Tag cl -> b
leftright Tag cl
tag_), b
w')
concurrentlyExcept ::
( Clock (ExceptT e IO) cl1
, Clock (ExceptT e IO) cl2
, Time cl1 ~ Time cl2
) =>
Schedule (ExceptT e IO) cl1 cl2
concurrentlyExcept :: forall e cl1 cl2.
(Clock (ExceptT e IO) cl1, Clock (ExceptT e IO) cl2,
Time cl1 ~ Time cl2) =>
Schedule (ExceptT e IO) cl1 cl2
concurrentlyExcept = forall (m :: Type -> Type) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 -> do
(MVar (Either e (Time cl2))
iMVar, MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
mvar, IORef (Maybe e)
errorref) <- forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
MVar (Either e (Time cl2))
iMVar <- forall a. IO (MVar a)
newEmptyMVar
MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
mvar <- forall a. IO (MVar a)
newEmptyMVar
IORef (Maybe e)
errorref <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
ThreadId
_ <- forall {a} {cl} {b}.
Clock (ExceptT a IO) cl =>
cl
-> (Tag cl -> b)
-> MVar (Either a (Time cl))
-> MVar (Either a (Time cl, b))
-> IORef (Maybe a)
-> IO ThreadId
launchSubThread cl1
cl1 forall a b. a -> Either a b
Left MVar (Either e (Time cl2))
iMVar MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
mvar IORef (Maybe e)
errorref
ThreadId
_ <- forall {a} {cl} {b}.
Clock (ExceptT a IO) cl =>
cl
-> (Tag cl -> b)
-> MVar (Either a (Time cl))
-> MVar (Either a (Time cl, b))
-> IORef (Maybe a)
-> IO ThreadId
launchSubThread cl2
cl2 forall a b. b -> Either a b
Right MVar (Either e (Time cl2))
iMVar MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
mvar IORef (Maybe e)
errorref
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MVar (Either e (Time cl2))
iMVar, MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
mvar, IORef (Maybe e)
errorref)
forall {e'} {b} {a}.
MVar (Either e' b) -> ExceptT e' IO a -> ExceptT e' IO a
catchAndDrain MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
mvar forall a b. (a -> b) -> a -> b
$ do
Time cl2
initTime <- forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Either e (Time cl2))
iMVar
Time cl2
_ <- forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Either e (Time cl2))
iMVar
let runningSchedule :: MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2))
runningSchedule = forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM forall a b. (a -> b) -> a -> b
$ do
Either e (Time cl2, Either (Tag cl1) (Tag cl2))
eTick <- forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
mvar
case Either e (Time cl2, Either (Tag cl1) (Tag cl2))
eTick of
Right (Time cl2, Either (Tag cl1) (Tag cl2))
tick -> forall (m :: Type -> Type) a. Monad m => a -> m a
return (Time cl2, Either (Tag cl1) (Tag cl2))
tick
Left e
e -> do
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe e)
errorref forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just e
e
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE e
e
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2))
runningSchedule, Time cl2
initTime)
where
launchSubThread :: cl
-> (Tag cl -> b)
-> MVar (Either a (Time cl))
-> MVar (Either a (Time cl, b))
-> IORef (Maybe a)
-> IO ThreadId
launchSubThread cl
cl Tag cl -> b
leftright MVar (Either a (Time cl))
iMVar MVar (Either a (Time cl, b))
mvar IORef (Maybe a)
errorref = IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
Either a (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl)
initialised <- forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
cl
case Either a (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl)
initialised of
Right (MSF (ExceptT a IO) () (Time cl, Tag cl)
runningClock, Time cl
initTime) -> do
forall a. MVar a -> a -> IO ()
putMVar MVar (Either a (Time cl))
iMVar forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Time cl
initTime
Left a
e <-
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
forall (m :: Type -> Type). Monad m => MSF m () () -> m ()
reactimate forall a b. (a -> b) -> a -> b
$
MSF (ExceptT a IO) () (Time cl, Tag cl)
runningClock forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> proc (Time cl
td, Tag cl
tag2) -> do
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM (forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> a -> IO ()
putMVar MVar (Either a (Time cl, b))
mvar) -< forall a b. b -> Either a b
Right (Time cl
td, Tag cl -> b
leftright Tag cl
tag2)
Maybe a
me <- forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM (forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Maybe a)
errorref) -< ()
Maybe Any
_ <- forall (m :: Type -> Type) e a.
Monad m =>
MSF (ExceptT e m) (Maybe e) (Maybe a)
throwMaybe -< Maybe a
me
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either a (Time cl, b))
mvar forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left a
e
Left a
e -> forall (f :: Type -> Type) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar (Either a (Time cl))
iMVar forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left a
e
catchAndDrain :: MVar (Either e' b) -> ExceptT e' IO a -> ExceptT e' IO a
catchAndDrain MVar (Either e' b)
mvar ExceptT e' IO a
initScheduleAction = forall (m :: Type -> Type) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE ExceptT e' IO a
initScheduleAction forall a b. (a -> b) -> a -> b
$ \e'
e -> do
()
_ <- forall (m :: Type -> Type). Monad m => MSF m () () -> m ()
reactimate forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM (forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar (Either e' b)
mvar) forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (forall a b. a -> b -> a
const ())
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE e'
e
concurrentlyMaybe ::
( Clock (MaybeT IO) cl1
, Clock (MaybeT IO) cl2
, Time cl1 ~ Time cl2
) =>
Schedule (MaybeT IO) cl1 cl2
concurrentlyMaybe :: forall cl1 cl2.
(Clock (MaybeT IO) cl1, Clock (MaybeT IO) cl2,
Time cl1 ~ Time cl2) =>
Schedule (MaybeT IO) cl1 cl2
concurrentlyMaybe = forall (m :: Type -> Type) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 ->
forall (m :: Type -> Type) cl1 cl2.
Schedule m cl1 cl2
-> cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule
(forall (m1 :: Type -> Type) (m2 :: Type -> Type) cl1 cl2.
(Monad m1, Monad m2) =>
(forall a. m1 a -> m2 a)
-> Schedule m1 cl1 cl2 -> Schedule m2 cl1 cl2
hoistSchedule forall a. ExceptT () IO a -> MaybeT IO a
exceptTIOToMaybeTIO forall e cl1 cl2.
(Clock (ExceptT e IO) cl1, Clock (ExceptT e IO) cl2,
Time cl1 ~ Time cl2) =>
Schedule (ExceptT e IO) cl1 cl2
concurrentlyExcept)
(forall (m1 :: Type -> Type) (m2 :: Type -> Type) cl.
cl -> (forall a. m1 a -> m2 a) -> HoistClock m1 m2 cl
HoistClock cl1
cl1 forall a. MaybeT IO a -> ExceptT () IO a
maybeTIOToExceptTIO)
(forall (m1 :: Type -> Type) (m2 :: Type -> Type) cl.
cl -> (forall a. m1 a -> m2 a) -> HoistClock m1 m2 cl
HoistClock cl2
cl2 forall a. MaybeT IO a -> ExceptT () IO a
maybeTIOToExceptTIO)
where
exceptTIOToMaybeTIO :: ExceptT () IO a -> MaybeT IO a
exceptTIOToMaybeTIO :: forall a. ExceptT () IO a -> MaybeT IO a
exceptTIOToMaybeTIO = forall (m :: Type -> Type) e a.
Functor m =>
ExceptT e m a -> MaybeT m a
exceptToMaybeT
maybeTIOToExceptTIO :: MaybeT IO a -> ExceptT () IO a
maybeTIOToExceptTIO :: forall a. MaybeT IO a -> ExceptT () IO a
maybeTIOToExceptTIO = forall (m :: Type -> Type) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT ()