{- |
Many clocks tick at nondeterministic times
(such as event sources),
and it is thus impossible to schedule them deterministically
with most other clocks.
Using concurrency, they can still be scheduled with all clocks in 'IO',
by running the clocks in separate threads.
-}

{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Schedule.Concurrently where

-- base
import Control.Concurrent
import Control.Monad (void)
import Data.IORef

-- transformers
import Control.Monad.Trans.Class

-- dunai
import Control.Monad.Trans.MSF.Except
import Control.Monad.Trans.MSF.Maybe
import Control.Monad.Trans.MSF.Writer

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Schedule


-- | Runs two clocks in separate GHC threads
--   and collects the results in the foreground thread.
--   Caution: The data processing will still happen in the same thread
--   (since data processing and scheduling are separated concerns).
concurrently
  :: ( Clock IO cl1, Clock IO cl2
     , Time cl1 ~ Time cl2
     )
  => Schedule IO cl1 cl2
concurrently :: Schedule IO cl1 cl2
concurrently = (cl1
 -> cl2
 -> RunningClockInit IO (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule IO cl1 cl2
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 ((cl1
  -> cl2
  -> RunningClockInit IO (Time cl1) (Either (Tag cl1) (Tag cl2)))
 -> Schedule IO cl1 cl2)
-> (cl1
    -> cl2
    -> RunningClockInit IO (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule IO cl1 cl2
forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 -> do
  MVar (Time cl2)
iMVar <- IO (MVar (Time cl2))
forall a. IO (MVar a)
newEmptyMVar
  MVar (Time cl2, Either (Tag cl1) (Tag cl2))
mvar  <- IO (MVar (Time cl2, Either (Tag cl1) (Tag cl2)))
forall a. IO (MVar a)
newEmptyMVar
  ThreadId
_ <- cl1
-> (Tag cl1 -> Either (Tag cl1) (Tag cl2))
-> MVar (Time cl1)
-> MVar (Time cl1, Either (Tag cl1) (Tag cl2))
-> IO ThreadId
forall cl c.
Clock IO cl =>
cl
-> (Tag cl -> c)
-> MVar (Time cl)
-> MVar (Time cl, c)
-> IO ThreadId
launchSubthread cl1
cl1 Tag cl1 -> Either (Tag cl1) (Tag cl2)
forall a b. a -> Either a b
Left  MVar (Time cl1)
MVar (Time cl2)
iMVar MVar (Time cl1, Either (Tag cl1) (Tag cl2))
MVar (Time cl2, Either (Tag cl1) (Tag cl2))
mvar
  ThreadId
_ <- cl2
-> (Tag cl2 -> Either (Tag cl1) (Tag cl2))
-> MVar (Time cl2)
-> MVar (Time cl2, Either (Tag cl1) (Tag cl2))
-> IO ThreadId
forall cl c.
Clock IO cl =>
cl
-> (Tag cl -> c)
-> MVar (Time cl)
-> MVar (Time cl, c)
-> IO ThreadId
launchSubthread cl2
cl2 Tag cl2 -> Either (Tag cl1) (Tag 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 <- MVar (Time cl2) -> IO (Time cl2)
forall a. MVar a -> IO a
takeMVar MVar (Time cl2)
iMVar -- The first clock to be initialised sets the first time stamp
  Time cl2
_        <- MVar (Time cl2) -> IO (Time cl2)
forall a. MVar a -> IO a
takeMVar MVar (Time cl2)
iMVar -- Initialise the second clock
  (MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2)), Time cl2)
-> IO (MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2)), Time cl2)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (IO (Time cl2, Either (Tag cl1) (Tag cl2))
-> MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM (IO (Time cl2, Either (Tag cl1) (Tag cl2))
 -> MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2)))
-> IO (Time cl2, Either (Tag cl1) (Tag cl2))
-> MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2))
forall a b. (a -> b) -> a -> b
$ MVar (Time cl2, Either (Tag cl1) (Tag cl2))
-> IO (Time cl2, Either (Tag cl1) (Tag cl2))
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 (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
      (MSF IO () (Time cl, Tag cl)
runningClock, Time cl
initTime) <- cl -> RunningClockInit IO (Time cl) (Tag cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
cl
      MVar (Time cl) -> Time cl -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Time cl)
iMVar Time cl
initTime
      MSF IO () () -> IO ()
forall (m :: Type -> Type). Monad m => MSF m () () -> m ()
reactimate (MSF IO () () -> IO ()) -> MSF IO () () -> IO ()
forall a b. (a -> b) -> a -> b
$ MSF IO () (Time cl, Tag cl)
runningClock MSF IO () (Time cl, Tag cl)
-> MSF IO (Time cl, Tag cl) () -> MSF IO () ()
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF IO (Tag cl) c -> MSF IO (Time cl, Tag cl) (Time cl, c)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Tag cl -> c) -> MSF IO (Tag cl) c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr Tag cl -> c
leftright) MSF IO (Time cl, Tag cl) (Time cl, c)
-> MSF IO (Time cl, c) () -> MSF IO (Time cl, Tag cl) ()
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Time cl, c) -> IO ()) -> MSF IO (Time cl, c) ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM (MVar (Time cl, c) -> (Time cl, c) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Time cl, c)
mvar)
-- TODO These threads can't be killed from outside easily since we've lost their ids
-- => make a MaybeT or ExceptT variant

