{- | Wrapper to write @gloss@ applications in Rhine, using concurrency.
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Gloss.IO
  ( GlossConcT
  , paintIO
  , clearIO
  , paintAllIO
  , GlossEventClockIO (..)
  , GlossSimClockIO (..)
  , launchGlossThread
  , flowGlossIO
  , glossConcurrently
  )
  where

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

-- transformers
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader

-- gloss
import Graphics.Gloss.Interface.IO.Game

-- rhine
import FRP.Rhine

-- rhine-gloss
import FRP.Rhine.Gloss.Common

-- * Gloss effects

type GlossEnv = (MVar Float, MVar Event, IORef Float, IORef Picture)

-- | Wraps the concurrent variables needed for communication with the @gloss@ backend.
newtype GlossConcT m a = GlossConcT
  { GlossConcT m a -> ReaderT GlossEnv m a
unGlossConcT :: ReaderT GlossEnv m a }
  deriving (a -> GlossConcT m b -> GlossConcT m a
(a -> b) -> GlossConcT m a -> GlossConcT m b
(forall a b. (a -> b) -> GlossConcT m a -> GlossConcT m b)
-> (forall a b. a -> GlossConcT m b -> GlossConcT m a)
-> Functor (GlossConcT m)
forall a b. a -> GlossConcT m b -> GlossConcT m a
forall a b. (a -> b) -> GlossConcT m a -> GlossConcT m b
forall (m :: * -> *) a b.
Functor m =>
a -> GlossConcT m b -> GlossConcT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GlossConcT m a -> GlossConcT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> GlossConcT m b -> GlossConcT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GlossConcT m b -> GlossConcT m a
fmap :: (a -> b) -> GlossConcT m a -> GlossConcT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GlossConcT m a -> GlossConcT m b
Functor, Functor (GlossConcT m)
a -> GlossConcT m a
Functor (GlossConcT m)
-> (forall a. a -> GlossConcT m a)
-> (forall a b.
    GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b)
-> (forall a b c.
    (a -> b -> c)
    -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c)
-> (forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b)
-> (forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m a)
-> Applicative (GlossConcT m)
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
GlossConcT m a -> GlossConcT m b -> GlossConcT m a
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
forall a. a -> GlossConcT m a
forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m a
forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall a b.
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
forall a b c.
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (GlossConcT m)
forall (m :: * -> *) a. Applicative m => a -> GlossConcT m a
forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m a
forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
<* :: GlossConcT m a -> GlossConcT m b -> GlossConcT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m a
*> :: GlossConcT m a -> GlossConcT m b -> GlossConcT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
liftA2 :: (a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
<*> :: GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
pure :: a -> GlossConcT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> GlossConcT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (GlossConcT m)
Applicative, Applicative (GlossConcT m)
a -> GlossConcT m a
Applicative (GlossConcT m)
-> (forall a b.
    GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b)
-> (forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b)
-> (forall a. a -> GlossConcT m a)
-> Monad (GlossConcT m)
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall a. a -> GlossConcT m a
forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall a b.
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
forall (m :: * -> *). Monad m => Applicative (GlossConcT m)
forall (m :: * -> *) a. Monad m => a -> GlossConcT m a
forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> GlossConcT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> GlossConcT m a
>> :: GlossConcT m a -> GlossConcT m b -> GlossConcT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
>>= :: GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (GlossConcT m)
Monad, m a -> GlossConcT m a
(forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a)
-> MonadTrans GlossConcT
forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> GlossConcT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a
MonadTrans, Monad (GlossConcT m)
Monad (GlossConcT m)
-> (forall a. IO a -> GlossConcT m a) -> MonadIO (GlossConcT m)
IO a -> GlossConcT m a
forall a. IO a -> GlossConcT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (GlossConcT m)
forall (m :: * -> *) a. MonadIO m => IO a -> GlossConcT m a
liftIO :: IO a -> GlossConcT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GlossConcT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (GlossConcT m)
MonadIO)

withPicRef
  :: MonadIO m
  => (IORef Picture -> IO a)
  -> GlossConcT m a
withPicRef :: (IORef Picture -> IO a) -> GlossConcT m a
withPicRef IORef Picture -> IO a
action = ReaderT GlossEnv m a -> GlossConcT m a
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT (ReaderT GlossEnv m a -> GlossConcT m a)
-> ReaderT GlossEnv m a -> GlossConcT m a
forall a b. (a -> b) -> a -> b
$ do
  (MVar Float
_, MVar Event
_, IORef Float
_, IORef Picture
picRef) <- ReaderT GlossEnv m GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO a -> ReaderT GlossEnv m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT GlossEnv m a) -> IO a -> ReaderT GlossEnv m a
forall a b. (a -> b) -> a -> b
$ IORef Picture -> IO a
action IORef Picture
picRef

-- | Add a picture to the canvas.
paintIO :: MonadIO m => Picture -> GlossConcT m ()
paintIO :: Picture -> GlossConcT m ()
paintIO Picture
pic = (IORef Picture -> IO ()) -> GlossConcT m ()
forall (m :: * -> *) a.
MonadIO m =>
(IORef Picture -> IO a) -> GlossConcT m a
withPicRef ((IORef Picture -> IO ()) -> GlossConcT m ())
-> (IORef Picture -> IO ()) -> GlossConcT m ()
forall a b. (a -> b) -> a -> b
$ \IORef Picture
ref -> IORef Picture -> (Picture -> Picture) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Picture
ref (Picture -> Picture -> Picture
forall a. Semigroup a => a -> a -> a
<> Picture
pic)

-- | Clear the canvas.
clearIO :: MonadIO m => GlossConcT m ()
clearIO :: GlossConcT m ()
clearIO = (IORef Picture -> IO ()) -> GlossConcT m ()
forall (m :: * -> *) a.
MonadIO m =>
(IORef Picture -> IO a) -> GlossConcT m a
withPicRef ((IORef Picture -> IO ()) -> GlossConcT m ())
-> (IORef Picture -> IO ()) -> GlossConcT m ()
forall a b. (a -> b) -> a -> b
$ \IORef Picture
ref -> IORef Picture -> Picture -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Picture
ref Picture
Blank

-- | Clear the canvas and then paint.
paintAllIO :: MonadIO m => Picture -> GlossConcT m ()
paintAllIO :: Picture -> GlossConcT m ()
paintAllIO Picture
pic = GlossConcT m ()
forall (m :: * -> *). MonadIO m => GlossConcT m ()
clearIO GlossConcT m () -> GlossConcT m () -> GlossConcT m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Picture -> GlossConcT m ()
forall (m :: * -> *). MonadIO m => Picture -> GlossConcT m ()
paintIO Picture
pic

-- * Gloss clocks in 'IO'

-- | Concurrently block on @gloss@ events.
data GlossEventClockIO = GlossEventClockIO

instance MonadIO m => Clock (GlossConcT m) GlossEventClockIO where
  type Time GlossEventClockIO = Float
  type Tag  GlossEventClockIO = Event
  initClock :: GlossEventClockIO
-> RunningClockInit
     (GlossConcT m) (Time GlossEventClockIO) (Tag GlossEventClockIO)
initClock GlossEventClockIO
_ = (MSF (GlossConcT m) () (Float, Event), Float)
-> GlossConcT m (MSF (GlossConcT m) () (Float, Event), Float)
forall (m :: * -> *) a. Monad m => a -> m a
return (GlossConcT m (Float, Event) -> MSF (GlossConcT m) () (Float, Event)
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM GlossConcT m (Float, Event)
getEvent, Float
0)
    where
      getEvent :: GlossConcT m (Float, Event)
getEvent = do
        (MVar Float
_, MVar Event
eventVar, IORef Float
timeRef, IORef Picture
_) <- ReaderT GlossEnv m GlossEnv -> GlossConcT m GlossEnv
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT ReaderT GlossEnv m GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        IO (Float, Event) -> GlossConcT m (Float, Event)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Float, Event) -> GlossConcT m (Float, Event))
-> IO (Float, Event) -> GlossConcT m (Float, Event)
forall a b. (a -> b) -> a -> b
$ do
          Event
