module Data.Handler
( HandlerSet
, HandlerID
, emptyHandlerSet
, emptyHandlerSetWithSequencer
, setHandlerSequencer
, addHandlerToSet
, removeHandlerFromSet
, invokeHandlers
) where
import qualified Data.Map as M
newtype HandlerID = HandlerID Int
deriving (Eq, Ord, Enum)
data HandlerSet m a b = HandlerSet
{ handlerSet :: M.Map HandlerID (a -> m b)
, handlerSequencer :: a -> [a -> m b] -> m b
, nextHandlerId :: HandlerID
}
sequenceHandlers :: Monad m => b -> a -> [a -> m b] -> m b
sequenceHandlers defReturn a = sh
where
sh [] = return defReturn
sh [x] = x a
sh (x:xs) = x a >> sh xs
emptyHandlerSet :: Monad m => HandlerSet m a ()
emptyHandlerSet = emptyHandlerSetWithSequencer (sequenceHandlers ())
emptyHandlerSetWithSequencer :: (a -> [a -> m b] -> m b) -> HandlerSet m a b
emptyHandlerSetWithSequencer sequencer = HandlerSet
{ handlerSet = M.empty
, handlerSequencer = sequencer
, nextHandlerId = HandlerID 0
}
addHandlerToSet :: (a -> m b) -> HandlerSet m a b -> (HandlerSet m a b, HandlerID)
addHandlerToSet handler hs@(HandlerSet {handlerSet = hSet, nextHandlerId = hId}) =
( hs { handlerSet = M.insert hId handler hSet
, nextHandlerId = succ hId
}
, hId
)
removeHandlerFromSet :: HandlerID -> HandlerSet m a b -> (HandlerSet m a b, Maybe (a -> m b))
removeHandlerFromSet hId hs@(HandlerSet {handlerSet = hSet}) =
( hs { handlerSet = rest }
, maybeHandler
) where
(matches, rest) = M.partitionWithKey (\k v -> k == hId) hSet
maybeHandler = M.lookup hId matches
setHandlerSequencer :: (a -> [a -> m b] -> m b) -> HandlerSet m a b -> HandlerSet m a b
setHandlerSequencer sequencer hs = hs { handlerSequencer = sequencer }
invokeHandlers :: Monad m => HandlerSet m a b -> a -> m b
invokeHandlers (HandlerSet {handlerSet = handlers, handlerSequencer = sequencer}) args = do
sequencer args (M.elems handlers)