-- TODO Test whether signal networks also share the writer and except effects correctly with these schedules

-- | As 'concurrently', but in the @WriterT w IO@ monad.
--   Both background threads share a joint variable with the foreground
--   to which the writer effect writes.
concurrentlyWriter
  :: ( Monoid w
     , Clock (WriterT w IO) cl1
     , Clock (WriterT w IO) cl2
     , Time cl1 ~ Time cl2
     )
  => Schedule (WriterT w IO) cl1 cl2
concurrentlyWriter :: Schedule (WriterT w IO) cl1 cl2
concurrentlyWriter = (cl1
 -> cl2
 -> RunningClockInit
      (WriterT w IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule (WriterT w IO) cl1 cl2
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 ((cl1
  -> cl2
  -> RunningClockInit
       (WriterT w IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
 -> Schedule (WriterT w IO) cl1 cl2)
-> (cl1
    -> cl2
    -> RunningClockInit
         (WriterT w IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule (WriterT w IO) cl1 cl2
forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 -> do
  MVar (Time cl2, w)
iMVar <- IO (MVar (Time cl2, w)) -> WriterT w IO (MVar (Time cl2, w))
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (MVar (Time cl2, w))
forall a. IO (MVar a)
newEmptyMVar
  MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
mvar  <- IO (MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w))
-> WriterT w IO (MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w))
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w))
forall a. IO (MVar a)
newEmptyMVar
  ThreadId
_ <- cl1
-> (Tag cl1 -> Either (Tag cl1) (Tag cl2))
-> MVar (Time cl1, w)
-> MVar ((Time cl1, Either (Tag cl1) (Tag cl2)), w)
-> WriterT w IO 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 Tag cl1 -> Either (Tag cl1) (Tag cl2)
forall a b. a -> Either a b
Left  MVar (Time cl1, w)
MVar (Time cl2, w)
iMVar MVar ((Time cl1, Either (Tag cl1) (Tag cl2)), w)
MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
mvar
  ThreadId
_ <- cl2
-> (Tag cl2 -> Either (Tag cl1) (Tag cl2))
-> MVar (Time cl2, w)
-> MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
-> WriterT w IO 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 Tag cl2 -> Either (Tag cl1) (Tag cl2)
forall a b. b -> Either a b
Right MVar (Time cl2, w)
iMVar MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
mvar
  -- The first clock to be initialised sets the first time stamp
  (Time cl2
initTime, w
w1) <- IO (Time cl2, w) -> WriterT w IO (Time cl2, w)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Time cl2, w) -> WriterT w IO (Time cl2, w))
-> IO (Time cl2, w) -> WriterT w IO (Time cl2, w)
forall a b. (a -> b) -> a -> b
$ MVar (Time cl2, w) -> IO (Time cl2, w)
forall a. MVar a -> IO a
takeMVar MVar (Time cl2, w)
iMVar
   -- Initialise the second clock
  (Time cl2
_       , w
w2) <- IO (Time cl2, w) -> WriterT w IO (Time cl2, w)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Time cl2, w) -> WriterT w IO (Time cl2, w))
-> IO (Time cl2, w) -> WriterT w IO (Time cl2, w)
forall a b. (a -> b) -> a -> b
$ MVar (Time cl2, w) -> IO (Time cl2, w)
forall a. MVar a -> IO a
takeMVar MVar (Time cl2, w)
iMVar
  w -> WriterT w IO ()
