module Hails.MVC.Model.ProtectedModel
( ProtectedModel (reactiveModel)
, startProtectedModel
, onReactiveModel
, onEvent
, onEvents
, applyToReactiveModel
, fromReactiveModel
, waitFor
)
where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Data.Maybe
import Data.Foldable as F
import Data.Sequence as Seq
import Hails.MVC.Model.ReactiveModel
( emptyRM
, getPendingHandler
, pendingEvents
, pendingHandlers
, Event
, ReactiveModel
)
import qualified Hails.MVC.Model.ReactiveModel as RM
data (Event b) => ProtectedModel a b = ProtectedModel
{ reactiveModel :: TVar (ReactiveModelIO a b)
, dispatcher :: Maybe ThreadId
}
type ReactiveModelIO a b = ReactiveModel a b (IO ())
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
}
waitFor :: Event b =>
ProtectedModel a b -> (ReactiveModelIO a b -> Bool) -> IO ()
waitFor p c = atomically $ void $ do
rm <- readTVar $ reactiveModel p
check (c rm)
dispatcherThread :: Event b => TVar (ReactiveModelIO a b) -> IO ()
dispatcherThread rmvar = forever $ do
pa <- atomically $ do
rm <- readTVar rmvar
check (not (Seq.null (pendingEvents rm))
|| not (Seq.null (pendingHandlers rm)))
let (rm', op) = getPendingHandler rm
writeTVar rmvar rm'
return op
when (isJust pa) $ fromJust pa
yield
onEvent :: Event b => ProtectedModel a b -> b -> IO () -> IO ()
onEvent pm ev f = applyToReactiveModel pm (\rm -> RM.onEvent rm ev f)
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)
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)
onReactiveModel :: Event b
=> ProtectedModel a b
-> (ReactiveModelIO a b -> c)
-> IO c
onReactiveModel p f = fmap f $ atomically $ readTVar $ reactiveModel p
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