{-# LANGUAGE ExistentialQuantification #-}
-- | This module holds a reactive program model. It holds a program model, but
-- includes events that other threads can listen to, so that a change in a part
-- of the model is notified to another part of the program. The reactive model
-- is not necessarily concurrent (it doesn't have its own thread), although a
-- facility is included to make it also concurrent (so that event handlers can
-- be called as soon as they are present).
--
-- This type includes operations to handle undoing-redoing and
-- tracking which notifications must be triggered in each
-- undo-redo step.
module Hails.MVC.Model.ReactiveModel
( ReactiveModel (basicModel)
-- * Construction
, Event
, emptyRM
-- * Access
, pendingEvents
, pendingHandlers
-- * Modification
, onBasicModel
, onEvent
, onEvents
, getPendingHandler
, eventHandlers
, prepareEventHandlers
, triggerEvent
, triggerEvents
)
where
-- External imports
import qualified Data.Foldable as F
import qualified Data.Map as M
import Data.Sequence ((|>), (><), Seq, ViewL(..), viewl)
import qualified Data.Sequence as Seq
-- | A reactive model uses an event datatype with all the events that our model
-- must trigger. An heterogenous container cannot be used because we need an Eq
-- operation that is efficient (a string comparison is not).
--
-- Therefore, we can declare operations that require certain events,
-- as long as we create a typeclass for Event types that have a constructor
-- for the kind of events we require.
--
-- NOTE: This is experimental code.
--
class (Eq a, Ord a) => Event a where
-- data FullEvent = forall a . Event a => FullEvent a
-- instance Eq FullEvent where
-- (FullEvent a) == (FullEvent b) = typeOf a == typeOf b
-- && cast a == Just b
-- instance Ord FullEvent where
-- (FullEvent a) < (FullEvent b) = (typeOf a == typeOf b
-- && fromJust (cast a) < b)
-- || (show (typeOf a) < show (typeOf b))
-- instance Show FullEvent where
-- show (FullEvent x) = show x
-- | A model of kind a with a stack of events of kind b
data Event b => ReactiveModel a b c = ReactiveModel
{ basicModel :: a
, eventHandlers :: M.Map b (Seq c)
, pendingEvents :: Seq b
, pendingHandlers :: Seq c
}
-- | Default constructor (with an empty model, no events and no handlers installed)
emptyRM :: Event b => a -> ReactiveModel a b c
emptyRM emptyBM = ReactiveModel
{ basicModel = emptyBM
, eventHandlers = M.empty
, pendingEvents = Seq.empty
, pendingHandlers = Seq.empty
}
-- | Apply a modification to the internal model (no events are triggered)
onBasicModel :: Event b => ReactiveModel a b c -> (a -> a) -> ReactiveModel a b c
onBasicModel rm f = rm { basicModel = f (basicModel rm) }
-- | Install a handler for an event
onEvent :: Event b => ReactiveModel a b c -> b -> c -> ReactiveModel a b c
onEvent rm ev f = rm { eventHandlers = m' }
where ls = M.findWithDefault Seq.empty ev m
ls' = ls |> f
m = eventHandlers rm
m' = M.insert ev ls' m
onEvents :: (F.Foldable container, Event b) => ReactiveModel a b c -> container b -> c -> ReactiveModel a b c
onEvents rm evs f = F.foldl (\rm' e' -> onEvent rm' e' f) rm evs
-- | Trigger an event (execute all handlers associated to it)
triggerEvent :: Event b => ReactiveModel a b c -> b -> ReactiveModel a b c
triggerEvent rm e = rm { pendingEvents = ps' }
where ps = pendingEvents rm
ps' = ps |> e
-- | Trigger many events in sequence (execute all handlers associated to them)
triggerEvents :: Event b => ReactiveModel a b c -> Seq b -> ReactiveModel a b c
triggerEvents = F.foldl triggerEvent
-- | If any pending handler exists or can be obtained, it is returned
-- and removed from the queue
getPendingHandler :: Event b => ReactiveModel a b c -> (ReactiveModel a b c, Maybe c)
getPendingHandler rm = (rm' { pendingHandlers = pt }, ph)
where rm' = prepareEventHandlers rm
ps = pendingHandlers rm'
vw = viewl ps
(ph, pt) = case vw of
EmptyL -> (Nothing, ps)
(h :< hs) -> (Just h, hs)
-- if Seq.null ps then (Nothing,ps) else (Just (head ps), tail ps)
-- | Return a reactive model that has no pending events. All the pending events
-- have been looked up in the eventHandlers table and the handlers have been
-- added to the field pendingHandlers.
prepareEventHandlers :: Event b => ReactiveModel a b c -> ReactiveModel a b c
prepareEventHandlers rm =
rm { pendingEvents = Seq.empty, pendingHandlers = hs1 >< hs2 }
where evs = pendingEvents rm
m = eventHandlers rm
hs1 = pendingHandlers rm
hs2 = F.foldl (><) Seq.empty $
fmap (\e -> M.findWithDefault Seq.empty e m) evs