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.Map as M
import Data.Foldable as F
import Data.Sequence as Seq
import Hails.MVC.Model.ReactiveModel
( emptyRM
, getPendingHandler
, pendingEvents
, pendingHandlers
, eventHandlers
, prepareEventHandlers
, Event
, ReactiveModel
)
import qualified Hails.MVC.Model.ReactiveModel as RM
data (Event b) => ProtectedModel a b = ProtectedModel
{ ProtectedModel a b -> TVar (ReactiveModelIO a b)
reactiveModel :: TVar (ReactiveModelIO a b)
, ProtectedModel a b -> Maybe ThreadId
dispatcher :: Maybe ThreadId
}
type ReactiveModelIO a b = ReactiveModel a b (IO ())
startProtectedModel :: Event b => a -> IO (ProtectedModel a b)
startProtectedModel :: a -> IO (ProtectedModel a b)
startProtectedModel a
emptyBM = do
TVar (ReactiveModel a b (IO ()))
rm <- STM (TVar (ReactiveModel a b (IO ())))
-> IO (TVar (ReactiveModel a b (IO ())))
forall a. STM a -> IO a
atomically (STM (TVar (ReactiveModel a b (IO ())))
-> IO (TVar (ReactiveModel a b (IO ()))))
-> STM (TVar (ReactiveModel a b (IO ())))
-> IO (TVar (ReactiveModel a b (IO ())))
forall a b. (a -> b) -> a -> b
$ ReactiveModel a b (IO ()) -> STM (TVar (ReactiveModel a b (IO ())))
forall a. a -> STM (TVar a)
newTVar (ReactiveModel a b (IO ())
-> STM (TVar (ReactiveModel a b (IO ()))))
-> ReactiveModel a b (IO ())
-> STM (TVar (ReactiveModel a b (IO ())))
forall a b. (a -> b) -> a -> b
$ a -> ReactiveModel a b (IO ())
forall b a c. Event b => a -> ReactiveModel a b c
emptyRM a
emptyBM
ThreadId
i <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TVar (ReactiveModel a b (IO ())) -> IO ()
forall b a. Event b => TVar (ReactiveModelIO a b) -> IO ()
dispatcherThread TVar (ReactiveModel a b (IO ()))
rm
ProtectedModel a b -> IO (ProtectedModel a b)
forall (m :: * -> *) a. Monad m => a -> m a
return ProtectedModel :: forall a b.
TVar (ReactiveModelIO a b) -> Maybe ThreadId -> ProtectedModel a b
ProtectedModel
{ reactiveModel :: TVar (ReactiveModel a b (IO ()))
reactiveModel = TVar (ReactiveModel a b (IO ()))
rm
, dispatcher :: Maybe ThreadId
dispatcher = ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
i
}
waitFor :: Event b =>
ProtectedModel a b -> (ReactiveModelIO a b -> Bool) -> IO ()
waitFor :: ProtectedModel a b -> (ReactiveModelIO a b -> Bool) -> IO ()
waitFor ProtectedModel a b
p ReactiveModelIO a b -> Bool
c = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
ReactiveModelIO a b
rm <- TVar (ReactiveModelIO a b) -> STM (ReactiveModelIO a b)
forall a. TVar a -> STM a
readTVar (TVar (ReactiveModelIO a b) -> STM (ReactiveModelIO a b))
-> TVar (ReactiveModelIO a b) -> STM (ReactiveModelIO a b)
forall a b. (a -> b) -> a -> b
$ ProtectedModel a b -> TVar (ReactiveModelIO a b)
forall a b.
Event b =>
ProtectedModel a b -> TVar (ReactiveModelIO a b)
reactiveModel ProtectedModel a b
p
Bool -> STM ()
check (ReactiveModelIO a b -> Bool
c ReactiveModelIO a b
rm)
dispatcherThread :: Event b => TVar (ReactiveModelIO a b) -> IO ()
dispatcherThread :: TVar (ReactiveModelIO a b) -> IO ()
dispatcherThread TVar (ReactiveModelIO a b)
rmvar = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Maybe (IO ())
pa <- STM (Maybe (IO ())) -> IO (Maybe (IO ()))
forall a. STM a -> IO a
atomically (STM (Maybe (IO ())) -> IO (Maybe (IO ())))
-> STM (Maybe (IO ())) -> IO (Maybe (IO ()))
forall a b. (a -> b) -> a -> b
$ do
ReactiveModelIO a b
rm <- TVar (ReactiveModelIO a b) -> STM (ReactiveModelIO a b)
forall a. TVar a -> STM a
readTVar TVar (ReactiveModelIO a b)
rmvar
Bool -> STM ()
check (Bool -> Bool
not (Seq b -> Bool
forall a. Seq a -> Bool
Seq.null (ReactiveModelIO a b -> Seq b
forall a b c. Event b => ReactiveModel a b c -> Seq b
pendingEvents ReactiveModelIO a b
rm))
Bool -> Bool -> Bool
|| Bool -> Bool
not (Seq (IO ()) -> Bool
forall a. Seq a -> Bool
Seq.null (ReactiveModelIO a b -> Seq (IO ())
forall a b c. Event b => ReactiveModel a b c -> Seq c
pendingHandlers ReactiveModelIO a b
rm)))
let (ReactiveModelIO a b
rm', Maybe (IO ())
op) = ReactiveModelIO a b -> (ReactiveModelIO a b, Maybe (IO ()))
forall b a c.
Event b =>
ReactiveModel a b c -> (ReactiveModel a b c, Maybe c)
getPendingHandler ReactiveModelIO a b
rm
TVar (ReactiveModelIO a b) -> ReactiveModelIO a b -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (ReactiveModelIO a b)
rmvar ReactiveModelIO a b
rm'
Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
op
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (IO ()) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (IO ())
pa) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (IO ()) -> IO ()
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (IO ())
pa
IO ()
yield
onEvent :: Event b => ProtectedModel a b -> b -> IO () -> IO ()
onEvent :: ProtectedModel a b -> b -> IO () -> IO ()
onEvent ProtectedModel a b
pm b
ev IO ()
f = ProtectedModel a b
-> (ReactiveModelIO a b -> ReactiveModelIO a b) -> IO ()
forall b a.
Event b =>
ProtectedModel a b
-> (ReactiveModelIO a b -> ReactiveModelIO a b) -> IO ()
applyToReactiveModel ProtectedModel a b
pm (\ReactiveModelIO a b
rm -> ReactiveModelIO a b -> b -> IO () -> ReactiveModelIO a b
forall b a c.
Event b =>
ReactiveModel a b c -> b -> c -> ReactiveModel a b c
RM.onEvent ReactiveModelIO a b
rm b
ev IO ()
f)
onEvents :: (F.Foldable container, Event b) => ProtectedModel a b -> container b -> IO () -> IO ()
onEvents :: ProtectedModel a b -> container b -> IO () -> IO ()
onEvents ProtectedModel a b
pm container b
evs IO ()
f = ProtectedModel a b
-> (ReactiveModelIO a b -> ReactiveModelIO a b) -> IO ()
forall b a.
Event b =>
ProtectedModel a b
-> (ReactiveModelIO a b -> ReactiveModelIO a b) -> IO ()
applyToReactiveModel ProtectedModel a b
pm (\ReactiveModelIO a b
rm -> ReactiveModelIO a b -> container b -> IO () -> ReactiveModelIO a b
forall (container :: * -> *) b a c.
(Foldable container, Event b) =>
ReactiveModel a b c -> container b -> c -> ReactiveModel a b c
RM.onEvents ReactiveModelIO a b
rm container b
evs IO ()
f)
applyToReactiveModel :: Event b
=> ProtectedModel a b
-> (ReactiveModelIO a b -> ReactiveModelIO a b)
-> IO ()
applyToReactiveModel :: ProtectedModel a b
-> (ReactiveModelIO a b -> ReactiveModelIO a b) -> IO ()
applyToReactiveModel ProtectedModel a b
p ReactiveModelIO a b -> ReactiveModelIO a b
f = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (ReactiveModelIO a b)
-> (ReactiveModelIO a b -> ReactiveModelIO a b) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
onTVar (ProtectedModel a b -> TVar (ReactiveModelIO a b)
forall a b.
Event b =>
ProtectedModel a b -> TVar (ReactiveModelIO a b)
reactiveModel ProtectedModel a b
p) ReactiveModelIO a b -> ReactiveModelIO a b
f
where onTVar :: TVar a -> (a -> a) -> STM ()
onTVar TVar a
v a -> a
g = TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
v STM a -> (a -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
v (a -> STM ()) -> (a -> a) -> a -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
g)
onReactiveModel :: Event b
=> ProtectedModel a b
-> (ReactiveModelIO a b -> c)
-> IO c
onReactiveModel :: ProtectedModel a b -> (ReactiveModelIO a b -> c) -> IO c
onReactiveModel ProtectedModel a b
p ReactiveModelIO a b -> c
f = (ReactiveModelIO a b -> c) -> IO (ReactiveModelIO a b) -> IO c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ReactiveModelIO a b -> c
f (IO (ReactiveModelIO a b) -> IO c)
-> IO (ReactiveModelIO a b) -> IO c
forall a b. (a -> b) -> a -> b
$ STM (ReactiveModelIO a b) -> IO (ReactiveModelIO a b)
forall a. STM a -> IO a
atomically (STM (ReactiveModelIO a b) -> IO (ReactiveModelIO a b))
-> STM (ReactiveModelIO a b) -> IO (ReactiveModelIO a b)
forall a b. (a -> b) -> a -> b
$ TVar (ReactiveModelIO a b) -> STM (ReactiveModelIO a b)
forall a. TVar a -> STM a
readTVar (TVar (ReactiveModelIO a b) -> STM (ReactiveModelIO a b))
-> TVar (ReactiveModelIO a b) -> STM (ReactiveModelIO a b)
forall a b. (a -> b) -> a -> b
$ ProtectedModel a b -> TVar (ReactiveModelIO a b)
forall a b.
Event b =>
ProtectedModel a b -> TVar (ReactiveModelIO a b)
reactiveModel ProtectedModel a b
p
fromReactiveModel :: Event b
=> ProtectedModel a b
-> (ReactiveModelIO a b -> (ReactiveModelIO a b, c))
-> IO c
fromReactiveModel :: ProtectedModel a b
-> (ReactiveModelIO a b -> (ReactiveModelIO a b, c)) -> IO c
fromReactiveModel ProtectedModel a b
p ReactiveModelIO a b -> (ReactiveModelIO a b, c)
f = STM c -> IO c
forall a. STM a -> IO a
atomically (STM c -> IO c) -> STM c -> IO c
forall a b. (a -> b) -> a -> b
$ do
ReactiveModelIO a b
rm <- TVar (ReactiveModelIO a b) -> STM (ReactiveModelIO a b)
forall a. TVar a -> STM a
readTVar (ProtectedModel a b -> TVar (ReactiveModelIO a b)
forall a b.
Event b =>
ProtectedModel a b -> TVar (ReactiveModelIO a b)
reactiveModel ProtectedModel a b
p)
let (ReactiveModelIO a b
rm', c
v) = ReactiveModelIO a b -> (ReactiveModelIO a b, c)
f ReactiveModelIO a b
rm
TVar (ReactiveModelIO a b) -> ReactiveModelIO a b -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ProtectedModel a b -> TVar (ReactiveModelIO a b)
forall a b.
Event b =>
ProtectedModel a b -> TVar (ReactiveModelIO a b)
reactiveModel ProtectedModel a b
p) ReactiveModelIO a b
rm'
c -> STM c
forall (m :: * -> *) a. Monad m => a -> m a
return c
v