event <- MVar Event -> IO Event
forall a. MVar a -> IO a
takeMVar MVar Event
eventVar
          Float
time <- IORef Float -> IO Float
forall a. IORef a -> IO a
readIORef IORef Float
timeRef
          (Float, Event) -> IO (Float, Event)
forall (m :: * -> *) a. Monad m => a -> m a
return (Float
time, Event
event)

instance GetClockProxy GlossEventClockIO

-- | Concurrently block on @gloss@ simulation ticks.
data GlossSimClockIO = GlossSimClockIO

instance MonadIO m => Clock (GlossConcT m) GlossSimClockIO where
  type Time GlossSimClockIO = Float
  type Tag  GlossSimClockIO = ()
  initClock :: GlossSimClockIO
-> RunningClockInit
     (GlossConcT m) (Time GlossSimClockIO) (Tag GlossSimClockIO)
initClock GlossSimClockIO
_ = (MSF (GlossConcT m) () (Float, ()), Float)
-> GlossConcT m (MSF (GlossConcT m) () (Float, ()), Float)
forall (m :: * -> *) a. Monad m => a -> m a
return (GlossConcT m Float -> MSF (GlossConcT m) () Float
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM GlossConcT m Float
getTime MSF (GlossConcT m) () Float
-> MSF (GlossConcT m) Float (Float, ())
-> MSF (GlossConcT m) () (Float, ())
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF (GlossConcT m) Float Float
forall v s (m :: * -> *). (VectorSpace v s, Monad m) => MSF m v v
sumS MSF (GlossConcT m) Float Float
-> MSF (GlossConcT m) Float (Float, ())
-> MSF (GlossConcT m) Float (Float, ())
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Float -> GlossConcT m ()) -> MSF (GlossConcT m) Float Float
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a a
withSideEffect Float -> GlossConcT m ()
forall (m :: * -> *). MonadIO m => Float -> GlossConcT m ()
writeTime MSF (GlossConcT m) Float Float
-> MSF (GlossConcT m) Float ()
-> MSF (GlossConcT m) Float (Float, ())
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Float -> ()) -> MSF (GlossConcT m) Float ()
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (() -> Float -> ()
forall a b. a -> b -> a
const ()), Float
0)
    where
      getTime :: GlossConcT m Float
