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 = forall a b. (a -> IO b) -> AddHandler a -> AddHandler b
mapIO (forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. (Handler a -> IO (IO ())) -> AddHandler a
AddHandler forall a b. (a -> b) -> a -> b
$ \Handler b
h -> forall a. AddHandler a -> Handler a -> IO (IO ())
register AddHandler a
e (a -> IO b
f 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 = forall a. (Handler a -> IO (IO ())) -> AddHandler a
AddHandler forall a b. (a -> b) -> a -> b
$ \Handler a
h ->
    forall a. AddHandler a -> Handler a -> IO (IO ())
register AddHandler a
e forall a b. (a -> b) -> a -> b
$ \a
x -> a -> IO Bool
f a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b 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
    IORef (Map Unique (Handler a))
handlers <- forall a. a -> IO (IORef a)
newIORef 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
            forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (Map Unique (Handler a))
handlers forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unique
key Handler a
handler
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (Map Unique (Handler a))
handlers forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Unique
key
        runHandlers :: Handler a
runHandlers a
a =
            forall a. a -> Map Unique (a -> IO ()) -> IO ()
runAll a
a forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IORef a -> IO a
readIORef IORef (Map Unique (Handler a))
handlers
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (Handler a -> IO (IO ())) -> AddHandler a
AddHandler Handler a -> IO (IO ())
register, Handler a
runHandlers)

atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ :: forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef a
ref a -> a
f = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef a
ref 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 = forall a. (a -> IO ()) -> Callback a
Callback forall a b. (a -> b) -> a -> b
$ \a
a -> a -> IO ()
f a
a 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 = forall a. (a -> IO ()) -> Callback a
Callback forall a b. (a -> b) -> a -> b
$ \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 = forall a. Callback a -> a -> IO ()
invoke (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. (a -> IO ()) -> Callback a
Callback Map Unique (a -> IO ())
fs) a
a