module Control.Event.Handler (
    -- * Synopsis
    -- | <http://en.wikipedia.org/wiki/Event-driven_programming Event-driven programming>
    -- in the traditional imperative style.

    -- * Documentation
    Handler, AddHandler(..), newAddHandler,
    mapIO, filterIO,
    ) where


import           Data.IORef
import qualified Data.Map    as Map
import qualified Data.Unique

type Map = Map.Map

{-----------------------------------------------------------------------------
    Types
------------------------------------------------------------------------------}
-- | An /event handler/ is a function that takes an
-- /event value/ and performs some computation.
type Handler a = a -> IO ()

-- | The type 'AddHandler' represents a facility for registering
-- event handlers. These will be called whenever the event occurs.
--
-- When registering an event handler, you will also be given an action
-- that unregisters this handler again.
--
-- > do unregisterMyHandler <- register addHandler myHandler
--
newtype AddHandler a = AddHandler { AddHandler a -> Handler a -> IO (IO ())
register :: Handler a -> IO (IO ()) }

{-----------------------------------------------------------------------------
    Combinators
------------------------------------------------------------------------------}
instance Functor AddHandler where
    fmap :: (a -> b) -> AddHandler a -> AddHandler b
fmap a -> b
f = (a -> IO b) -> AddHandler a -> AddHandler b
forall a b. (a -> IO b) -> AddHandler a -> AddHandler b
mapIO (b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> (a -> b) -> a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

-- | Map the event value with an 'IO' action.
mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b
mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b
mapIO a -> IO b
f AddHandler a
e = (Handler b -> IO (IO ())) -> AddHandler b
forall a. (Handler a -> IO (IO ())) -> AddHandler a
AddHandler ((Handler b -> IO (IO ())) -> AddHandler b)
-> (Handler b -> IO (IO ())) -> AddHandler b
forall a b. (a -> b) -> a -> b
$ \Handler b
h -> AddHandler a -> Handler a -> IO (IO ())
forall a. AddHandler a -> Handler a -> IO (IO ())
register AddHandler a
e (Handler a -> IO (IO ())) -> Handler a -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \a
x -> a -> IO b
f a
x IO b -> Handler b -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handler b
h

-- | Filter event values that don't return 'True'.
filterIO :: (a -> IO Bool) -> AddHandler a -> AddHandler a
filterIO :: (a -> IO Bool) -> AddHandler a -> AddHandler a
filterIO a -> IO Bool
f AddHandler a
e = (Handler a -> IO (IO ())) -> AddHandler a
forall a. (Handler a -> IO (IO ())) -> AddHandler a
AddHandler ((Handler a -> IO (IO ())) -> AddHandler a)
-> (Handler a -> IO (IO ())) -> AddHandler a
forall a b. (a -> b) -> a -> b
$ \Handler a
h ->
    AddHandler a -> Handler a -> IO (IO ())
forall a. AddHandler a -> Handler a -> IO (IO ())
register AddHandler a
e (Handler a -> IO (IO ())) -> Handler a -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \a
x -> a -> IO Bool
f a
x IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then Handler a
h a
x else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-----------------------------------------------------------------------------
    Construction
------------------------------------------------------------------------------}
-- | Build a facility to register and unregister event handlers.
-- Also yields a function that takes an event handler and runs all the registered
-- handlers.
--
-- Example:
--
-- > do
-- >     (addHandler, fire) <- newAddHandler
-- >     register addHandler putStrLn
-- >     fire "Hello!"
newAddHandler :: IO (AddHandler a, Handler a)
newAddHandler :: IO (AddHandler a, Handler a)
newAddHandler = do
    IORef (Map Unique (Handler a))
handlers <- Map Unique (Handler a) -> IO (IORef (Map Unique (Handler a)))
forall a. a -> IO (IORef a)
newIORef Map Unique (Handler a)
forall k a. Map k a
Map.empty
    let register :: Handler a -> IO (IO ())
register Handler a
handler = do
            Unique
key <- IO Unique
Data.Unique.newUnique
            IORef (Map Unique (Handler a))
-> (Map Unique (Handler a) -> Map Unique (Handler a)) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (Map Unique (Handler a))
handlers ((Map Unique (Handler a) -> Map Unique (Handler a)) -> IO ())
-> (Map Unique (Handler a) -> Map Unique (Handler a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Unique
-> Handler a -> Map Unique (Handler a) -> Map Unique (Handler a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unique
key Handler a
handler
            IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ IORef (Map Unique (Handler a))
-> (Map Unique (Handler a) -> Map Unique (Handler a)) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (Map Unique (Handler a))
handlers ((Map Unique (Handler a) -> Map Unique (Handler a)) -> IO ())
-> (Map Unique (Handler a) -> Map Unique (Handler a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Unique -> Map Unique (Handler a) -> Map Unique (Handler a)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Unique
key
        runHandlers :: Handler a
runHandlers a
a =
            (Handler a -> IO ()) -> [Handler a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handler a -> Handler a
forall a b. (a -> b) -> a -> b
$ a
a) ([Handler a] -> IO ())
-> (Map Unique (Handler a) -> [Handler a])
-> Map Unique (Handler a)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Unique, Handler a) -> Handler a)
-> [(Unique, Handler a)] -> [Handler a]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, Handler a) -> Handler a
forall a b. (a, b) -> b
snd ([(Unique, Handler a)] -> [Handler a])
-> (Map Unique (Handler a) -> [(Unique, Handler a)])
-> Map Unique (Handler a)
-> [Handler a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Unique (Handler a) -> [(Unique, Handler a)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Unique (Handler a) -> IO ())
-> IO (Map Unique (Handler a)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Map Unique (Handler a)) -> IO (Map Unique (Handler a))
forall a. IORef a -> IO a
readIORef IORef (Map Unique (Handler a))
handlers
    (AddHandler a, Handler a) -> IO (AddHandler a, Handler a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Handler a -> IO (IO ())) -> AddHandler a
forall a. (Handler a -> IO (IO ())) -> AddHandler a
AddHandler Handler a -> IO (IO ())
register, Handler a
runHandlers)

atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef a
ref a -> a
f = IORef a -> (a -> (a, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef a
ref ((a -> (a, ())) -> IO ()) -> (a -> (a, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \a
x -> (a -> a
f a
x, ())