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