{- |
This module provides two things:

* Clocks that tick whenever events arrive on a 'Control.Concurrent.Chan',
  and useful utilities.
* Primitives to emit events.

Note that _events work across multiple clocks_,
i.e. it is possible (and encouraged) to emit events from signals
on a different clock than the event clock.
This is in line with the Rhine philosophy that _event sources are clocks_.

Events even work well across separate threads,
and constitute the recommended way of communication between threads in Rhine.

A simple example using events and threads can be found in rhine-examples.
-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module FRP.Rhine.Clock.Realtime.Event
  ( module FRP.Rhine.Clock.Realtime.Event
  , module Control.Monad.IO.Class
  , newChan
  )
  where

-- base
import Control.Concurrent.Chan
import Data.Time.Clock

-- deepseq
import Control.DeepSeq

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

-- rhine
import FRP.Rhine.Clock.Proxy
import FRP.Rhine.ClSF
import FRP.Rhine.Schedule
import FRP.Rhine.Schedule.Concurrently



-- * Monads allowing for event emission and handling

-- | A monad transformer in which events can be emitted onto a 'Chan'.
type EventChanT event m = ReaderT (Chan event) m

-- | Escape the 'EventChanT' layer by explicitly providing a channel
--   over which events are sent.
--   Often this is not needed, and 'runEventChanT' can be used instead.
withChan :: Chan event -> EventChanT event m a -> m a
withChan :: Chan event -> EventChanT event m a -> m a
withChan = (EventChanT event m a -> Chan event -> m a)
-> Chan event -> EventChanT event m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip EventChanT event m a -> Chan event -> m a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT

{- | Create a channel across which events can be communicated,
and subsequently execute all event effects on this channel.

Ideally, this action is run _outside_ of 'flow',
e.g. @runEventChanT $ flow myRhine@.
This way, exactly one channel is created.

Caution: Don't use this with 'morphS',
since it would create a new channel every tick.
Instead, create one @chan :: Chan c@, e.g. with 'newChan',
and then use 'withChanS'.
-}
runEventChanT :: MonadIO m => EventChanT event m a -> m a
runEventChanT :: EventChanT event m a -> m a
runEventChanT EventChanT event m a
a = do
  Chan event
chan <- IO (Chan event) -> m (Chan event)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Chan event) -> m (Chan event))
-> IO (Chan event) -> m (Chan event)
forall a b. (a -> b) -> a -> b
$ IO (Chan event)
forall a. IO (Chan a)
newChan
  EventChanT event m a -> Chan event -> m a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT EventChanT event m a
a Chan event
chan

{- | Remove ("run") an 'EventChanT' layer from the monad stack
by passing it explicitly the channel over which events are sent.

This is usually only needed if you can't use 'runEventChanT'
to create the channel.
Typically, create a @chan :: Chan c@ in your main program
before the main loop (e.g. 'flow') would be run,
then, by using this function,
pass the channel to every behaviour or 'ClSF' that wants to emit events,
and, by using 'eventClockOn', to every clock that should tick on the event.
-}
withChanS
  :: Monad m
  => Chan event
  -> ClSF (EventChanT event m) cl a b
  -> ClSF m cl a b
withChanS :: Chan event -> ClSF (EventChanT event m) cl a b -> ClSF m cl a b
withChanS = (ClSF (EventChanT event m) cl a b -> Chan event -> ClSF m cl a b)
-> Chan event -> ClSF (EventChanT event m) cl a b -> ClSF m cl a b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClSF (EventChanT event m) cl a b -> Chan event -> ClSF m cl a b
forall (m :: Type -> Type) r cl a b.
Monad m =>
ClSF (ReaderT r m) cl a b -> r -> ClSF m cl a b
runReaderS_

-- * Event emission

{- | Emit a single event.
This causes every 'EventClock' on the same monad to tick immediately.

Be cautious when emitting events from a signal clocked by an 'EventClock'.
Nothing prevents you from emitting more events than are handled,
causing the event buffer to grow indefinitely.
-}
emit :: MonadIO m => event -> EventChanT event m ()
emit :: event -> EventChanT event m ()
emit event
event = do
  Chan event
chan <- ReaderT (Chan event) m (Chan event)
forall (m :: Type -> Type) r. Monad m => ReaderT r m r
ask
  IO () -> EventChanT event m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventChanT event m ()) -> IO () -> EventChanT event m ()
forall a b. (a -> b) -> a -> b
$ Chan event -> event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan event
chan event
event

