{-# 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
import qualified Control.Category as Category
import Control.Concurrent
import Control.Concurrent.MVar
import Data.Functor (void)
import Data.IORef
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Graphics.Gloss.Interface.IO.Game
import FRP.Rhine
import FRP.Rhine.Gloss.Common
type GlossEnv = (MVar Float, MVar Event, IORef Float, IORef Picture)
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
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)
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
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
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
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
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
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
Bool
result <- 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
Bool
result <- 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
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
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
..
}