-- | 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.
--
-- Copyright   : (C) Keera Studios Ltd, 2013
-- License     : BSD3
-- Maintainer  : support@keera.co.uk
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.Map      as M
import Data.Foldable as F
import Data.Sequence as Seq

-- Internal libraries
import Hails.MVC.Model.ReactiveModel
  ( emptyRM
  , getPendingHandler
  , pendingEvents
  , pendingHandlers
  , eventHandlers
  , prepareEventHandlers
  , 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
  { 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 ())

-- | Start executing the a new protected model.
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
           }

-- | Lock the calling thread until the reactive model fulfills a
-- condition.
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)

-- | 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 :: 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
    -- Check that there's something pending
    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)))
    -- Get the next handler
    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

    -- Update the ReactiveModel
    TVar (ReactiveModelIO a b) -> ReactiveModelIO a b -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (ReactiveModelIO a b)
rmvar ReactiveModelIO a b
rm'

    -- Return the next handler to execute
    Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
op

  -- Execute the handler
  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

  -- Let other threads run
  IO ()
yield

-- | Execute an event handler for a given Event.
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)

-- | Execute an event handler for a given Event.
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)

-- | Perform a modification to the underlying reactive model.
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)

-- | Calculate a value from the reactive model.
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

-- | 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 :: 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