-- | Emit an event on every tick.
emitS :: MonadIO m => ClSF (EventChanT event m) cl event ()
emitS :: ClSF (EventChanT event m) cl event ()
emitS = (event -> ReaderT (Chan event) m ())
-> ClSF (EventChanT event m) cl event ()
forall (m :: Type -> Type) a b cl.
Monad m =>
(a -> m b) -> ClSF m cl a b
arrMCl event -> ReaderT (Chan event) m ()
forall (m :: Type -> Type) event.
MonadIO m =>
event -> EventChanT event m ()
emit

-- | Emit an event whenever the input value is @Just event@.
emitSMaybe :: MonadIO m => ClSF (EventChanT event m) cl (Maybe event) ()
emitSMaybe :: ClSF (EventChanT event m) cl (Maybe event) ()
emitSMaybe = ClSF (EventChanT event m) cl event ()
-> ClSF (EventChanT event m) cl (Maybe event) (Maybe ())
forall (m :: Type -> Type) cl a b.
Monad m =>
ClSF m cl a b -> ClSF m cl (Maybe a) (Maybe b)
mapMaybe ClSF (EventChanT event m) cl event ()
forall (m :: Type -> Type) event cl.
MonadIO m =>
ClSF (EventChanT event m) cl event ()
emitS ClSF (EventChanT event m) cl (Maybe event) (Maybe ())
-> MSF (ReaderT (TimeInfo cl) (EventChanT event m)) (Maybe ()) ()
-> ClSF (EventChanT event m) cl (Maybe event) ()
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe () -> ())
-> MSF (ReaderT (TimeInfo cl) (EventChanT event m)) (Maybe ()) ()
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (() -> Maybe () -> ()
forall a b. a -> b -> a
const ())

-- | Like 'emit', but completely evaluates the event before emitting it.
emit' :: (NFData event, MonadIO m) => event -> EventChanT event m ()
emit' :: event -> EventChanT event m ()
emit' event
event = event
event event -> EventChanT event m () -> EventChanT event m ()
forall a b. NFData a => a -> b -> b
`deepseq` do
  Chan event
chan <- ReaderT (Chan event) m (Chan event)
forall (m :: Type -> Type) r. Monad m => ReaderT r m r
ask
  IO () -> EventChanT event m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventChanT event m ()) -> IO () -> EventChanT event m ()
forall a b. (a -> b) -> a -> b
$ Chan event -> event -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan event
chan event
event

-- | Like 'emitS', but completely evaluates the event before emitting it.
emitS' :: (NFData event, MonadIO m) => ClSF (EventChanT event m) cl event ()
emitS' :: ClSF (EventChanT event m) cl event ()
emitS' = (event -> ReaderT (Chan event) m ())
-> ClSF (EventChanT event m) cl event ()
forall (m :: Type -> Type) a b cl.
Monad m =>
(a -> m b) -> ClSF m cl a b
arrMCl event -> ReaderT (Chan event) m ()
forall event (m :: Type -> Type).
(NFData event, MonadIO m) =>
event -> EventChanT event m ()
emit'

-- | Like 'emitSMaybe', but completely evaluates the event before emitting it.
emitSMaybe'
  :: (NFData event, MonadIO m)
  => ClSF (EventChanT event m) cl (Maybe event) ()
emitSMaybe' :: ClSF (EventChanT event m) cl (Maybe event) ()
emitSMaybe' = ClSF (EventChanT event m) cl event ()
-> ClSF (EventChanT event m) cl (Maybe event) (Maybe ())
forall (m :: Type -> Type) cl a b.
Monad m =>
ClSF m cl a b -> ClSF m cl (Maybe a) (Maybe b)
mapMaybe ClSF (EventChanT event m) cl event ()
forall event (m :: Type -> Type) cl.
(NFData event, MonadIO m) =>
ClSF (EventChanT event m) cl event ()
emitS' ClSF (EventChanT event m) cl (Maybe event) (Maybe ())
-> MSF (ReaderT (TimeInfo cl) (EventChanT event m)) (Maybe ()) ()
-> ClSF (EventChanT event m) cl (Maybe event) ()
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe () -> ())
-> MSF (ReaderT (TimeInfo cl) (EventChanT event m)) (Maybe ()) ()
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (() -> Maybe () -> ()
forall a b. a -> b -> a
const ())


-- * Event clocks and schedules

-- | A clock that ticks whenever an @event@ is emitted.
--   It is not yet bound to a specific channel,
--   since ideally, the correct channel is created automatically
--   by 'runEventChanT'.
--   If you want to create the channel manually and bind the clock to it,
--   use 'eventClockOn'.
data EventClock event = EventClock

instance Semigroup (EventClock event) where
  <> :: EventClock event -> EventClock event -> EventClock event
(<>) EventClock event
_ EventClock event
_ = EventClock event
forall event. EventClock event
EventClock

