{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Reactive.IO
  (
  -- * Events
    Event
  , newEvent
  , filterE
  , accumE
  , execute
  -- * Signals
  , Signal
  , newSignal
  , apply
  , stepper
  )
  where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Cont
import Control.Monad.IO.Class
import Data.IORef

--------------------------------------------------
-- Events
--------------------------------------------------

newtype Event a = Event { runEvent :: ContT () IO a }
  deriving (Functor, Applicative, Monad, MonadIO)

initE :: IO (Event a) -> Event a
initE = join . liftIO

-- | 'empty' is the event that never occurs; '<|>' is the union of events
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, ()))

--------------------------------------------------
-- Signals
--------------------------------------------------

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