-- | Note: this is experimental code. It's what I'm using to build my
-- own Gtk apps. That being said, you may find IO more often than it's
-- really necessary. I'd be glad if you could point that out when you
-- see it. I'd like to make this code as generic and useful as
-- possible.
--
-- | This module holds the protected reactive program model. It holds
-- a reactive model, but includes an interface that is thread safe
-- (can be called concurrently). This makes it easier for different
-- threads to modify the model without having to worry about
-- concurrency. Note that using this interface can lead to deadlocks
-- in the program.
module Hails.MVC.Model.ProtectedModel
( ProtectedModel (reactiveModel)
-- * Construction
, startProtectedModel
-- * Access
, onReactiveModel
, onEvent
, onEvents
, applyToReactiveModel
, fromReactiveModel
, waitFor
)
where
-- External libraries
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Data.Maybe
import Data.Foldable as F
import Data.Sequence as Seq
-- Internal libraries
import Hails.MVC.Model.ReactiveModel
( emptyRM
, getPendingHandler
, pendingEvents
, pendingHandlers
, Event
, ReactiveModel
)
import qualified Hails.MVC.Model.ReactiveModel as RM
-- A Protected model holds a reactive model and a thread that calls
-- the necessary event handlers as soon as the events are triggered.
-- Note that the hanlders are executed by this thread, which means
-- that, if you need the operation to be executed in another handlers,
-- you'll have to write explicit code for that.
--
-- Gtk (which is what I use this for) has specific functions for this
-- purpose.
data (Event b) => ProtectedModel a b = ProtectedModel
{ reactiveModel :: TVar (ReactiveModelIO a b)
, dispatcher :: Maybe ThreadId
}
type ReactiveModelIO a b = ReactiveModel a b (IO ())
-- | Start executing the a new protected model.
startProtectedModel :: Event b => a -> IO (ProtectedModel a b)
startProtectedModel emptyBM = do
rm <- atomically $ newTVar $ emptyRM emptyBM
i <- forkIO $ dispatcherThread rm
return ProtectedModel
{ reactiveModel = rm
, dispatcher = Just i
}
-- | Lock the calling thread until the reactive model fulfills a
-- condition.
waitFor :: Event b =>
ProtectedModel a b -> (ReactiveModelIO a b -> Bool) -> IO ()
waitFor p c = atomically $ void $ do
rm <- readTVar $ reactiveModel p
check (c rm)
-- | Run the thread that executes the event handlers.
-- This thread runs indefinitely.
--
-- TODO: would it be better to kill the thread in a clean way
-- (notifying that it has to die ASAP?)
dispatcherThread :: Event b => TVar (ReactiveModelIO a b) -> IO ()
dispatcherThread rmvar = forever $ do
pa <- atomically $ do
rm <- readTVar rmvar
-- Check that there's something pending
check (not (Seq.null (pendingEvents rm))
|| not (Seq.null (pendingHandlers rm)))
-- Get the next handler
let (rm', op) = getPendingHandler rm
-- Update the ReactiveModel
writeTVar rmvar rm'
-- Return the next handler to execute
return op
-- Execute the handler
when (isJust pa) $ fromJust pa
-- Let other threads run
yield
-- | Execute an event handler for a given Event.
onEvent :: Event b => ProtectedModel a b -> b -> IO () -> IO ()
onEvent pm ev f = applyToReactiveModel pm (\rm -> RM.onEvent rm ev f)
-- | Execute an event handler for a given Event.
onEvents :: (F.Foldable container, Event b) => ProtectedModel a b -> container b -> IO () -> IO ()
onEvents pm evs f = applyToReactiveModel pm (\rm -> RM.onEvents rm evs f)
-- | Perform a modification to the underlying reactive model.
applyToReactiveModel :: Event b
=> ProtectedModel a b
-> (ReactiveModelIO a b -> ReactiveModelIO a b)
-> IO ()
applyToReactiveModel p f = atomically $ onTVar (reactiveModel p) f
where onTVar v g = readTVar v >>= (writeTVar v . g)
-- | Calculate a value from the reactive model.
onReactiveModel :: Event b
=> ProtectedModel a b
-> (ReactiveModelIO a b -> c)
-> IO c
onReactiveModel p f = fmap f $ atomically $ readTVar $ reactiveModel p
-- | Calculate a value from the reactive model and update it at the same time
fromReactiveModel :: Event b
=> ProtectedModel a b
-> (ReactiveModelIO a b -> (ReactiveModelIO a b, c))
-> IO c
fromReactiveModel p f = atomically $ do
rm <- readTVar (reactiveModel p)
let (rm', v) = f rm
writeTVar (reactiveModel p) rm'
return v