forall (m :: Type -> Type) w. Monad m => w -> WriterT w m ()
tell w
w1
  w -> WriterT w IO ()
forall (m :: Type -> Type) w. Monad m => w -> WriterT w m ()
tell w
w2
  (MSF (WriterT w IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
 Time cl2)
-> WriterT
     w
     IO
     (MSF (WriterT w IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (WriterT w IO (Time cl2, Either (Tag cl1) (Tag cl2))
-> MSF (WriterT w IO) () (Time cl2, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM (IO ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
-> WriterT w IO (Time cl2, Either (Tag cl1) (Tag cl2))
forall w (m :: Type -> Type) a. m (a, w) -> WriterT w m a
WriterT (IO ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
 -> WriterT w IO (Time cl2, Either (Tag cl1) (Tag cl2)))
-> IO ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
-> WriterT w IO (Time cl2, Either (Tag cl1) (Tag cl2))
forall a b. (a -> b) -> a -> b
$ MVar ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
-> IO ((Time cl2, Either (Tag cl1) (Tag cl2)), w)
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 = IO ThreadId -> t IO ThreadId
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ThreadId -> t IO ThreadId) -> IO ThreadId -> t IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
      ((MSF (WriterT b IO) () (Time cl, Tag cl)
runningClock, Time cl
initTime), b
w) <- WriterT b IO (MSF (WriterT b IO) () (Time cl, Tag cl), Time cl)
-> IO ((MSF (WriterT b IO) () (Time cl, Tag cl), Time cl), b)
forall w (m :: Type -> Type) a. WriterT w m a -> m (a, w)
runWriterT (WriterT b IO (MSF (WriterT b IO) () (Time cl, Tag cl), Time cl)
 -> IO ((MSF (WriterT b IO) () (Time cl, Tag cl), Time cl), b))
-> WriterT b IO (MSF (WriterT b IO) () (Time cl, Tag cl), Time cl)
-> IO ((MSF (WriterT b IO) () (Time cl, Tag cl), Time cl), b)
forall a b. (a -> b) -> a -> b
$ cl
-> WriterT b IO (MSF (WriterT b IO) () (Time cl, Tag cl), Time cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
cl
      MVar (Time cl, b) -> (Time cl, b) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Time cl, b)
iMVar (Time cl
initTime, b
w)
      MSF IO () () -> IO ()
forall (m :: Type -> Type). Monad m => MSF m () () -> m ()
reactimate (MSF IO () () -> IO ()) -> MSF IO () () -> IO ()
forall a b. (a -> b) -> a -> b
$ MSF (WriterT b IO) () (Time cl, Tag cl)
-> MSF IO () (b, (Time cl, Tag cl))
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 MSF IO () (b, (Time cl, Tag cl))
-> MSF IO (b, (Time cl, Tag cl)) () -> MSF IO () ()
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_)) ->
        (((Time cl, b), b) -> IO ()) -> MSF IO ((Time cl, b), b) ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM (MVar ((Time cl, b), b) -> ((Time cl, b), b) -> IO ()
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')

-- | Schedule in the @ExceptT e IO@ monad.
--   Whenever one clock encounters an exception in 'ExceptT',
--   this exception is thrown in the other clock's 'ExceptT' layer as well,
--   and in the schedule's (i.e. in the main clock's) thread.
concurrentlyExcept
  :: ( Clock (ExceptT e IO) cl1
     , Clock (ExceptT e IO) cl2
     , Time cl1 ~ Time cl2
     )
  => Schedule (ExceptT e IO) cl1 cl2
concurrentlyExcept :: Schedule (ExceptT e IO) cl1 cl2
concurrentlyExcept = (cl1
 -> cl2
 -> RunningClockInit
      (ExceptT e IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule (ExceptT e IO) cl1 cl2
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 ((cl1
  -> cl2
  -> RunningClockInit
       (ExceptT e IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
 -> Schedule (ExceptT e IO) cl1 cl2)
-> (cl1
    -> cl2
    -> RunningClockInit
         (ExceptT e IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule (ExceptT e IO) cl1 cl2
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) <- IO
  (MVar (Either e (Time cl2)),
   MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2))),
   IORef (Maybe e))
-> ExceptT
     e
     IO
     (MVar (Either e (Time cl2)),
      MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2))),
      IORef (Maybe e))
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO
   (MVar (Either e (Time cl2)),
    MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2))),
    IORef (Maybe e))
 -> ExceptT
      e
      IO
      (MVar (Either e (Time cl2)),
       MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2))),
       IORef (Maybe e)))
