{-# LANGUAGE RankNTypes, DeriveDataTypeable, StandaloneDeriving, TypeSynonymInstances,
FlexibleInstances, ExistentialQuantification, FlexibleContexts, TypeFamilies #-}
-----------------------------------------------------------------------------
--
-- Module : Base.Event
-- Copyright : Juergen Nicklisch-Franken
-- License : LGPL
--
-- Maintainer : maintainer@leksah.org
-- Stability : provisional
-- Portability : portabel
--
-- | Simple (imperative) event implementation
-- For concrete usage an event factory has to be constructed.
-----------------------------------------------------------------------------
module Base.Event (
-- * High level interface
makeEvent,
getEvent,
registerEvent,
registerEvent',
triggerEvent,
unionEvent,
filterEvent,
propagateEvent,
retriggerEvent,
-- * Types
Handler,
Handlers(..),
EvtID,
HandlerID,
EventChannel(..),
EventFactory(..),
-- * Low level interface
stdEventFactory,
mkEvent,
GenEvent(..),
newEventID
) where
import Base.State
import Base.Selector
import Data.Unique (newUnique, Unique)
import Data.Map (Map)
import Control.Monad.IO.Class
import qualified Data.Map as Map (empty, insert, lookup)
import Control.Monad (foldM)
import Data.IORef (newIORef, writeIORef, readIORef, IORef)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Maybe (fromJust)
-- ---------------------------------
-- Types
--
--
-- | A handler is a callback function
--
type Handler event = event -> StateM event
type EvtID = Unique
type HandlerID = Unique
--
-- | An event has a unique id, can be triggered, and callbacks can be registered
-- and unregistered
--
data EventChannel event = EventChannel {
evtRegister :: Handler event -> HandlerID -> StateM (),
evtUnregister :: HandlerID -> StateM (),
evtTrigger :: event -> StateM event,
evtID :: EvtID}
--
-- | A boxed type for events
--
data GenEvent = forall event. GenEvent event
--
-- | The implementation type
--
newtype Handlers event = Handlers (Map EvtID [(HandlerID, event -> StateM event)])
--
-- | The provider of low level state mechanism
--
data EventFactory event handlers = EventFactory {
efGetHandlers :: StateM handlers,
efSetHandlers :: handlers -> StateM ()}
-- ---------------------------------
-- High level interface
--
--
-- | Constructs a new event. The plugin name has to be unique!
--
makeEvent
:: (ValueType alpha ~ EventChannel event, Selector alpha) =>
alpha -> StateM (EventChannel event)
makeEvent selector = do
ideRef <- liftIO $ newIORef (Handlers Map.empty)
let ef = stdEventFactory selector ideRef
ev <- mkEvent selector ef
persistEvent selector ev
return ev
persistEvent :: Selector alpha => alpha -> ValueType alpha -> StateM ()
persistEvent key event =
registerState key event >> return ()
--
-- | Get the event from a plugin name (The type has to fit, otherwise
-- an error will be thrown).
--
getEvent :: Selector alpha => alpha -> StateM (ValueType alpha)
getEvent = getState
--
-- | Registers an event handler for this event
--
registerEvent :: EventChannel alpha -> Handler alpha -> StateM (HandlerID)
registerEvent event handler = do
newEvtID <- liftIO $ newUnique
(evtRegister event) handler newEvtID
return newEvtID
--
-- | Registers an event handler for this event, without returning a Value
--
registerEvent' :: EventChannel alpha -> (alpha -> StateM ()) -> StateM (HandlerID)
registerEvent' event handler = do
newEvtID <- liftIO $ newUnique
(evtRegister event) (\ e -> handler e >> return e) newEvtID
return newEvtID
--
-- | Triggers the event with the provided value
--
triggerEvent :: (Selector alpha, ValueType alpha ~ EventChannel event)
=> alpha -> event -> StateM event
triggerEvent sel e = getEvent sel >>= \ event -> (evtTrigger event) e
--
-- | Merge two event streams of the same type
--
unionEvent :: EventChannel event -> EventChannel event -> StateM (EventChannel event)
unionEvent e1 e2 = do
newEvtID <- newEventID
return $ EventChannel {
evtRegister = \ handler newHdlIdID -> do
(evtRegister e1) handler newHdlIdID
(evtRegister e2) handler newHdlIdID,
evtUnregister = \ hdlID -> do
(evtUnregister e1) hdlID
(evtUnregister e2) hdlID,
evtTrigger = \ event -> do
(evtTrigger e1) event
(evtTrigger e2) event,
evtID = newEvtID}
--
-- | Allow all events that fulfill the predicate, discard the rest. Think of it as
--
filterEvent :: (e -> Bool) -> EventChannel e -> StateM (EventChannel e)
filterEvent filterFunc event = do
newEvtID <- newEventID
return $ EventChannel {
evtRegister = \ handler newHdlId -> do
(evtRegister event) (newHandler handler) newHdlId,
evtUnregister = evtUnregister event,
evtTrigger = evtTrigger event,
evtID = newEvtID}
where
newHandler handler = \ event -> do
if filterFunc event
then handler event
else return event
--
-- | Propagate event ...
--
propagateEvent :: EventChannel e -> [EventChannel e] -> StateM ()
propagateEvent to fromList =
mapM_ (\ from -> registerEvent from (\e -> (evtTrigger to) e)) fromList
retriggerEvent :: EventChannel e -> (e -> Maybe e) -> StateM ()
retriggerEvent event trans =
registerEvent event (\e -> case trans e of
Nothing -> return e
Just ne -> (evtTrigger event) ne) >> return ()
-- ---------------------------------
-- Low level implementation
--
stdEventFactory :: (Selector alpha, ValueType alpha ~ EventChannel event) => alpha ->
IORef (Handlers event) -> EventFactory event (Handlers event)
stdEventFactory _ handlersRef = EventFactory {
efGetHandlers = liftIO $ readIORef handlersRef,
efSetHandlers = \ nh -> liftIO $ writeIORef handlersRef nh}
newEventID = liftIO $ newUnique
--
-- | Make an EventChannel in the IO Monad
--
mkEvent
:: (Selector alpha, ValueType alpha ~ EventChannel event) => alpha
-> EventFactory event (Handlers event)
-> StateM (ValueType alpha)
mkEvent _ ef@EventFactory{efGetHandlers = getHandlers, efSetHandlers = setHandlers} = do
newEvtID <- newEventID
return $ EventChannel {
evtRegister = \ handler newUni -> do
Handlers handlerMap <- getHandlers
let newHandlers = case newEvtID `Map.lookup` handlerMap of
Nothing -> Map.insert newEvtID [(newUni,handler)] handlerMap
Just l -> Map.insert newEvtID ((newUni,handler):l) handlerMap
setHandlers (Handlers newHandlers),
evtUnregister = \ unique -> do
Handlers handlerMap <- getHandlers
let newHandlers = case newEvtID `Map.lookup` handlerMap of
Nothing -> handlerMap
Just l -> let newList = filter (\ (mu,_) -> mu /= unique) l
in Map.insert newEvtID newList handlerMap
setHandlers (Handlers newHandlers)
return (),
evtTrigger = \ event -> do
Handlers handlerMap <- getHandlers
case newEvtID `Map.lookup` handlerMap of
Nothing -> return event
Just l -> foldM (\ e (_,ah) -> ah e) event (reverse l),
evtID = newEvtID}