module Control.Event.Handler (
Handler, AddHandler(..), newAddHandler,
mapIO, filterIO,
) where
import Control.Monad ((>=>), when)
import Data.IORef
import qualified Data.Map as Map
import qualified Data.Unique
type Handler a = a -> IO ()
newtype AddHandler a = AddHandler { AddHandler a -> Handler a -> IO (IO ())
register :: Handler a -> IO (IO ()) }
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)
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)
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
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, ())
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 ()
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