module Control.Event.Handler (
Handler, AddHandler(..), newAddHandler,
mapIO, filterIO,
) where
import Data.IORef
import qualified Data.Map as Map
import qualified Data.Unique
type Map = Map.Map
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 (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
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 ()
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, ())