module FRP.Peakachu.Internal (
Event(..), escanl, efilter,
makeCallbackEvent
) where
import Control.Concurrent.MVar (
newMVar, putMVar, readMVar, takeMVar)
import Control.Monad (when)
import Data.Monoid (Monoid(..))
data Event a = Event {
addHandler :: (a -> IO ()) -> IO (),
initialValues :: [a]
}
instance Functor Event where
fmap func event =
Event {
addHandler = addHandler event . (. func),
initialValues = map func (initialValues event)
}
instance Monoid (Event a) where
mempty =
Event {
addHandler = const (return ()),
initialValues = []
}
mappend x y =
Event {
addHandler = \handler -> do
addHandler x handler
addHandler y handler,
initialValues = initialValues x ++ initialValues y
}
escanl :: (a -> b -> a) -> a -> Event b -> Event a
escanl step startVal event =
Event {
addHandler = \handler -> do
accVar <- newMVar (last initValues)
let
srcHandler val = do
prevAcc <- takeMVar accVar
let newAcc = step prevAcc val
putMVar accVar newAcc
handler newAcc
addHandler event srcHandler,
initialValues = initValues
}
where
initValues = scanl step startVal (initialValues event)
efilter :: (a -> Bool) -> Event a -> Event a
efilter cond event =
Event {
addHandler = \handler -> do
let
srcHandler val =
when (cond val) (handler val)
addHandler event srcHandler,
initialValues = filter cond (initialValues event)
}
makeCallbackEvent :: IO (Event a, a -> IO ())
makeCallbackEvent = do
dstHandlersVar <- newMVar []
let
srcHandler val =
mapM_ ($ val) =<< readMVar dstHandlersVar
event =
Event {
addHandler = \handler ->
takeMVar dstHandlersVar >>=
putMVar dstHandlersVar . (handler :),
initialValues = []
}
return (event, srcHandler)