module Reactive.IO
(
Event
, newEvent
, filterE
, accumE
, execute
, Signal
, newSignal
, apply
, stepper
)
where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Cont
import Control.Monad.IO.Class
import Data.IORef
newtype Event a = Event { runEvent :: ContT () IO a }
deriving (Functor, Applicative, Monad, MonadIO)
initE :: IO (Event a) -> Event a
initE = join . liftIO
instance Alternative Event where
Event a <|> Event b = Event $ ContT $ \k ->
runContT a k >> runContT b k
empty = Event $ ContT $ \cb -> return ()
newEvent :: ((a -> IO ()) -> IO ()) -> Event a
newEvent = Event . ContT
filterE :: (a -> Bool) -> Event a -> Event a
filterE f a =
a >>= \va ->
if f va then return va else empty
accumE :: a -> Event (a -> a) -> Event a
accumE a (Event fs) = Event $ ContT $ \k -> do
accVar <- liftIO $ newIORef a
let
cb f = do
acc <- readIORef accVar
let acc' = f acc
writeIORef accVar acc'
k acc'
runContT fs cb
execute :: Event (IO ()) -> IO ()
execute (Event a) = runContT a id
memoE :: Event a -> Event a
memoE (Event e) = initE $ do
sinks <- newIORef []
runContT e $ \x -> readIORef sinks >>= mapM_ ($ x)
return $ newEvent $ \cb -> atomicModifyIORef sinks (\x -> (cb : x, ()))
newtype Signal a = Signal { runSignal :: IO (IO a) }
newSignal :: IO a -> Signal a
newSignal = Signal . pure
apply :: Signal (a -> b) -> Event a -> Event b
apply (Signal ss) a = initE $ do
s <- ss
return $ liftIO s <*> a
stepper :: a -> Event a -> Signal a
stepper a e = Signal $ do
lastVar <- newIORef a
runContT (runEvent e) (writeIORef lastVar)
return $ readIORef lastVar