-> IO
     (MVar (Either e (Time cl2)),
      MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2))),
      IORef (Maybe e))
-> ExceptT
     e
     IO
     (MVar (Either e (Time cl2)),
      MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2))),
      IORef (Maybe e))
forall a b. (a -> b) -> a -> b
$ do
    MVar (Either e (Time cl2))
iMVar <- IO (MVar (Either e (Time cl2)))
forall a. IO (MVar a)
newEmptyMVar -- The initialisation time is transferred over this variable. It's written to twice.
    MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
mvar  <- IO (MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2))))
forall a. IO (MVar a)
newEmptyMVar -- The ticks and exceptions are transferred over this variable. It receives two 'Left' values in total.
    IORef (Maybe e)
errorref <- Maybe e -> IO (IORef (Maybe e))
forall a. a -> IO (IORef a)
newIORef Maybe e
forall a. Maybe a
Nothing -- Used to broadcast the exception to both clocks
    ThreadId
_ <- cl1
-> (Tag cl1 -> Either (Tag cl1) (Tag cl2))
-> MVar (Either e (Time cl1))
-> MVar (Either e (Time cl1, Either (Tag cl1) (Tag cl2)))
-> IORef (Maybe e)
-> IO 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 Tag cl1 -> Either (Tag cl1) (Tag cl2)
forall a b. a -> Either a b
Left  MVar (Either e (Time cl1))
MVar (Either e (Time cl2))
iMVar MVar (Either e (Time cl1, Either (Tag cl1) (Tag cl2)))
MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
mvar IORef (Maybe e)
errorref
    ThreadId
_ <- cl2
-> (Tag cl2 -> Either (Tag cl1) (Tag cl2))
-> MVar (Either e (Time cl2))
-> MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
-> IORef (Maybe e)
-> IO 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 Tag cl2 -> Either (Tag cl1) (Tag 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
    (MVar (Either e (Time cl2)),
 MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2))),
 IORef (Maybe e))
-> IO
     (MVar (Either e (Time cl2)),
      MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2))),
      IORef (Maybe e))
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)
  MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
