{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- | Wrapper to write @gloss@ applications in Rhine, using concurrency.
module FRP.Rhine.Gloss.IO (
  GlossEnv (..),
  GlossConcT (..),
  GlossConc,
  runGlossConcT,
  paintIO,
  clearIO,
  paintAllIO,
  GlossEventClockIO (..),
  GlossSimClockIO (..),
  makeGlossEnv,
  launchInGlossThread,
  launchGlossThread,
  flowGlossIO,
  runGlossEnvClock,
  RunGlossEnvClock,
  GlossClockUTC,
  glossClockUTC,
  GlossConcTClock,
  glossConcTClock,
  GlossConcClock,
  glossConcClock,
)
where

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

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

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

-- monad-schedule
import Control.Monad.Schedule.Class
import Control.Monad.Schedule.FreeAsync

-- rhine
import FRP.Rhine
import FRP.Rhine.Clock.Realtime (UTCClock, addUTC)

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

-- * Gloss effects

-- | Concurrent variables needed to communicate with the gloss backend.
data GlossEnv = GlossEnv
  { GlossEnv -> MVar Float
timeVar :: MVar Float
  , GlossEnv -> MVar Event
eventVar :: MVar Event
  , GlossEnv -> IORef Picture
picRef :: IORef Picture
  , GlossEnv -> IORef Float
timeRef :: IORef Float
  }

{- | Effects in the gloss backend

* Wraps the concurrent variables needed for communication with the @gloss@ backend.
* Adds the 'FreeAsyncT' concurrency layer for fairer scheduling
-}
newtype GlossConcT m a = GlossConcT
  {forall (m :: * -> *) a.
GlossConcT m a -> ReaderT GlossEnv (FreeAsyncT m) a
unGlossConcT :: ReaderT GlossEnv (FreeAsyncT m) a}
  deriving ((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.
Monad m =>
a -> GlossConcT m b -> GlossConcT m a
forall (m :: * -> *) a b.
Monad 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
$cfmap :: forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> GlossConcT m a -> GlossConcT m b
fmap :: forall a b. (a -> b) -> GlossConcT m a -> GlossConcT m b
$c<$ :: forall (m :: * -> *) a b.
Monad m =>
a -> GlossConcT m b -> GlossConcT m a
<$ :: forall a b. a -> GlossConcT m b -> GlossConcT m a
Functor, Functor (GlossConcT m)
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)
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 (m :: * -> *). Monad m => Functor (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 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 -> b) -> GlossConcT m a -> GlossConcT m b
forall (m :: * -> *) a b c.
Monad m =>
(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
$cpure :: forall (m :: * -> *) a. Monad m => a -> GlossConcT m a
pure :: forall a. a -> GlossConcT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
<*> :: forall a b.
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
liftA2 :: forall a b c.
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
*> :: forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m a
<* :: forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m a
Applicative, Applicative (GlossConcT m)
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)
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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
>>= :: forall a b.
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
>> :: forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> GlossConcT m a
return :: forall a. a -> GlossConcT m a
Monad, Monad (GlossConcT m)
Monad (GlossConcT m) =>
(forall a. IO a -> GlossConcT m a) -> MonadIO (GlossConcT m)
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
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GlossConcT m a
liftIO :: forall a. IO a -> GlossConcT m a
MonadIO)

-- | When @gloss@ is the only effect you are using, use this monad to simplify your type signatures.
type GlossConc = GlossConcT IO

instance MonadTrans GlossConcT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a
lift = ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
forall (m :: * -> *) a.
ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
GlossConcT (ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a)
-> (m a -> ReaderT GlossEnv (FreeAsyncT m) a)
-> m a
-> GlossConcT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeAsyncT m a -> ReaderT GlossEnv (FreeAsyncT m) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT GlossEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FreeAsyncT m a -> ReaderT GlossEnv (FreeAsyncT m) a)
-> (m a -> FreeAsyncT m a)
-> m a
-> ReaderT GlossEnv (FreeAsyncT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- FIXME MFunctor & MMonad instances pending https://github.com/HeinrichApfelmus/operational/pull/28/

-- | Remove the 'GlossConcT' transformer by explicitly providing an environment.
runGlossConcT :: (MonadIO m) => GlossConcT m a -> GlossEnv -> m a
runGlossConcT :: forall (m :: * -> *) a.
MonadIO m =>
GlossConcT m a -> GlossEnv -> m a
runGlossConcT GlossConcT m a
ma GlossEnv
env = FreeAsyncT m a -> m a
forall (m :: * -> *) a. MonadIO m => FreeAsyncT m a -> m a
runFreeAsyncT (FreeAsyncT m a -> m a) -> FreeAsyncT m a -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT GlossEnv (FreeAsyncT m) a -> GlossEnv -> FreeAsyncT m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (GlossConcT m a -> ReaderT GlossEnv (FreeAsyncT m) a
forall (m :: * -> *) a.
GlossConcT m a -> ReaderT GlossEnv (FreeAsyncT m) a
unGlossConcT GlossConcT m a
ma) GlossEnv
env

-- | Disregards scheduling capabilities of @m@, as it uses 'FreeAsync'.
instance (MonadIO m) => MonadSchedule (GlossConcT m) where
  schedule :: forall a.
NonEmpty (GlossConcT m a)
-> GlossConcT m (NonEmpty a, [GlossConcT m a])
schedule NonEmpty (GlossConcT m a)
actions = ReaderT GlossEnv (FreeAsyncT m) (NonEmpty a, [GlossConcT m a])
-> GlossConcT m (NonEmpty a, [GlossConcT m a])
forall (m :: * -> *) a.
ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
GlossConcT (ReaderT GlossEnv (FreeAsyncT m) (NonEmpty a, [GlossConcT m a])
 -> GlossConcT m (NonEmpty a, [GlossConcT m a]))
-> ReaderT GlossEnv (FreeAsyncT m) (NonEmpty a, [GlossConcT m a])
-> GlossConcT m (NonEmpty a, [GlossConcT m a])
forall a b. (a -> b) -> a -> b
$ ((NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
 -> (NonEmpty a, [GlossConcT m a]))
-> ReaderT
     GlossEnv
     (FreeAsyncT m)
     (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
-> ReaderT GlossEnv (FreeAsyncT m) (NonEmpty a, [GlossConcT m a])
forall a b.
(a -> b)
-> ReaderT GlossEnv (FreeAsyncT m) a
-> ReaderT GlossEnv (FreeAsyncT m) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([ReaderT GlossEnv (FreeAsyncT m) a] -> [GlossConcT m a])
-> (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
-> (NonEmpty a, [GlossConcT m a])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([ReaderT GlossEnv (FreeAsyncT m) a] -> [GlossConcT m a])
 -> (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
 -> (NonEmpty a, [GlossConcT m a]))
-> ([ReaderT GlossEnv (FreeAsyncT m) a] -> [GlossConcT m a])
-> (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
-> (NonEmpty a, [GlossConcT m a])
forall a b. (a -> b) -> a -> b
$ (ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a)
-> [ReaderT GlossEnv (FreeAsyncT m) a] -> [GlossConcT m a]
forall a b. (a -> b) -> [a] -> [b]
map ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
forall (m :: * -> *) a.
ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
GlossConcT) (ReaderT
   GlossEnv
   (FreeAsyncT m)
   (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
 -> ReaderT GlossEnv (FreeAsyncT m) (NonEmpty a, [GlossConcT m a]))
-> ReaderT
     GlossEnv
     (FreeAsyncT m)
     (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
-> ReaderT GlossEnv (FreeAsyncT m) (NonEmpty a, [GlossConcT m a])
forall a b. (a -> b) -> a -> b
$ NonEmpty (ReaderT GlossEnv (FreeAsyncT m) a)
-> ReaderT
     GlossEnv
     (FreeAsyncT m)
     (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
forall a.
NonEmpty (ReaderT GlossEnv (FreeAsyncT m) a)
-> ReaderT
     GlossEnv
     (FreeAsyncT m)
     (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule (NonEmpty (ReaderT GlossEnv (FreeAsyncT m) a)
 -> ReaderT
      GlossEnv
      (FreeAsyncT m)
      (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a]))
-> NonEmpty (ReaderT GlossEnv (FreeAsyncT m) a)
-> ReaderT
     GlossEnv
     (FreeAsyncT m)
     (NonEmpty a, [ReaderT GlossEnv (FreeAsyncT m) a])
forall a b. (a -> b) -> a -> b
$ GlossConcT m a -> ReaderT GlossEnv (FreeAsyncT m) a
forall (m :: * -> *) a.
GlossConcT m a -> ReaderT GlossEnv (FreeAsyncT m) a
unGlossConcT (GlossConcT m a -> ReaderT GlossEnv (FreeAsyncT m) a)
-> NonEmpty (GlossConcT m a)
-> NonEmpty (ReaderT GlossEnv (FreeAsyncT m) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (GlossConcT m a)
actions

withPicRef ::
  (MonadIO m) =>
  (IORef Picture -> IO a) ->
  GlossConcT m a
withPicRef :: forall (m :: * -> *) a.
MonadIO m =>
(IORef Picture -> IO a) -> GlossConcT m a
withPicRef IORef Picture -> IO a
action = ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
forall (m :: * -> *) a.
ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
GlossConcT (ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a)
-> ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
forall a b. (a -> b) -> a -> b
$ do
  GlossEnv {IORef Picture
picRef :: GlossEnv -> IORef Picture
picRef :: IORef Picture
picRef} <- ReaderT GlossEnv (FreeAsyncT m) GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO a -> ReaderT GlossEnv (FreeAsyncT m) a
forall a. IO a -> ReaderT GlossEnv (FreeAsyncT m) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT GlossEnv (FreeAsyncT m) a)
-> IO a -> ReaderT GlossEnv (FreeAsyncT 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 :: forall (m :: * -> *). MonadIO m => 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 :: forall (m :: * -> *). MonadIO m => 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 :: forall (m :: * -> *). MonadIO m => Picture -> GlossConcT m ()
paintAllIO 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 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Picture
ref Picture
pic

-- * Gloss clocks in 'IO'

{- | Concurrently block on @gloss@ events.

Caution: Currently, you should only add one such clock in a 'Rhine'.
If you add several 'GlossEventClockIO', only one will be chosen at random and receive the event.
See https://github.com/turion/rhine/issues/330.
-}
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
_ = (Automaton (GlossConcT m) () (Float, Event), Float)
-> GlossConcT m (Automaton (GlossConcT m) () (Float, Event), Float)
forall a. a -> GlossConcT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GlossConcT m (Float, Event)
-> Automaton (GlossConcT m) () (Float, Event)
forall (m :: * -> *) b a. Functor m => m b -> Automaton m a b
constM GlossConcT m (Float, Event)
getEvent, Float
0)
    where
      getEvent :: GlossConcT m (Float, Event)
getEvent = do
        GlossEnv {MVar Event
eventVar :: GlossEnv -> MVar Event
eventVar :: MVar Event
eventVar, IORef Float
timeRef :: GlossEnv -> IORef Float
timeRef :: IORef Float
timeRef} <- ReaderT GlossEnv (FreeAsyncT m) GlossEnv -> GlossConcT m GlossEnv
forall (m :: * -> *) a.
ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
GlossConcT ReaderT GlossEnv (FreeAsyncT m) GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        Event
event <- ReaderT GlossEnv (FreeAsyncT m) Event -> GlossConcT m Event
forall (m :: * -> *) a.
ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
GlossConcT (ReaderT GlossEnv (FreeAsyncT m) Event -> GlossConcT m Event)
-> ReaderT GlossEnv (FreeAsyncT m) Event -> GlossConcT m Event
forall a b. (a -> b) -> a -> b
$ FreeAsyncT m Event -> ReaderT GlossEnv (FreeAsyncT m) Event
forall (m :: * -> *) a. Monad m => m a -> ReaderT GlossEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FreeAsyncT m Event -> ReaderT GlossEnv (FreeAsyncT m) Event)
-> FreeAsyncT m Event -> ReaderT GlossEnv (FreeAsyncT m) Event
forall a b. (a -> b) -> a -> b
$ MVar Event -> FreeAsyncT m Event
forall a (m :: * -> *). MVar a -> FreeAsyncT m a
asyncMVar MVar Event
eventVar
        IO (Float, Event) -> GlossConcT m (Float, Event)
forall a. IO a -> GlossConcT m a
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
          Float
time <- IORef Float -> IO Float
forall a. IORef a -> IO a
readIORef IORef Float
timeRef
          (Float, Event) -> IO (Float, Event)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Float
time, Event
event)

instance GetClockProxy GlossEventClockIO

{- | Concurrently block on @gloss@ simulation ticks.

Caution: Currently, you should only add one such clock in a 'Rhine'.
If you add several 'GlossSimClockIO', only one will be chosen at random and receive the event.
See https://github.com/turion/rhine/issues/330.
-}
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
_ = (Automaton (GlossConcT m) () (Float, ()), Float)
-> GlossConcT m (Automaton (GlossConcT m) () (Float, ()), Float)
forall a. a -> GlossConcT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GlossConcT m Float -> Automaton (GlossConcT m) () Float
forall (m :: * -> *) b a. Functor m => m b -> Automaton m a b
constM GlossConcT m Float
getTime Automaton (GlossConcT m) () Float
-> Automaton (GlossConcT m) () ()
-> Automaton (GlossConcT m) () (Float, ())
forall b c c'.
Automaton (GlossConcT m) b c
-> Automaton (GlossConcT m) b c'
-> Automaton (GlossConcT m) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (() -> ()) -> Automaton (GlossConcT m) () ()
forall b c. (b -> c) -> Automaton (GlossConcT m) b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (() -> () -> ()
forall a b. a -> b -> a
const ()), Float
0)
    where
      getTime :: GlossConcT m Float
getTime = ReaderT GlossEnv (FreeAsyncT m) Float -> GlossConcT m Float
forall (m :: * -> *) a.
ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
GlossConcT (ReaderT GlossEnv (FreeAsyncT m) Float -> GlossConcT m Float)
-> ReaderT GlossEnv (FreeAsyncT m) Float -> GlossConcT m Float
forall a b. (a -> b) -> a -> b
$ do
        GlossEnv {MVar Float
timeVar :: GlossEnv -> MVar Float
timeVar :: MVar Float
timeVar} <- ReaderT GlossEnv (FreeAsyncT m) GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        FreeAsyncT m Float -> ReaderT GlossEnv (FreeAsyncT m) Float
forall (m :: * -> *) a. Monad m => m a -> ReaderT GlossEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FreeAsyncT m Float -> ReaderT GlossEnv (FreeAsyncT m) Float)
-> FreeAsyncT m Float -> ReaderT GlossEnv (FreeAsyncT m) Float
forall a b. (a -> b) -> a -> b
$ MVar Float -> FreeAsyncT m Float
forall a (m :: * -> *). MVar a -> FreeAsyncT m a
asyncMVar MVar Float
timeVar

instance GetClockProxy GlossSimClockIO

-- * Reactimation

{- | Create the concurrent variables to communicate with the @gloss@ backend.

You will usually not need this function, have a look at 'launchInGlossThread' and 'flowGlossIO' instead.
-}
makeGlossEnv ::
  (MonadIO m) =>
  m GlossEnv
makeGlossEnv :: forall (m :: * -> *). MonadIO m => m GlossEnv
makeGlossEnv = IO GlossEnv -> m GlossEnv
forall a. IO a -> m a
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 Picture -> IORef Float -> GlossEnv
GlossEnv (MVar Float
 -> MVar Event -> IORef Picture -> IORef Float -> GlossEnv)
-> IO (MVar Float)
-> IO (MVar Event -> IORef Picture -> IORef Float -> 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 Picture -> IORef Float -> GlossEnv)
-> IO (MVar Event) -> IO (IORef Picture -> IORef Float -> GlossEnv)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (MVar Event)
forall a. IO (MVar a)
newEmptyMVar IO (IORef Picture -> IORef Float -> GlossEnv)
-> IO (IORef Picture) -> IO (IORef Float -> GlossEnv)
forall a b. IO (a -> b) -> IO a -> IO b
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 IO (IORef Float -> GlossEnv) -> IO (IORef Float) -> IO GlossEnv
forall a b. IO (a -> b) -> IO a -> IO b
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

{- | Helper function for 'launchInGlossThread'.

Creates concurrent variables and launches the @gloss@ backend in a separate thread.
-}
launchGlossThread ::
  (MonadIO m) =>
  GlossSettings ->
  m GlossEnv
launchGlossThread :: forall (m :: * -> *). MonadIO m => GlossSettings -> m GlossEnv
launchGlossThread GlossSettings {Int
Color
Display
display :: Display
backgroundColor :: Color
stepsPerSecond :: Int
display :: GlossSettings -> Display
backgroundColor :: GlossSettings -> Color
stepsPerSecond :: GlossSettings -> Int
..} = do
  GlossEnv
vars <- m GlossEnv
forall (m :: * -> *). MonadIO m => m GlossEnv
makeGlossEnv
  let
    getPic :: GlossEnv -> IO Picture
getPic GlossEnv {IORef Picture
picRef :: GlossEnv -> IORef Picture
picRef :: IORef Picture
picRef} = IORef Picture -> IO Picture
forall a. IORef a -> IO a
readIORef IORef Picture
picRef
    handleEvent :: Event -> GlossEnv -> IO GlossEnv
handleEvent Event
event vars :: GlossEnv
vars@GlossEnv {MVar Event
eventVar :: GlossEnv -> MVar Event
eventVar :: MVar Event
eventVar} = do
      IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ -- Perform non-blocking so other actions are not delayed
          IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
            Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
100000 (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ -- timeout in case noone is listening for events
              MVar Event -> Event -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Event
eventVar Event
event
      GlossEnv -> IO GlossEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GlossEnv
vars
    simStep :: Float -> GlossEnv -> IO GlossEnv
simStep Float
diffTime vars :: GlossEnv
vars@GlossEnv {MVar Float
timeVar :: GlossEnv -> MVar Float
timeVar :: MVar Float
timeVar, IORef Float
timeRef :: GlossEnv -> IORef Float
timeRef :: IORef Float
timeRef} = do
      Float
time <- IORef Float -> IO Float
forall a. IORef a -> IO a
readIORef IORef Float
timeRef
      let !time' :: Float
time' = Float
time Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
diffTime
      -- We don't do this in a separate thread, because forkIO putMVar would create a race condition on putting the MVar,
      -- which can lead to non-monotonous time updates.
      MVar Float -> Float -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar Float
timeVar Float
time'
      IORef Float -> Float -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Float
timeRef Float
time'
      GlossEnv -> IO GlossEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GlossEnv
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 a. IO a -> m a
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
getPic Event -> GlossEnv -> IO GlossEnv
handleEvent Float -> GlossEnv -> IO GlossEnv
simStep
  GlossEnv -> m GlossEnv
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return GlossEnv
vars

{- | 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.
-}
launchInGlossThread ::
  (MonadIO m) =>
  GlossSettings ->
  GlossConcT m a ->
  m a
launchInGlossThread :: forall (m :: * -> *) a.
MonadIO m =>
GlossSettings -> GlossConcT m a -> m a
launchInGlossThread GlossSettings
settings GlossConcT m a
glossLoop = do
  GlossEnv
vars <- GlossSettings -> m GlossEnv
forall (m :: * -> *). MonadIO m => GlossSettings -> m GlossEnv
launchGlossThread GlossSettings
settings
  GlossConcT m a -> GlossEnv -> m a
forall (m :: * -> *) a.
MonadIO m =>
GlossConcT m a -> GlossEnv -> m a
runGlossConcT 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 ::
  ( MonadIO m
  , Clock (GlossConcT m) cl
  , GetClockProxy cl
  , Time cl ~ Time (In cl)
  , Time cl ~ Time (Out cl)
  ) =>
  GlossSettings ->
  Rhine (GlossConcT m) cl () () ->
  m ()
flowGlossIO :: forall (m :: * -> *) cl.
(MonadIO m, Clock (GlossConcT m) cl, GetClockProxy cl,
 Time cl ~ Time (In cl), Time cl ~ Time (Out cl)) =>
GlossSettings -> Rhine (GlossConcT m) cl () () -> m ()
flowGlossIO GlossSettings
settings = GlossSettings -> GlossConcT m () -> m ()
forall (m :: * -> *) a.
MonadIO m =>
GlossSettings -> GlossConcT m a -> m a
launchInGlossThread GlossSettings
settings (GlossConcT m () -> m ())
-> (Rhine (GlossConcT m) cl () () -> GlossConcT m ())
-> Rhine (GlossConcT m) cl () ()
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rhine (GlossConcT m) cl () () -> GlossConcT m ()
forall (m :: * -> *) cl void.
(Monad m, Clock m cl, GetClockProxy cl, Time cl ~ Time (In cl),
 Time cl ~ Time (Out cl)) =>
Rhine m cl () () -> m void
flow

{- | Apply this wrapper to your clock type @cl@ in order to escape the 'GlossConcT' transformer.
  The resulting clock will be in @m@, not 'GlossConcT m' anymore.
  Typically, @m@ will have the 'MonadIO' constraint.
-}
type RunGlossEnvClock m cl = HoistClock (GlossConcT m) m cl

{- | Apply to a gloss clock to remove a 'GlossConcT' layer.
  You will have to have initialized a 'GlossEnv', for example by calling 'launchGlossThread'.
-}
runGlossEnvClock ::
  (MonadIO m) =>
  GlossEnv ->
  cl ->
  RunGlossEnvClock m cl
runGlossEnvClock :: forall (m :: * -> *) cl.
MonadIO m =>
GlossEnv -> cl -> RunGlossEnvClock m cl
runGlossEnvClock GlossEnv
env cl
unhoistedClock =
  HoistClock
    { monadMorphism :: forall a. GlossConcT m a -> m a
monadMorphism = (GlossConcT m a -> GlossEnv -> m a)
-> GlossEnv -> GlossConcT m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip GlossConcT m a -> GlossEnv -> m a
forall (m :: * -> *) a.
MonadIO m =>
GlossConcT m a -> GlossEnv -> m a
runGlossConcT GlossEnv
env
    , cl
unhoistedClock :: cl
unhoistedClock :: cl
..
    }

-- * Lifting clocks to 'GlossConcT'

{- | Lift a 'MonadIO' clock to 'GlossConcT'.

You should use this instead of 'IOClock', otherwise scheduling will probably not work.
(This is because 'GlossConcT' uses 'FreeAsyncT', but 'liftIO' is not asynchronous.)
-}
type GlossConcTClock m = HoistClock IO (GlossConcT m)

-- | A 'MonadIO' clock lifted to 'GlossConcT'.
glossConcTClock :: (MonadIO m) => cl -> GlossConcTClock m cl
glossConcTClock :: forall (m :: * -> *) cl. MonadIO m => cl -> GlossConcTClock m cl
glossConcTClock cl
unhoistedClock =
  HoistClock
    { cl
unhoistedClock :: cl
unhoistedClock :: cl
unhoistedClock
    , monadMorphism :: forall a. IO a -> GlossConcT m a
monadMorphism = ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
forall (m :: * -> *) a.
ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a
GlossConcT (ReaderT GlossEnv (FreeAsyncT m) a -> GlossConcT m a)
-> (IO a -> ReaderT GlossEnv (FreeAsyncT m) a)
-> IO a
-> GlossConcT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeAsyncT m a -> ReaderT GlossEnv (FreeAsyncT m) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT GlossEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FreeAsyncT m a -> ReaderT GlossEnv (FreeAsyncT m) a)
-> (IO a -> FreeAsyncT m a)
-> IO a
-> ReaderT GlossEnv (FreeAsyncT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> FreeAsyncT m a
forall (m :: * -> *) a. MonadIO m => IO a -> FreeAsyncT m a
freeAsync
    }

{- | Lift an 'IO' clock to 'GlossConc'.

See 'GlossConcTClock'.
-}
type GlossConcClock = GlossConcTClock IO

-- | An 'IO' clock lifted to 'GlossConc'.
glossConcClock :: cl -> GlossConcClock cl
glossConcClock :: forall cl. cl -> GlossConcClock cl
glossConcClock = cl -> GlossConcTClock IO cl
forall (m :: * -> *) cl. MonadIO m => cl -> GlossConcTClock m cl
glossConcTClock

-- * Rescaled clocks in other time domains

{- | Rescale a gloss clock like 'GlossSimClockIO' or 'GlossEventClockIO' to 'UTCTime'.

This is needed for compatibility with other realtime clocks like 'Millisecond'.
-}
type GlossClockUTC m cl = UTCClock (GlossConcT m) cl

{- | Rescale a gloss clock like 'GlossSimClockIO' or 'GlossEventClockIO' to 'UTCTime'.

Uses 'addUTC'. For other strategies to rescale a gloss clock to 'UTCTime',
see "FRP.Rhine.Clock.Realtime".
-}
glossClockUTC :: (MonadIO m, Real (Time cl)) => cl -> GlossClockUTC m cl
glossClockUTC :: forall (m :: * -> *) cl.
(MonadIO m, Real (Time cl)) =>
cl -> GlossClockUTC m cl
glossClockUTC = cl -> UTCClock (GlossConcT m) cl
forall cl (m :: * -> *).
(Real (Time cl), MonadIO m) =>
cl -> UTCClock m cl
addUTC