    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           Control.Monad ((>=>), when)
    import           Data.IORef
    import qualified Data.Map    as Map
    import qualified Data.Unique

    {-----------------------------------------------------------------------------
        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 { forall a. AddHandler a -> Handler a -> IO (IO ())
    register :: Handler a -> IO (IO ()) }

    {-----------------------------------------------------------------------------
        Combinators
    ------------------------------------------------------------------------------}
    instance Functor AddHandler where
        fmap :: forall a b. (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 a. a -> IO a
    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 :: forall a b. (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 (a -> IO b
    f (a -> IO b) -> Handler b -> Handler a
    forall (m :: * -> *) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> Handler b
    h)

    -- | Filter event values that don't return 'True'.
    filterIO :: (a -> IO Bool) -> AddHandler a -> AddHandler a
    filterIO :: forall a. (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 a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Bool
    b -> Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    b (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Handler a
    h a
    x

    {-----------------------------------------------------------------------------
        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 :: forall a. IO (AddHandler a, Handler a)
    newAddHandler = do
        handlers <- Map Unique (a -> IO ()) -> IO (IORef (Map Unique (a -> IO ())))
    forall a. a -> IO (IORef a)
    newIORef Map Unique (a -> IO ())
    forall k a. Map k a
    Map.empty
        let register a -> IO ()
    handler = do
                key <- IO Unique
    Data.Unique.newUnique
                atomicModifyIORef_ handlers $ Map.insert key handler
                return $ atomicModifyIORef_ handlers $ Map.delete key
            runHandlers a
    a =
                a -> Map Unique (a -> IO ()) -> IO ()
    forall a. a -> Map Unique (a -> IO ()) -> IO ()
    runAll a
    a (Map Unique (a -> IO ()) -> IO ())
    -> IO (Map Unique (a -> IO ())) -> IO ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< IORef (Map Unique (a -> IO ())) -> IO (Map Unique (a -> IO ()))
    forall a. IORef a -> IO a
    readIORef IORef (Map Unique (a -> IO ()))
    handlers
        return (AddHandler register, runHandlers)

    atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
    atomicModifyIORef_ :: forall a. 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, ())

    -- | A callback is a @a -> IO ()@ function. We define this newtype to provide
    -- a way to combine callbacks ('Monoid' and 'Semigroup' instances), which
    -- allow us to write the efficient 'runAll' function.
    newtype Callback a = Callback { forall a. Callback a -> a -> IO ()
    invoke :: a -> IO () }

    instance Semigroup (Callback a) where
        Callback a -> IO ()
    f <> :: Callback a -> Callback a -> Callback a
    <> Callback a -> IO ()
    g = (a -> IO ()) -> Callback a
    forall a. (a -> IO ()) -> Callback a
    Callback ((a -> IO ()) -> Callback a) -> (a -> IO ()) -> Callback a
    forall a b. (a -> b) -> a -> b
    $ \a
    a -> a -> IO ()
    f a
    a IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> a -> IO ()
    g a
    a

    instance Monoid (Callback a) where
        mempty :: Callback a
    mempty = (a -> IO ()) -> Callback a
    forall a. (a -> IO ()) -> Callback a
    Callback ((a -> IO ()) -> Callback a) -> (a -> IO ()) -> Callback a
    forall a b. (a -> b) -> a -> b
    $ \a
    _ -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    -- This function can also be seen as
    --
    --   runAll a fs = mapM_ ($ a) fs
    --
    -- The reason we write this using 'foldMap' and 'Callback' is to produce code
    -- that doesn't allocate. See https://github.com/HeinrichApfelmus/reactive-banana/pull/237
    -- for more info.
    runAll :: a -> Map.Map Data.Unique.Unique (a -> IO ()) -> IO ()
    runAll :: forall a. a -> Map Unique (a -> IO ()) -> IO ()
    runAll a
    a Map Unique (a -> IO ())
    fs = Callback a -> a -> IO ()
    forall a. Callback a -> a -> IO ()
    invoke (((a -> IO ()) -> Callback a)
    -> Map Unique (a -> IO ()) -> Callback a
    forall m a. Monoid m => (a -> m) -> Map Unique a -> m
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap (a -> IO ()) -> Callback a
    forall a. (a -> IO ()) -> Callback a
    Callback Map Unique (a -> IO ())
    fs) a
    a