instance MonadIO m => Clock (EventChanT event m) (EventClock event) where
  type Time (EventClock event) = UTCTime
  type Tag  (EventClock event) = event
  initClock :: EventClock event
-> RunningClockInit
     (EventChanT event m)
     (Time (EventClock event))
     (Tag (EventClock event))
initClock EventClock event
_ = do
    UTCTime
initialTime <- IO UTCTime -> ReaderT (Chan event) m UTCTime
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    (MSF (EventChanT event m) () (UTCTime, event), UTCTime)
-> ReaderT
     (Chan event)
     m
     (MSF (EventChanT event m) () (UTCTime, event), UTCTime)
forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( ReaderT (Chan event) m (UTCTime, event)
-> MSF (EventChanT event m) () (UTCTime, event)
forall (m :: Type -> Type) b a. Monad m => m b -> MSF m a b
constM (ReaderT (Chan event) m (UTCTime, event)
 -> MSF (EventChanT event m) () (UTCTime, event))
-> ReaderT (Chan event) m (UTCTime, event)
-> MSF (EventChanT event m) () (UTCTime, event)
forall a b. (a -> b) -> a -> b
$ do
          Chan event
chan  <- ReaderT (Chan event) m (Chan event)
forall (m :: Type -> Type) r. Monad m => ReaderT r m r
ask
          event
event <- IO event -> ReaderT (Chan event) m event
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO event -> ReaderT (Chan event) m event)
-> IO event -> ReaderT (Chan event) m event
forall a b. (a -> b) -> a -> b
$ Chan event -> IO event
forall a. Chan a -> IO a
readChan Chan event
chan
          UTCTime
time  <- IO UTCTime -> ReaderT (Chan event) m UTCTime
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> ReaderT (Chan event) m UTCTime)
-> IO UTCTime -> ReaderT (Chan event) m UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
          (UTCTime, event) -> ReaderT (Chan event) m (UTCTime, event)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (UTCTime
time, event
event)
      , UTCTime
initialTime
      )

instance GetClockProxy (EventClock event)

-- | Create an event clock that is bound to a specific event channel.
--   This is usually only useful if you can't apply 'runEventChanT'
--   to the main loop (see 'withChanS').
eventClockOn
  :: MonadIO m
  => Chan event
  -> HoistClock (EventChanT event m) m (EventClock event)
eventClockOn :: Chan event -> HoistClock (EventChanT event m) m (EventClock event)
eventClockOn Chan event
chan = HoistClock :: forall (m1 :: Type -> Type) (m2 :: Type -> Type) cl.
cl -> (forall a. m1 a -> m2 a) -> HoistClock m1 m2 cl
HoistClock
  { unhoistedClock :: EventClock event
unhoistedClock = EventClock event
forall event. EventClock event
EventClock
  , monadMorphism :: forall a. EventChanT event m a -> m a
monadMorphism  = Chan event -> EventChanT event m a -> m a
forall event (m :: Type -> Type) a.
Chan event -> EventChanT event m a -> m a
withChan Chan event
chan
  }

{- |
Given two clocks with an 'EventChanT' layer directly atop the 'IO' monad,
you can schedule them using concurrent GHC threads,
and share the event channel.

Typical use cases:

* Different subevent selection clocks
  (implemented i.e. with 'FRP.Rhine.Clock.Select')
  on top of the same main event source.
* An event clock and other event-unaware clocks in the 'IO' monad,
  which are lifted using 'liftClock'.
-}
concurrentlyWithEvents
  :: ( Time cl1 ~ Time cl2
     , Clock (EventChanT event IO) cl1
     , Clock (EventChanT event IO) cl2
     )
  => Schedule (EventChanT event IO) cl1 cl2
concurrentlyWithEvents :: Schedule (EventChanT event IO) cl1 cl2
concurrentlyWithEvents = Schedule
  IO
  (HoistClock (EventChanT event IO) IO cl1)
  (HoistClock (EventChanT event IO) IO cl2)
-> Schedule (EventChanT event IO) cl1 cl2
forall (m :: Type -> Type) r cl1 cl2.
(Monad m, Clock (ReaderT r m) cl1, Clock (ReaderT r m) cl2,
 Time cl1 ~ Time cl2) =>
Schedule
  m (HoistClock (ReaderT r m) m cl1) (HoistClock (ReaderT r m) m cl2)
-> Schedule (ReaderT r m) cl1 cl2
readerSchedule Schedule
  IO
  (HoistClock (EventChanT event IO) IO cl1)
  (HoistClock (EventChanT event IO) IO cl2)
forall cl1 cl2.
(Clock IO cl1, Clock IO cl2, Time cl1 ~ Time cl2) =>
Schedule IO cl1 cl2
concurrently