getTime = do
        (MVar Float
timeVar, MVar Event
_, IORef Float
_, IORef Picture
_) <- ReaderT GlossEnv m GlossEnv -> GlossConcT m GlossEnv
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT ReaderT GlossEnv m GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        IO Float -> GlossConcT m Float
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Float -> GlossConcT m Float) -> IO Float -> GlossConcT m Float
forall a b. (a -> b) -> a -> b
$ MVar Float -> IO Float
forall a. MVar a -> IO a
takeMVar MVar Float
timeVar
      writeTime :: Float -> GlossConcT m ()
writeTime Float
time = do
        (MVar Float
_, MVar Event
_, IORef Float
timeRef, IORef Picture
_) <- ReaderT GlossEnv m GlossEnv -> GlossConcT m GlossEnv
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT ReaderT GlossEnv m GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        IO () -> GlossConcT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GlossConcT m ()) -> IO () -> GlossConcT m ()
forall a b. (a -> b) -> a -> b
$ IORef Float -> Float -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Float
timeRef Float
time

instance GetClockProxy GlossSimClockIO

-- * Reactimation

-- | Apply this to supply the 'GlossConcT' effect.
--   Creates a new thread in which @gloss@ is run,
--   and feeds the clocks 'GlossEventClockIO' and 'GlossSimClockIO'.
--
--   Usually, this function is applied to the result of 'flow',
--   so you can handle all occurring effects as needed.
--   If you only use @gloss@ in your whole signal network,
--   you can use 'flowGlossIO' instead.
launchGlossThread
  :: MonadIO    m
  => GlossSettings
  -> GlossConcT m a
  ->            m a
launchGlossThread :: GlossSettings -> GlossConcT m a -> m a
launchGlossThread GlossSettings { Int
Display
Color
stepsPerSecond :: GlossSettings -> Int
backgroundColor :: GlossSettings -> Color
display :: GlossSettings -> Display
stepsPerSecond :: Int
backgroundColor :: Color
display :: Display
.. } GlossConcT m a
glossLoop = do
  GlossEnv
vars <- IO GlossEnv -> m GlossEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GlossEnv -> m GlossEnv) -> IO GlossEnv -> m GlossEnv
forall a b. (a -> b) -> a -> b
$ ( , , , ) (MVar Float
 -> MVar Event -> IORef Float -> IORef Picture -> GlossEnv)