-> ExceptT
     e
     IO
     (MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
-> ExceptT
     e
     IO
     (MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
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 (ExceptT
   e
   IO
   (MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
    Time cl2)
 -> ExceptT
      e
      IO
      (MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
       Time cl2))
-> ExceptT
     e
     IO
     (MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
-> ExceptT
     e
     IO
     (MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
forall a b. (a -> b) -> a -> b
$ do
    Time cl2
initTime <- IO (Either e (Time cl2)) -> ExceptT e IO (Time cl2)
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either e (Time cl2)) -> ExceptT e IO (Time cl2))
-> IO (Either e (Time cl2)) -> ExceptT e IO (Time cl2)
forall a b. (a -> b) -> a -> b
$ MVar (Either e (Time cl2)) -> IO (Either e (Time cl2))
forall a. MVar a -> IO a
takeMVar MVar (Either e (Time cl2))
iMVar -- The first clock to be initialised sets the first time stamp
    Time cl2
_        <- IO (Either e (Time cl2)) -> ExceptT e IO (Time cl2)
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either e (Time cl2)) -> ExceptT e IO (Time cl2))
-> IO (Either e (Time cl2)) -> ExceptT e IO (Time cl2)
forall a b. (a -> b) -> a -> b
$ MVar (Either e (Time cl2)) -> IO (Either e (Time cl2))
forall a. MVar a -> IO a
takeMVar MVar (Either e (Time cl2))
iMVar -- Initialise the second clock
    let runningSchedule :: MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2))
runningSchedule = ExceptT e IO (Time cl2, Either (Tag cl1) (Tag cl2))
-> MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM (ExceptT e IO (Time cl2, Either (Tag cl1) (Tag cl2))
 -> MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2)))
-> ExceptT e IO (Time cl2, Either (Tag cl1) (Tag cl2))
-> MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2))
forall a b. (a -> b) -> a -> b
$ do
          Either e (Time cl2, Either (Tag cl1) (Tag cl2))
eTick <- IO (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
-> ExceptT e IO (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
 -> ExceptT e IO (Either e (Time cl2, Either (Tag cl1) (Tag cl2))))
-> IO (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
-> ExceptT e IO (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
forall a b. (a -> b) -> a -> b
$ MVar (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
-> IO (Either e (Time cl2, Either (Tag cl1) (Tag cl2)))
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 -> (Time cl2, Either (Tag cl1) (Tag cl2))
-> ExceptT e IO (Time cl2, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Time cl2, Either (Tag cl1) (Tag cl2))
tick
            Left e
e     -> do
              IO () -> ExceptT e IO ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT e IO ()) -> IO () -> ExceptT e IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe e) -> Maybe e -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe e)
errorref (Maybe e -> IO ()) -> Maybe e -> IO ()
forall a b. (a -> b) -> a -> b
$ e -> Maybe e
forall a. a -> Maybe a
Just e
e -- Broadcast the exception to both clocks
              e -> ExceptT e IO (Time cl2, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE e
e
    (MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
 Time cl2)
-> ExceptT
     e
     IO
     (MSF (ExceptT e IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
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 (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
      Either a (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl)
initialised <- ExceptT a IO (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl)
-> IO (Either a (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl))
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT a IO (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl)
 -> IO
      (Either a (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl)))
-> ExceptT a IO (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl)
-> IO (Either a (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl))
forall a b. (a -> b) -> a -> b
$ cl
-> ExceptT a IO (MSF (ExceptT a IO) () (Time cl, Tag cl), Time cl)
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
          MVar (Either a (Time cl)) -> Either a (Time cl) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either a (Time cl))
iMVar (Either a (Time cl) -> IO ()) -> Either a (Time cl) -> IO ()
forall a b. (a -> b) -> a -> b
$ Time cl -> Either a (Time cl)
forall a b. b -> Either a b
Right Time cl
initTime
          Left a
e <- ExceptT a IO () -> IO (Either a ())
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT a IO () -> IO (Either a ()))
-> ExceptT a IO () -> IO (Either a ())
forall a b. (a -> b) -> a -> b
$ MSF (ExceptT a IO) () () -> ExceptT a IO ()
forall (m :: Type -> Type). Monad m => MSF m () () -> m ()
reactimate (MSF (ExceptT a IO) () () -> ExceptT a IO ())
-> MSF (ExceptT a IO) () () -> ExceptT a IO ()
forall a b. (a -> b) -> a -> b
$ MSF (ExceptT a IO) () (Time cl, Tag cl)
runningClock MSF (ExceptT a IO) () (Time cl, Tag cl)
-> MSF (ExceptT a IO) (Time cl, Tag cl) ()
-> MSF (ExceptT a IO) () ()
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
            (Either a (Time cl, b) -> ExceptT a IO ())
-> MSF (ExceptT a IO) (Either a (Time cl, b)) ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM (IO () -> ExceptT a IO ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT a IO ())
-> (Either a (Time cl, b) -> IO ())
-> Either a (Time cl, b)
-> ExceptT a IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (Either a (Time cl, b)) -> Either a (Time cl, b) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either a (Time cl, b))
mvar)               -< (Time cl, b) -> Either a (Time cl, b)
forall a b. b -> Either a b
Right (Time cl
td, Tag cl -> b
leftright Tag cl
tag2)
            Maybe a
