Reactive.hs

{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, LambdaCase #-}

module Control.Eternal.Reactive 
	( Action
	, Request
	, reactiveObjectIO
    , Sink
    , pauseIO
    , reactiveIO
	) where

-- |
-- Module: Control.Eternal.Reactive
-- Copyright: Andy Gill (??-2008), Heather Cynede (2014)
-- License: BSD3
-- |

import Control.Concurrent.Chan
import Control.Concurrent
import Control.Exception as Ex

-- An action is an IO-based change to an explicit state
type Action s    = s -> IO s	 -- only state change
type Request s a = s -> IO (s,a) -- state change + reply to be passed back to caller

-- Choices:
--   * do the Requests see the failure
--   * Actions do not see anything
--   * 
data Msg s = Act (Action s)
           | forall a . Req (Request s a) (MVar a)
           | Done (MVar ())

reactiveObjectIO
    :: forall state object. state
    -> (    ThreadId 
            -> (forall r. Request state r -> IO r) 	-- requests
            -> (Action state -> IO ()) 	            -- actions
            -> IO ()				                -- done
            -> object
       ) -> IO object
reactiveObjectIO state mkObject = do
    chan <- newChan
    let dispatch st = 
         readChan chan >>= \case Act act     -> do state1 <- act st
                                                   dispatch $! state1
                                 Req req box -> do (state1,ret) <- req st
                                                   putMVar box ret
                                                   dispatch $! state1
                                 Done box    -> do putMVar box ()
                                                   return ()
        requestit :: forall r. Request state r -> IO r
        requestit fun = do ret <- newEmptyMVar
                           writeChan chan $ Req fun ret
                           takeMVar ret -- wait
        actionit act = writeChan chan $ Act act
        doneit = do ret <- newEmptyMVar
                    writeChan chan $ Done ret
                    takeMVar ret -- wait
    pid <- forkIO $ dispatch state
    return (mkObject pid requestit actionit doneit)

type Sink a = a -> IO ()

-- This turns a reactive style call into a pausing IO call.
pauseIO :: (a -> Sink b -> IO ()) -> a -> IO b
pauseIO fn a = do var <- newEmptyMVar
                  forkIO $ do fn a (\ b -> putMVar var b)
                  takeMVar var

-- This turns a pausing IO call into a reactive style call.
reactiveIO :: (a -> IO b) -> a -> Sink b -> IO ()
reactiveIO fn a sinkB = do forkIO $ sinkB =<< fn a
                           return ()