Handler.hs

{-
 -      ``Data/Handler''
 -      (c) 2008 Cook, J. MR  SSD, Inc.
 -}
{-# LANGUAGE
        GeneralizedNewtypeDeriving,
        ExistentialQuantification,
        FlexibleContexts
  #-}

module Data.Handler
        ( HandlerSet
        , HandlerID
        
        , emptyHandlerSet
        , emptyHandlerSetWithSequencer
        
        , setHandlerSequencer
        
        , addHandlerToSet
        , removeHandlerFromSet
        , invokeHandlers
        ) where

-- generic "handler" concept.  a handler has:

-- at type level:
--  an argument type
--  a monad in which the handlers will run
--  a return type

-- at data level:
--  a numeric ID within the context of the set of handlers registered for a given event
--  a piece of code to run when triggered

-- I would also like to add a description field for each handler at some point,
-- and maybe also one for the whole handler set.

import qualified Data.Map as M

-- |An opaque identifier for handlers, useful for removing them from a set
-- later.
newtype HandlerID = HandlerID Int
        deriving (Eq, Ord, Enum)

-- |A collection of handlers that can be fired in a batch.
-- Consists of a collection of handlers and a sequencing rule that 
-- determines how multiple handlers are ordered and their results
-- threaded or aggregated.
data HandlerSet m a b = HandlerSet
        { handlerSet            :: M.Map HandlerID (a -> m b)
        , handlerSequencer      :: a -> [a -> m b] -> m b
        , nextHandlerId         :: HandlerID
        }

----------------------------------------------------------------
-- some canned handler sequencing rules

-- |Make a simple handler sequencer that executes handlers sequentially
--  and returns whatever the last one returns (or the first 'b' parameter
--  passed to 'sequenceHandlers' if there are no handlers in the set)
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

----------------------------------------------------------------
-- handler sets

-- |Create a new handler set with a simple default sequencer
--  ('sequenceHandlers' ())
emptyHandlerSet :: Monad m => HandlerSet m a ()
emptyHandlerSet = emptyHandlerSetWithSequencer (sequenceHandlers ())

-- |Create a new handler set using the provided function to coordinate
--  the dispatch of the handlers
emptyHandlerSetWithSequencer :: (a -> [a -> m b] -> m b) -> HandlerSet m a b
emptyHandlerSetWithSequencer sequencer = HandlerSet
        { handlerSet            = M.empty
        , handlerSequencer      = sequencer
        , nextHandlerId         = HandlerID 0
        }

-- |Add a handler to a set and return the updated set and the assigned 'HandlerID'
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
        )

-- |Attempt to remove a handler from a set (based on its 'HandlerID'), returning
-- the modified set and the handler removed, if any.
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

-- |Replace the handler sequencing rule in a 'HandlerSet'.
setHandlerSequencer :: (a -> [a -> m b] -> m b) -> HandlerSet m a b -> HandlerSet m a b
setHandlerSequencer sequencer hs = hs { handlerSequencer = sequencer }

-- |Invoke the handlers in a 'HandlerSet' with the provided input.
invokeHandlers :: Monad m => HandlerSet m a b -> a -> m b
invokeHandlers (HandlerSet {handlerSet = handlers, handlerSequencer = sequencer}) args = do
        sequencer args (M.elems handlers)