-> IO (MVar Float)
-> IO (MVar Event -> IORef Float -> IORef Picture -> GlossEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar Float)
forall a. IO (MVar a)
newEmptyMVar IO (MVar Event -> IORef Float -> IORef Picture -> GlossEnv)
-> IO (MVar Event) -> IO (IORef Float -> IORef Picture -> GlossEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (MVar Event)
forall a. IO (MVar a)
newEmptyMVar IO (IORef Float -> IORef Picture -> GlossEnv)
-> IO (IORef Float) -> IO (IORef Picture -> GlossEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Float -> IO (IORef Float)
forall a. a -> IO (IORef a)
newIORef Float
0 IO (IORef Picture -> GlossEnv) -> IO (IORef Picture) -> IO GlossEnv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Picture -> IO (IORef Picture)
forall a. a -> IO (IORef a)
newIORef Picture
Blank
  let
      getPic :: (a, b, c, IORef a) -> IO a
getPic               (a
_, b
_, c
_, IORef a
picRef)   = IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
picRef
      -- Only try to put so this doesn't hang in case noone is listening for events or ticks
      handleEvent :: a -> (a, MVar a, c, d) -> IO (a, MVar a, c, d)
handleEvent a
event    vars :: (a, MVar a, c, d)
vars@(a
_, MVar a
eventVar, c
_, d
_) = do
        IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar a
eventVar a
event
        (a, MVar a, c, d) -> IO (a, MVar a, c, d)
forall (m :: * -> *) a. Monad m => a -> m a
return (a, MVar a, c, d)
vars
      simStep :: a -> (MVar a, b, c, d) -> IO (MVar a, b, c, d)
simStep     a
diffTime vars :: (MVar a, b, c, d)
vars@(MVar a
timeVar,  b
_, c
_, d
_) = do
        IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar a
timeVar a
diffTime
        (MVar a, b, c, d) -> IO (MVar a, b, c, d)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar a, b, c, d)
vars
  m ThreadId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ThreadId -> m ()) -> m ThreadId -> m ()
forall a b. (a -> b) -> a -> b
$ 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
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Display
-> Color
-> Int
-> GlossEnv
-> (GlossEnv -> IO Picture)
-> (Event -> GlossEnv -> IO GlossEnv)
-> (Float -> GlossEnv -> IO GlossEnv)
-> IO ()
forall world.
Display
-> Color
-> Int
-> world
-> (world -> IO Picture)
-> (Event -> world -> IO world)
-> (Float -> world -> IO world)
-> IO ()
playIO Display
display Color
backgroundColor Int
stepsPerSecond GlossEnv
vars GlossEnv -> IO Picture
forall a b c a. (a, b, c, IORef a) -> IO a
getPic Event -> GlossEnv -> IO GlossEnv
forall a a c d. a -> (a, MVar a, c, d) -> IO (a, MVar a, c, d)
handleEvent Float -> GlossEnv -> IO GlossEnv
forall a b c d. a -> (MVar a, b, c, d) -> IO (MVar a, b, c, d)
simStep
  ReaderT GlossEnv m a -> GlossEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (GlossConcT m a -> ReaderT GlossEnv m a
forall (m :: * -> *) a. GlossConcT m a -> ReaderT GlossEnv m a
unGlossConcT GlossConcT m a
glossLoop) GlossEnv
vars

-- | Run a 'Rhine' in the 'GlossConcT' monad by launching a separate thread for the @gloss@ backend,
--   and reactimate in the foreground.
flowGlossIO
  :: ( Clock (GlossConcT IO) cl
     , GetClockProxy cl
     , Time cl ~ Time (In  cl)
     , Time cl ~ Time (Out cl)
     )
  => GlossSettings
  -> Rhine (GlossConcT IO) cl () ()
  -> IO ()
flowGlossIO :: GlossSettings -> Rhine (GlossConcT IO) cl () () -> IO ()
flowGlossIO GlossSettings
settings = GlossSettings -> GlossConcT IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
GlossSettings -> GlossConcT m a -> m a
launchGlossThread GlossSettings
settings (GlossConcT IO () -> IO ())
-> (Rhine (GlossConcT IO) cl () () -> GlossConcT IO ())
-> Rhine (GlossConcT IO) cl () ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rhine (GlossConcT IO) cl () () -> GlossConcT IO ()
forall (m :: * -> *) cl.
(Monad m, Clock m cl, GetClockProxy cl, Time cl ~ Time (In cl),
 Time cl ~ Time (Out cl)) =>
Rhine m cl () () -> m ()
flow

-- | A schedule in the 'GlossConcT' transformer,
--   supplying the same backend connection to its scheduled clocks.
glossConcurrently
  :: ( Monad IO
     , Clock (GlossConcT IO) cl1, Clock (GlossConcT IO) cl2
     , Time cl1 ~ Time cl2
     )
  => Schedule (GlossConcT IO) cl1 cl2