me <- ExceptT a IO (Maybe a) -> MSF (ExceptT a IO) () (Maybe a)
forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM (IO (Maybe a) -> ExceptT a IO (Maybe a)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe a) -> ExceptT a IO (Maybe a))
-> IO (Maybe a) -> ExceptT a IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe a) -> IO (Maybe a)
forall a. IORef a -> IO a
readIORef IORef (Maybe a)
errorref) -< ()
            Maybe Any
_  <- MSF (ExceptT a IO) (Maybe a) (Maybe Any)
forall (m :: Type -> Type) e a.
Monad m =>
MSF (ExceptT e m) (Maybe e) (Maybe a)
throwMaybe                         -< Maybe a
me
            MSF (ExceptT a IO) () ()
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< ()
          MVar (Either a (Time cl, b)) -> Either a (Time cl, b) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either a (Time cl, b))
mvar (Either a (Time cl, b) -> IO ()) -> Either a (Time cl, b) -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Either a (Time cl, b)
forall a b. a -> Either a b
Left a
e -- Either throw own exception or acknowledge the exception from the other clock
        Left a
e -> IO () -> IO ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Either a (Time cl)) -> Either a (Time cl) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either a (Time cl))
iMVar (Either a (Time cl) -> IO ()) -> Either a (Time cl) -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Either a (Time cl)
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 = ExceptT e' IO a -> (e' -> ExceptT e' IO a) -> ExceptT e' IO a
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 ((e' -> ExceptT e' IO a) -> ExceptT e' IO a)
-> (e' -> ExceptT e' IO a) -> ExceptT e' IO a
forall a b. (a -> b) -> a -> b
$ \e'
e -> do
      ()
_ <- MSF (ExceptT e' IO) () () -> ExceptT e' IO ()
forall (m :: Type -> Type). Monad m => MSF m () () -> m ()
reactimate (MSF (ExceptT e' IO) () () -> ExceptT e' IO ())
-> MSF (ExceptT e' IO) () () -> ExceptT e' IO ()
forall a b. (a -> b) -> a -> b
$ (ExceptT e' IO b -> MSF (ExceptT e' IO) () b
forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM (ExceptT e' IO b -> MSF (ExceptT e' IO) () b)
-> ExceptT e' IO b -> MSF (ExceptT e' IO) () b
forall a b. (a -> b) -> a -> b
$ IO (Either e' b) -> ExceptT e' IO b
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either e' b) -> ExceptT e' IO b)
-> IO (Either e' b) -> ExceptT e' IO b
forall a b. (a -> b) -> a -> b
$ MVar (Either e' b) -> IO (Either e' b)
forall a. MVar a -> IO a
takeMVar MVar (Either e' b)
mvar) MSF (ExceptT e' IO) () b
-> MSF (ExceptT e' IO) b () -> MSF (ExceptT e' IO) () ()
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (b -> ()) -> MSF (ExceptT e' IO) b ()
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (() -> b -> ()
forall a b. a -> b -> a
const ()) -- Drain the mvar until the other clock acknowledges the exception
      e' -> ExceptT e' IO a
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE e'
e

-- | As 'concurrentlyExcept', with a single possible exception value.
concurrentlyMaybe
  :: ( Clock (MaybeT IO) cl1
     , Clock (MaybeT IO) cl2
     , Time cl1 ~ Time cl2
     )
  => Schedule (MaybeT IO) cl1 cl2
concurrentlyMaybe :: Schedule (MaybeT IO) cl1 cl2
concurrentlyMaybe = (cl1
 -> cl2
 -> RunningClockInit
      (MaybeT IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule (MaybeT IO) cl1 cl2
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 ((cl1
  -> cl2
  -> RunningClockInit
       (MaybeT IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
 -> Schedule (MaybeT IO) cl1 cl2)
-> (cl1
    -> cl2
    -> RunningClockInit
         (MaybeT IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule (MaybeT IO) cl1 cl2
forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 -> Schedule
  (MaybeT IO)
  (HoistClock (MaybeT IO) (ExceptT () IO) cl1)
  (HoistClock (MaybeT IO) (ExceptT () IO) cl2)
-> HoistClock (MaybeT IO) (ExceptT () IO) cl1
-> HoistClock (MaybeT IO) (ExceptT () IO) cl2
-> RunningClockInit
     (MaybeT IO)
     (Time (HoistClock (MaybeT IO) (ExceptT () IO) cl1))
     (Either
        (Tag (HoistClock (MaybeT IO) (ExceptT () IO) cl1))
        (Tag (HoistClock (MaybeT IO) (ExceptT () IO) cl2)))
forall (m :: Type -> Type) cl1 cl2.
Schedule m cl1 cl2
-> cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule
  ((forall a. ExceptT () IO a -> MaybeT IO a)
-> Schedule
     (ExceptT () IO)
     (HoistClock (MaybeT IO) (ExceptT () IO) cl1)
     (HoistClock (MaybeT IO) (ExceptT () IO) cl2)
-> Schedule
     (MaybeT IO)
     (HoistClock (MaybeT IO) (ExceptT () IO) cl1)
     (HoistClock (MaybeT IO) (ExceptT () IO) cl2)
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 Schedule
  (ExceptT () IO)
  (HoistClock (MaybeT IO) (ExceptT () IO) cl1)
  (HoistClock (MaybeT IO) (ExceptT () IO) cl2)
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)
    (cl1
-> (forall a. MaybeT IO a -> ExceptT () IO a)
-> HoistClock (MaybeT IO) (ExceptT () IO) cl1
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)
    (cl2
-> (forall a. MaybeT IO a -> ExceptT () IO a)
-> HoistClock (MaybeT IO) (ExceptT () IO) cl2
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 :: ExceptT () IO a -> MaybeT IO a
exceptTIOToMaybeTIO = ExceptT () IO a -> MaybeT IO a
forall (m :: Type -> Type) e a.
Functor m =>
ExceptT e m a -> MaybeT m a
exceptToMaybeT
        maybeTIOToExceptTIO :: MaybeT IO a -> ExceptT () IO a
        maybeTIOToExceptTIO :: MaybeT IO a -> ExceptT () IO a
maybeTIOToExceptTIO = () -> MaybeT IO a -> ExceptT () IO a
forall (m :: Type -> Type) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT ()