module Eve.Internal.Listeners
( HasEvents
, dispatchEvent
, dispatchEvent_
, dispatchLocalEvent
, dispatchLocalEvent_
, dispatchEventAsync
, addListener
, addListener_
, addLocalListener
, addLocalListener_
, removeListener
, removeLocalListener
, asyncEventProvider
, afterInit
, beforeEvent
, beforeEvent_
, afterEvent
, afterEvent_
, onExit
, Listener
, ListenerId
, EventDispatcher
) where
import Eve.Internal.States
import Eve.Internal.Async
import Eve.Internal.Actions
import Eve.Internal.Events
import Control.Monad.State
import Control.Lens
import Data.Default
import Data.Typeable
import Data.Maybe
import qualified Data.Map as M
afterInit :: forall base m a. (Monad m, HasEvents base, Typeable m) => AppT base m a -> AppT base m ()
afterInit action = addListener_ (const (void action) :: AfterInit -> AppT base m ())
beforeEvent :: forall base zoomed m a. (Monad m, HasEvents base, Typeable m) => AppT base m a -> ActionT base zoomed m ListenerId
beforeEvent action = addListener (const (void action) :: BeforeEvent -> AppT base m ())
beforeEvent_ :: (Monad m, HasEvents base, Typeable m) => AppT base m a -> ActionT base zoomed m ()
beforeEvent_ = void . beforeEvent
afterEvent :: forall base zoomed m a. (Monad m, HasEvents base, Typeable m) => AppT base m a -> ActionT base zoomed m ListenerId
afterEvent action = addListener (const (void action) :: AfterEvent -> AppT base m ())
afterEvent_ :: (Monad m, HasEvents base, Typeable m) => AppT base m a -> ActionT base zoomed m ()
afterEvent_ = void . afterEvent
onExit :: forall base zoomed m a. (HasEvents base, Typeable m, Monad m) => AppT base m a -> ActionT base zoomed m ()
onExit action = addListener_ (const (void action) :: Exit -> AppT base m ())
dispatchLocalEvent
:: forall result eventType m s.
(MonadState s m
,HasEvents s
,Monoid result
,Typeable m
,Typeable eventType
,Typeable result)
=> eventType -> m result
dispatchLocalEvent evt = do
LocalListeners _ listeners <- use localListeners
results <-
traverse ($ evt) (matchingListeners listeners :: [eventType -> m result])
return (mconcat results :: result)
dispatchLocalEvent_
:: forall eventType m s.
(MonadState s m
,HasEvents s
,Typeable m
,Typeable eventType)
=> eventType -> m ()
dispatchLocalEvent_ = dispatchLocalEvent
dispatchEvent
:: forall result eventType m base zoomed.
(HasEvents base
,Monoid result
,Monad m
,Typeable m
,Typeable eventType
,Typeable result)
=> eventType -> ActionT base zoomed m result
dispatchEvent evt = runApp $ dispatchLocalEvent evt
dispatchEvent_
:: forall eventType m base zoomed.
(HasEvents base
,Monad m
,Typeable m
,Typeable eventType)
=> eventType -> ActionT base zoomed m ()
dispatchEvent_ = dispatchEvent
addLocalListener
:: forall result eventType m s.
(MonadState s m
,HasEvents s
,Typeable m
,Typeable eventType
,Typeable result
,Monoid result)
=> (eventType -> m result) -> m ListenerId
addLocalListener lFunc = do
LocalListeners nextListenerId listeners <- use localListeners
let (listener, listenerId, eventType) = mkListener nextListenerId lFunc
newListeners = M.insertWith mappend eventType [listener] listeners
localListeners .= LocalListeners (nextListenerId + 1) newListeners
return listenerId
where
mkListener
:: forall event r.
(Typeable event, Typeable r, Monoid r)
=> Int -> (event -> m r) -> (Listener, ListenerId, TypeRep)
mkListener n listenerFunc =
let list = Listener (typeOf listenerFunc) listId listenerFunc
listId = ListenerId n (typeRep (Proxy :: Proxy event))
prox = typeRep (Proxy :: Proxy event)
in (list, listId, prox)
addLocalListener_
:: forall result eventType m s.
(MonadState s m
,HasEvents s
,Typeable m
,Typeable eventType
,Typeable result
,Monoid result)
=> (eventType -> m result) -> m ()
addLocalListener_ = void . addLocalListener
addListener
:: forall result eventType m base zoomed.
(HasEvents base
,Monad m
,Typeable m
,Typeable eventType
,Typeable result
,Monoid result)
=> (eventType -> AppT base m result) -> ActionT base zoomed m ListenerId
addListener = runApp . addLocalListener
addListener_
:: forall result eventType m base zoomed.
(HasEvents base
,Monad m
,Typeable m
,Typeable eventType
,Typeable result
,Monoid result)
=> (eventType -> AppT base m result) -> ActionT base zoomed m ()
addListener_ = void . addListener
removeLocalListener
:: (MonadState s m, HasEvents s)
=> ListenerId -> m ()
removeLocalListener listenerId@(ListenerId _ eventType) = localListeners %= remover
where
remover (LocalListeners nextListenerId listeners) =
let newListeners =
listeners & at eventType . _Just %~ filter (notMatch listenerId)
in LocalListeners nextListenerId newListeners
notMatch idA (Listener _ idB _) = idA /= idB
removeListener
:: (HasEvents base
,Monad m)
=> ListenerId -> ActionT base zoomed m ()
removeListener = runApp . removeLocalListener
dispatchEventAsync
:: (Typeable event
,MonadIO m
,Typeable m
,HasEvents base
) => IO event -> ActionT base zoomed m ()
dispatchEventAsync ioEvent = dispatchActionAsync $ dispatchEvent <$> ioEvent
data Listener where
Listener ::
(MonadState s m, Typeable m, Typeable eventType, Typeable result,
Monoid result, HasStates s) =>
TypeRep -> ListenerId -> (eventType -> m result) -> Listener
data ListenerId =
ListenerId Int
TypeRep
instance Eq ListenerId where
ListenerId a _ == ListenerId b _ = a == b
type Listeners = M.Map TypeRep [Listener]
data LocalListeners =
LocalListeners Int
Listeners
instance Default LocalListeners where
def = LocalListeners 0 M.empty
localListeners
:: HasStates s
=> Lens' s LocalListeners
localListeners = stateLens
matchingListeners
:: forall m eventType result.
(Typeable m
,Typeable eventType
,Typeable result)
=> Listeners -> [eventType -> m result]
matchingListeners listeners =
catMaybes $ (getListener :: Listener -> Maybe (eventType -> m result)) <$>
(listeners ^. at (typeRep (Proxy :: Proxy eventType)) . _Just)
getListener
:: Typeable expected
=> Listener -> Maybe expected
getListener (Listener _ _ x) = cast x
type EventDispatcher = forall event. Typeable event =>
event -> IO ()
asyncEventProvider
:: (HasEvents base, MonadIO m, Typeable m) => (EventDispatcher -> IO ()) -> ActionT base zoomed m ()
asyncEventProvider asyncEventProv = asyncActionProvider $ eventsToActions asyncEventProv
where
eventsToActions :: (Monad m, HasEvents base, Typeable m) => (EventDispatcher -> IO ()) -> (AppT base m () -> IO ()) -> IO ()
eventsToActions aEventProv dispatcher =
aEventProv (dispatcher . dispatchEvent)