glossConcurrently :: Schedule (GlossConcT IO) cl1 cl2
glossConcurrently = (cl1
 -> cl2
 -> RunningClockInit
      (GlossConcT IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule (GlossConcT IO) cl1 cl2
forall (m :: * -> *) 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
       (GlossConcT IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
 -> Schedule (GlossConcT IO) cl1 cl2)
-> (cl1
    -> cl2
    -> RunningClockInit
         (GlossConcT IO) (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule (GlossConcT IO) cl1 cl2
forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 -> ReaderT
  GlossEnv
  IO
  (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
   Time cl2)
-> GlossConcT
     IO
     (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT (ReaderT
   GlossEnv
   IO
   (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
    Time cl2)
 -> GlossConcT
      IO
      (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
       Time cl2))
-> ReaderT
     GlossEnv
     IO
     (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
-> GlossConcT
     IO
     (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
forall a b. (a -> b) -> a -> b
$ (GlossEnv
 -> IO
      (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
       Time cl2))
-> ReaderT
     GlossEnv
     IO
     (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT
  ((GlossEnv
  -> IO
       (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
        Time cl2))
 -> ReaderT
      GlossEnv
      IO
      (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
       Time cl2))
-> (GlossEnv
    -> IO
         (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
          Time cl2))
-> ReaderT
     GlossEnv
     IO
     (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
forall a b. (a -> b) -> a -> b
$ \GlossEnv
vars -> (MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2))
 -> MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)))
-> (MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2)), Time cl2)
-> (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
    Time cl2)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2))
-> MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTrans t, Monad m, Monad (t m)) =>
MSF m a b -> MSF (t m) a b
liftTransS
  ((MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2)), Time cl2)
 -> (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
     Time cl2))
-> IO (MSF IO () (Time cl2, Either (Tag cl1) (Tag cl2)), Time cl2)
-> IO
     (MSF (GlossConcT IO) () (Time cl2, Either (Tag cl1) (Tag cl2)),
      Time cl2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schedule IO (RunGlossEnvClock cl1) (RunGlossEnvClock cl2)
-> RunGlossEnvClock cl1
-> RunGlossEnvClock cl2
-> RunningClockInit
     IO
     (Time (RunGlossEnvClock cl1))
     (Either (Tag (RunGlossEnvClock cl1)) (Tag (RunGlossEnvClock cl2)))
forall (m :: * -> *) cl1 cl2.
Schedule m cl1 cl2
-> cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule Schedule IO (RunGlossEnvClock cl1) (RunGlossEnvClock cl2)
forall cl1 cl2.
(Clock IO cl1, Clock IO cl2, Time cl1 ~ Time cl2) =>
Schedule IO cl1 cl2
concurrently
        (GlossEnv -> cl1 -> RunGlossEnvClock cl1
forall cl. GlossEnv -> cl -> RunGlossEnvClock cl
runGlossEnvClock GlossEnv
vars cl1
cl1)
        (GlossEnv -> cl2 -> RunGlossEnvClock cl2
forall cl. GlossEnv -> cl -> RunGlossEnvClock cl
runGlossEnvClock GlossEnv
vars cl2
cl2)

type RunGlossEnvClock cl = HoistClock (GlossConcT IO) IO cl

runGlossEnvClock
  :: GlossEnv
  -> cl
  -> RunGlossEnvClock cl
runGlossEnvClock :: GlossEnv -> cl -> RunGlossEnvClock cl
runGlossEnvClock GlossEnv
env cl
unhoistedClock = HoistClock :: forall (m1 :: * -> *) (m2 :: * -> *) cl.
cl -> (forall a. m1 a -> m2 a) -> HoistClock m1 m2 cl
HoistClock
  { monadMorphism :: forall a. GlossConcT IO a -> IO a
monadMorphism = (ReaderT GlossEnv IO a -> GlossEnv -> IO a)
-> GlossEnv -> ReaderT GlossEnv IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT GlossEnv IO a -> GlossEnv -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT GlossEnv
env (ReaderT GlossEnv IO a -> IO a)
-> (GlossConcT IO a -> ReaderT GlossEnv IO a)
-> GlossConcT IO a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlossConcT IO a -> ReaderT GlossEnv IO a
forall (m :: * -> *) a. GlossConcT m a -> ReaderT GlossEnv m a
unGlossConcT
  , cl
unhoistedClock :: cl
unhoistedClock :: cl
..
  }

-- FIXME And a schedule for gloss clocks and other clocks