module Eve.Internal.Listeners
( HasEvents
, dispatchEvent
, dispatchEvent_
, dispatchEventAsync
, addListener
, addListener_
, removeListener
, asyncEventProvider
, onInit
, afterInit
, beforeEvent
, beforeEvent_
, afterEvent
, afterEvent_
, onExit
, Listener
, ListenerId
) where
import Eve.Internal.Extensions
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
onInit :: App result -> App ()
onInit action = void $ addListener (const (void action) :: Init -> App ())
afterInit :: App a -> App ()
afterInit action = void $ addListener (const (void action) :: AfterInit -> App ())
beforeEvent :: App a -> App ListenerId
beforeEvent action = addListener (const (void action) :: BeforeEvent -> App ())
beforeEvent_ :: App a -> App ()
beforeEvent_ = void . beforeEvent
afterEvent :: App a -> App ListenerId
afterEvent action = addListener (const (void action) :: AfterEvent -> App ())
afterEvent_ :: App a -> App ()
afterEvent_ = void . afterEvent
onExit :: App a -> App ()
onExit action = void $ addListener (const $ void action :: Exit -> App ())
dispatchEvent
:: forall result eventType m s.
(MonadState s m
,HasEvents s
,Monoid result
,Typeable m
,Typeable eventType
,Typeable result)
=> eventType -> m result
dispatchEvent evt = do
LocalListeners _ listeners <- use localListeners
results <-
traverse ($ evt) (matchingListeners listeners :: [eventType -> m result])
return (mconcat results :: result)
dispatchEvent_
:: forall eventType m s.
(MonadState s m
,HasEvents s
,Typeable m
,Typeable eventType)
=> eventType -> m ()
dispatchEvent_ = dispatchEvent
addListener
:: forall result eventType m s.
(MonadState s m
,HasEvents s
,Typeable m
,Typeable eventType
,Typeable result
,Monoid result)
=> (eventType -> m result) -> m ListenerId
addListener 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)
addListener_
:: forall result eventType m s.
(MonadState s m
,HasEvents s
,Typeable m
,Typeable eventType
,Typeable result
,Monoid result)
=> (eventType -> m result) -> m ()
addListener_ = void . addListener
removeListener
:: (MonadState s m, HasEvents s)
=> ListenerId -> m ()
removeListener 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
dispatchEventAsync
:: (Typeable event)
=> IO event -> App ()
dispatchEventAsync ioEvent = dispatchActionAsync $ dispatchEvent <$> ioEvent
data Listener where
Listener ::
(MonadState s m, Typeable m, Typeable eventType, Typeable result,
Monoid result, HasExts s) =>
TypeRep -> ListenerId -> (eventType -> m result) -> Listener
instance Show Listener where
show (Listener rep (ListenerId n _) _) =
"<Listener #" ++ show n ++ ", " ++ show rep ++ ">"
data ListenerId =
ListenerId Int
TypeRep
deriving (Show)
instance Eq ListenerId where
ListenerId a _ == ListenerId b _ = a == b
type Listeners = M.Map TypeRep [Listener]
data LocalListeners =
LocalListeners Int
Listeners
deriving (Show)
instance Default LocalListeners where
def = LocalListeners 0 M.empty
localListeners
:: HasExts s
=> Lens' s LocalListeners
localListeners = ext
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 Dispatcher = forall event. Typeable event =>
event -> IO ()
asyncEventProvider
:: (Dispatcher -> IO ()) -> App ()
asyncEventProvider asyncEventProv = asyncActionProvider $ eventsToActions asyncEventProv
where
eventsToActions :: (Dispatcher -> IO ()) -> (App () -> IO ()) -> IO ()
eventsToActions aEventProv dispatcher =
aEventProv (dispatcher . dispatchEvent)