module Control.Event (
EventSelector
, Event(..)
, EventSource(..)
, Handlers
, registerEvents
) where
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Unique
import Control.Monad
import Data.Maybe (catMaybes)
class (Eq delta, Ord delta, Show delta) => EventSelector delta
class EventSelector delta => Event beta delta | beta -> delta, delta -> beta where
getSelector :: beta -> delta
type Handlers beta gamma delta = Map delta [(Unique, beta -> gamma beta)]
class (Monad gamma, Event beta delta) => EventSource alpha beta gamma delta
| alpha -> beta, alpha -> gamma where
getHandlers :: alpha -> gamma (Handlers beta gamma delta)
setHandlers :: alpha -> Handlers beta gamma delta -> gamma ()
myUnique :: alpha -> gamma Unique
canTriggerEvent :: alpha -> delta -> Bool
canTriggerEvent _ _ = False
triggerEvent :: alpha -> beta -> gamma beta
triggerEvent o e =
if canTriggerEvent o (getSelector e)
then do
handlerMap <- getHandlers o
let selector = getSelector e
case selector `Map.lookup` handlerMap of
Nothing -> return e
Just l -> foldM (\e (_,ah) -> ah e) e (reverse l)
else error $ "Can't trigger event " ++ show (getSelector e)
registerEvent :: alpha -> delta -> (beta -> gamma beta) -> gamma (Maybe Unique)
registerEvent o e handler =
if canTriggerEvent o e
then do
handlerMap <- getHandlers o
unique <- myUnique o
let newHandlers = case e `Map.lookup` handlerMap of
Nothing -> Map.insert e [(unique,handler)] handlerMap
Just l -> Map.insert e ((unique,handler):l) handlerMap
setHandlers o newHandlers
return (Just unique)
else error $ "Can't register event " ++ show e
unregisterEvent :: alpha -> delta -> Unique -> gamma ()
unregisterEvent o e unique =
if canTriggerEvent o e
then do
handlerMap <- getHandlers o
let newHandlers = case e `Map.lookup` handlerMap of
Nothing -> handlerMap
Just l -> let newList = filter (\ (mu,_) -> mu /= unique) l
in Map.insert e newList handlerMap
setHandlers o newHandlers
return ()
else error $ "Can't register event " ++ show e
registerEvents :: EventSource alpha beta gamma delta => alpha -> [delta] -> (beta -> gamma beta) -> gamma [Unique]
registerEvents o l handler = liftM catMaybes (mapM (\ e -> registerEvent o e handler) l)