Reactive.hs

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

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

-- 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)
           | ∀ a . Req (Request s a) (MVar a)
           | Done (MVar ())

reactiveObjectIO
    :: ∀ state object. state
    → ( ThreadId
            → (∀ 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 :: ∀ 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 $ fn a (putMVar var)
                  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 ()