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 { 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 (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 :: (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 -> 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 :: 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 =
            a -> Map Unique (Handler a) -> IO ()
forall a. a -> Map Unique (a -> IO ()) -> IO ()
runAll a
a (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, ())

-- | 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 { 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 (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 (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 :: 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 (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