{-# 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.
--
-- Copyright   : (C) Keera Studios Ltd, 2013
-- License     : BSD3
-- Maintainer  : support@keera.co.uk
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
  { ReactiveModel a b c -> a
basicModel      :: a
  , ReactiveModel a b c -> Map b (Seq c)
eventHandlers   :: M.Map b (Seq c)
  , ReactiveModel a b c -> Seq b
pendingEvents   :: Seq b
  , ReactiveModel a b c -> Seq c
pendingHandlers :: Seq c
  }

-- | Default constructor (with an empty model, no events and no handlers installed)
emptyRM :: Event b => a -> ReactiveModel a b c
emptyRM :: a -> ReactiveModel a b c
emptyRM a
emptyBM = ReactiveModel :: forall a b c.
a -> Map b (Seq c) -> Seq b -> Seq c -> ReactiveModel a b c
ReactiveModel
  { basicModel :: a
basicModel      = a
emptyBM
  , eventHandlers :: Map b (Seq c)
eventHandlers   = Map b (Seq c)
forall k a. Map k a
M.empty
  , pendingEvents :: Seq b
pendingEvents   = Seq b
forall a. Seq a
Seq.empty
  , pendingHandlers :: Seq c
pendingHandlers = Seq c
forall a. Seq a
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 :: ReactiveModel a b c -> (a -> a) -> ReactiveModel a b c
onBasicModel ReactiveModel a b c
rm a -> a
f = ReactiveModel a b c
rm { basicModel :: a
basicModel = a -> a
f (ReactiveModel a b c -> a
forall a b c. Event b => ReactiveModel a b c -> a
basicModel ReactiveModel a b c
rm) }

-- | Install a handler for an event
onEvent :: Event b => ReactiveModel a b c -> b -> c -> ReactiveModel a b c
onEvent :: ReactiveModel a b c -> b -> c -> ReactiveModel a b c
onEvent ReactiveModel a b c
rm b
ev c
f = ReactiveModel a b c
rm { eventHandlers :: Map b (Seq c)
eventHandlers = Map b (Seq c)
m' }
 where ls :: Seq c
ls  = Seq c -> b -> Map b (Seq c) -> Seq c
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Seq c
forall a. Seq a
Seq.empty b
ev Map b (Seq c)
m
       ls' :: Seq c
ls' = Seq c
ls Seq c -> c -> Seq c
forall a. Seq a -> a -> Seq a
|> c
f
       m :: Map b (Seq c)
m   = ReactiveModel a b c -> Map b (Seq c)
forall a b c. Event b => ReactiveModel a b c -> Map b (Seq c)
eventHandlers ReactiveModel a b c
rm
       m' :: Map b (Seq c)
m'  = b -> Seq c -> Map b (Seq c) -> Map b (Seq c)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert b
ev Seq c
ls' Map b (Seq c)
m

onEvents :: (F.Foldable container, Event b) => ReactiveModel a b c -> container b -> c -> ReactiveModel a b c
onEvents :: ReactiveModel a b c -> container b -> c -> ReactiveModel a b c
onEvents ReactiveModel a b c
rm container b
evs c
f = (ReactiveModel a b c -> b -> ReactiveModel a b c)
-> ReactiveModel a b c -> container b -> ReactiveModel a b c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl (\ReactiveModel a b c
rm' b
e' -> ReactiveModel a b c -> b -> c -> ReactiveModel a b c
forall b a c.
Event b =>
ReactiveModel a b c -> b -> c -> ReactiveModel a b c
onEvent ReactiveModel a b c
rm' b
e' c
f) ReactiveModel a b c
rm container b
evs

-- | Trigger an event (execute all handlers associated to it)
triggerEvent :: Event b => ReactiveModel a b c -> b -> ReactiveModel a b c
triggerEvent :: ReactiveModel a b c -> b -> ReactiveModel a b c
triggerEvent ReactiveModel a b c
rm b
e = ReactiveModel a b c
rm { pendingEvents :: Seq b
pendingEvents = Seq b
ps' }
  where ps :: Seq b
ps  = ReactiveModel a b c -> Seq b
forall a b c. Event b => ReactiveModel a b c -> Seq b
pendingEvents ReactiveModel a b c
rm
        ps' :: Seq b
ps' = Seq b
ps Seq b -> b -> Seq b
forall a. Seq a -> a -> Seq a
|> b
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 :: ReactiveModel a b c -> Seq b -> ReactiveModel a b c
triggerEvents = (ReactiveModel a b c -> b -> ReactiveModel a b c)
-> ReactiveModel a b c -> Seq b -> ReactiveModel a b c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl ReactiveModel a b c -> b -> ReactiveModel a b c
forall b a c.
Event b =>
ReactiveModel a b c -> b -> ReactiveModel a b c
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 :: ReactiveModel a b c -> (ReactiveModel a b c, Maybe c)
getPendingHandler ReactiveModel a b c
rm = (ReactiveModel a b c
rm' { pendingHandlers :: Seq c
pendingHandlers = Seq c
pt }, Maybe c
ph)
 where rm' :: ReactiveModel a b c
rm'      = ReactiveModel a b c -> ReactiveModel a b c
forall b a c. Event b => ReactiveModel a b c -> ReactiveModel a b c
prepareEventHandlers ReactiveModel a b c
rm
       ps :: Seq c
ps       = ReactiveModel a b c -> Seq c
forall a b c. Event b => ReactiveModel a b c -> Seq c
pendingHandlers ReactiveModel a b c
rm'
       vw :: ViewL c
vw       = Seq c -> ViewL c
forall a. Seq a -> ViewL a
viewl Seq c
ps
       (Maybe c
ph, Seq c
pt) = case ViewL c
vw of
                    ViewL c
EmptyL    -> (Maybe c
forall a. Maybe a
Nothing, Seq c
ps)
                    (c
h :< Seq c
hs) -> (c -> Maybe c
forall a. a -> Maybe a
Just c
h, Seq c
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 :: ReactiveModel a b c -> ReactiveModel a b c
prepareEventHandlers ReactiveModel a b c
rm =
  ReactiveModel a b c
rm { pendingEvents :: Seq b
pendingEvents = Seq b
forall a. Seq a
Seq.empty, pendingHandlers :: Seq c
pendingHandlers = Seq c
hs1 Seq c -> Seq c -> Seq c
forall a. Seq a -> Seq a -> Seq a
>< Seq c
hs2 }
 where evs :: Seq b
evs = ReactiveModel a b c -> Seq b
forall a b c. Event b => ReactiveModel a b c -> Seq b
pendingEvents ReactiveModel a b c
rm
       m :: Map b (Seq c)
m   = ReactiveModel a b c -> Map b (Seq c)
forall a b c. Event b => ReactiveModel a b c -> Map b (Seq c)
eventHandlers ReactiveModel a b c
rm
       hs1 :: Seq c
hs1 = ReactiveModel a b c -> Seq c
forall a b c. Event b => ReactiveModel a b c -> Seq c
pendingHandlers ReactiveModel a b c
rm
       hs2 :: Seq c
hs2 = (Seq c -> Seq c -> Seq c) -> Seq c -> Seq (Seq c) -> Seq c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl Seq c -> Seq c -> Seq c
forall a. Seq a -> Seq a -> Seq a
(><) Seq c
forall a. Seq a
Seq.empty (Seq (Seq c) -> Seq c) -> Seq (Seq c) -> Seq c
forall a b. (a -> b) -> a -> b
$
                  (b -> Seq c) -> Seq b -> Seq (Seq c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b
e -> Seq c -> b -> Map b (Seq c) -> Seq c
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Seq c
forall a. Seq a
Seq.empty b
e Map b (Seq c)
m) Seq b
evs