-- | This module defines 'PerformEvent' and 'TriggerEvent', which mediate the
-- interaction between a "Reflex"-based program and the external side-effecting
-- actions such as 'IO'.
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#ifdef USE_REFLEX_OPTIMIZER
{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
#endif
module Reflex.PerformEvent.Class
  ( PerformEvent (..)
  , performEventAsync
  ) where

import Reflex.Class
import Reflex.TriggerEvent.Class

import Control.Monad.Reader
import Control.Monad.Trans.Maybe (MaybeT (..))

-- | 'PerformEvent' represents actions that can trigger other actions based on
-- 'Event's.
class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where
  -- | The type of action to be triggered; this is often not the same type as
  -- the triggering action.
  type Performable m :: * -> *
  -- | Perform the action contained in the given 'Event' whenever the 'Event'
  -- fires.  Return the result in another 'Event'.  Note that the output 'Event'
  -- will generally occur later than the input 'Event', since most 'Performable'
  -- actions cannot be performed during 'Event' propagation.
  performEvent :: Event t (Performable m a) -> m (Event t a)
  -- | Like 'performEvent', but do not return the result.  May have slightly
  -- better performance.
  performEvent_ :: Event t (Performable m ()) -> m ()

-- | Like 'performEvent', but the resulting 'Event' occurs only when the
-- callback (@a -> IO ()@) is called, not when the included action finishes.
--
-- NOTE: Despite the name, 'performEventAsync' does not run its action in a
-- separate thread - although the action is free to invoke forkIO and then call
-- the callback whenever it is ready.  This will work properly, even in GHCJS
-- (which fully implements concurrency even though JavaScript does not have
-- built in concurrency).
{-# INLINABLE performEventAsync #-}
performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)
performEventAsync :: Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)
performEventAsync e :: Event t ((a -> IO ()) -> Performable m ())
e = do
  (eOut :: Event t a
eOut, triggerEOut :: a -> IO ()
triggerEOut) <- m (Event t a, a -> IO ())
forall t (m :: * -> *) a.
TriggerEvent t m =>
m (Event t a, a -> IO ())
newTriggerEvent
  Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ (((a -> IO ()) -> Performable m ()) -> Performable m ())
-> Event t ((a -> IO ()) -> Performable m ())
-> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a -> IO ()) -> Performable m ())
-> (a -> IO ()) -> Performable m ()
forall a b. (a -> b) -> a -> b
$ a -> IO ()
triggerEOut) Event t ((a -> IO ()) -> Performable m ())
e
  Event t a -> m (Event t a)
forall (m :: * -> *) a. Monad m => a -> m a
return Event t a
eOut

instance PerformEvent t m => PerformEvent t (ReaderT r m) where
  type Performable (ReaderT r m) = ReaderT r (Performable m)
  performEvent_ :: Event t (Performable (ReaderT r m) ()) -> ReaderT r m ()
performEvent_ e :: Event t (Performable (ReaderT r m) ())
e = do
    r
r <- ReaderT r m r
forall r (m :: * -> *). MonadReader r m => m r
ask
    m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ()) -> m () -> ReaderT r m ()
forall a b. (a -> b) -> a -> b
$ Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ (ReaderT r (Performable m) () -> r -> Performable m ())
-> r -> ReaderT r (Performable m) () -> Performable m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT r (Performable m) () -> r -> Performable m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT r
r (ReaderT r (Performable m) () -> Performable m ())
-> Event t (ReaderT r (Performable m) ())
-> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t (ReaderT r (Performable m) ())
Event t (Performable (ReaderT r m) ())
e
  performEvent :: Event t (Performable (ReaderT r m) a) -> ReaderT r m (Event t a)
performEvent e :: Event t (Performable (ReaderT r m) a)
e = do
    r
r <- ReaderT r m r
forall r (m :: * -> *). MonadReader r m => m r
ask
    m (Event t a) -> ReaderT r m (Event t a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Event t a) -> ReaderT r m (Event t a))
-> m (Event t a) -> ReaderT r m (Event t a)
forall a b. (a -> b) -> a -> b
$ Event t (Performable m a) -> m (Event t a)
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m a) -> m (Event t a))
-> Event t (Performable m a) -> m (Event t a)
forall a b. (a -> b) -> a -> b
$ (ReaderT r (Performable m) a -> r -> Performable m a)
-> r -> ReaderT r (Performable m) a -> Performable m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT r (Performable m) a -> r -> Performable m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT r
r (ReaderT r (Performable m) a -> Performable m a)
-> Event t (ReaderT r (Performable m) a)
-> Event t (Performable m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t (ReaderT r (Performable m) a)
Event t (Performable (ReaderT r m) a)
e

instance PerformEvent t m => PerformEvent t (MaybeT m) where
  type Performable (MaybeT m) = MaybeT (Performable m)
  performEvent_ :: Event t (Performable (MaybeT m) ()) -> MaybeT m ()
performEvent_ = m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ())
-> (Event t (MaybeT (Performable m) ()) -> m ())
-> Event t (MaybeT (Performable m) ())
-> MaybeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> (Event t (MaybeT (Performable m) ())
    -> Event t (Performable m ()))
-> Event t (MaybeT (Performable m) ())
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MaybeT (Performable m) () -> Performable m ())
-> Event t (MaybeT (Performable m) ())
-> Event t (Performable m ())
forall k (t :: k) a b.
Reflex t =>
(a -> b) -> Event t a -> Event t b
fmapCheap (Performable m (Maybe ()) -> Performable m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Performable m (Maybe ()) -> Performable m ())
-> (MaybeT (Performable m) () -> Performable m (Maybe ()))
-> MaybeT (Performable m) ()
-> Performable m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT (Performable m) () -> Performable m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT)
  performEvent :: Event t (Performable (MaybeT m) a) -> MaybeT m (Event t a)
performEvent = m (Event t a) -> MaybeT m (Event t a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Event t a) -> MaybeT m (Event t a))
-> (Event t (MaybeT (Performable m) a) -> m (Event t a))
-> Event t (MaybeT (Performable m) a)
-> MaybeT m (Event t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event t (Maybe a) -> Event t a)
-> m (Event t (Maybe a)) -> m (Event t a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe a -> Maybe a) -> Event t (Maybe a) -> Event t a
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
fmapMaybe Maybe a -> Maybe a
forall a. a -> a
id) (m (Event t (Maybe a)) -> m (Event t a))
-> (Event t (MaybeT (Performable m) a) -> m (Event t (Maybe a)))
-> Event t (MaybeT (Performable m) a)
-> m (Event t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event t (Performable m (Maybe a)) -> m (Event t (Maybe a))
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m (Maybe a)) -> m (Event t (Maybe a)))
-> (Event t (MaybeT (Performable m) a)
    -> Event t (Performable m (Maybe a)))
-> Event t (MaybeT (Performable m) a)
-> m (Event t (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MaybeT (Performable m) a -> Performable m (Maybe a))
-> Event t (MaybeT (Performable m) a)
-> Event t (Performable m (Maybe a))
forall k (t :: k) a b.
Reflex t =>
(a -> b) -> Event t a -> Event t b
fmapCheap MaybeT (Performable m) a -> Performable m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT