{-# 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
   , nextModels
   , previousModels
   -- * Modification
   , onBasicModel
   , onEvent
   , onEvents
   , getPendingHandler
   , eventHandlers
   , prepareEventHandlers
   , triggerEvent
   , triggerEvents

   -- * Handling the Undo/Redo stack
   , recordChange
   , onUndo
   , undo
   , redo
   , clearUndoStack
   , onUndoStack

   -- , FullEvent(..)
   -- , UndoEvent(..)
   )
  where

-- External imports
import           Control.Arrow    (first)
import qualified Data.Foldable    as F
import qualified Data.Map         as M
import           Data.Sequence    ((|>), (><), Seq, ViewL(..), viewl)
import qualified Data.Sequence    as Seq
import           Data.Stack       as Stk

-- | 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. This reactive model handles Undo/Redo
-- internally, and changes to the undo-stack are notified automatically.
-- All Event types must declare an undo event, even if it's not used.
--
-- NOTE: This is experimental code. Undo/Redo support may not be necessary in
-- many programs, and another Reactive Model definition could be provided with
-- no support for undo-redo if this bothers you too much.
--
class (Eq a, Ord a) => Event a where
   undoStackChangedEvent :: a

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

-- data UndoEvent = UndoEvent
--  deriving (Eq, Ord, Typeable, Show)

-- instance Event UndoEvent where

-- | 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 -> Stack (a, Seq b)
previousModels  :: Stack (a, Seq b )
  , ReactiveModel a b c -> Stack (a, Seq b)
nextModels      :: Stack (a, Seq b )
  , 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
-> Stack (a, Seq b)
-> Stack (a, Seq b)
-> Map b (Seq c)
-> Seq b
-> Seq c
-> ReactiveModel a b c
ReactiveModel
  { basicModel :: a
basicModel      = a
emptyBM
  , previousModels :: Stack (a, Seq b)
previousModels  = Stack (a, Seq b)
forall a. Stack a
Stk.empty
  , nextModels :: Stack (a, Seq b)
nextModels      = Stack (a, Seq b)
forall a. Stack a
Stk.empty
  , 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

-- | Record a change in the undo stack, with a list of associated events for
-- that change. Events are expected to work bi-directionally (the same event
-- will be triggered when the change is redone or undone).
recordChange :: Event b => ReactiveModel a b c -> (a -> a) -> [b] -> ReactiveModel a b c
recordChange :: ReactiveModel a b c -> (a -> a) -> [b] -> ReactiveModel a b c
recordChange ReactiveModel a b c
rm a -> a
f [b]
evs = 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 ReactiveModel a b c
rm' b
forall a. Event a => a
undoStackChangedEvent
  where rm' :: ReactiveModel a b c
rm' = 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)
                 , previousModels :: Stack (a, Seq b)
previousModels = (ReactiveModel a b c -> a
forall a b c. Event b => ReactiveModel a b c -> a
basicModel ReactiveModel a b c
rm, [b] -> Seq b
forall a. [a] -> Seq a
Seq.fromList [b]
evs) (a, Seq b) -> Stack (a, Seq b) -> Stack (a, Seq b)
forall a. a -> [a] -> [a]
: ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
previousModels ReactiveModel a b c
rm
                 , nextModels :: Stack (a, Seq b)
nextModels     = Stack (a, Seq b)
forall a. Stack a
Stk.empty
                 }

-- | Install a handler in the previous model's event list
onUndo :: Event b => ReactiveModel a b c -> [b] -> ReactiveModel a b c
onUndo :: ReactiveModel a b c -> [b] -> ReactiveModel a b c
onUndo ReactiveModel a b c
rm [b]
evs =
  case Stack (a, Seq b)
pvs of
   ((a
bx, Seq b
evx):Stack (a, Seq b)
xs) -> ReactiveModel a b c
rm { previousModels :: Stack (a, Seq b)
previousModels = (a
bx, Seq b
evx Seq b -> Seq b -> Seq b
forall a. Seq a -> Seq a -> Seq a
>< [b] -> Seq b
forall a. [a] -> Seq a
Seq.fromList [b]
evs)(a, Seq b) -> Stack (a, Seq b) -> Stack (a, Seq b)
forall a. a -> [a] -> [a]
:Stack (a, Seq b)
xs }
   Stack (a, Seq b)
_              -> ReactiveModel a b c
rm
 where pvs :: Stack (a, Seq b)
pvs = ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
previousModels ReactiveModel a b c
rm

-- | Undo one step
undo :: Event b => ReactiveModel a b c -> ReactiveModel a b c
undo :: ReactiveModel a b c -> ReactiveModel a b c
undo ReactiveModel a b c
rm = ReactiveModel a b c -> Stack (a, Seq b) -> ReactiveModel a b c
forall b a c.
Event b =>
ReactiveModel a b c -> Stack (a, Seq b) -> ReactiveModel a b c
undo' ReactiveModel a b c
rm (ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
previousModels ReactiveModel a b c
rm)

undo' :: Event b => ReactiveModel a b c -> Stack (a, Seq b) -> ReactiveModel a b c
undo' :: ReactiveModel a b c -> Stack (a, Seq b) -> ReactiveModel a b c
undo' ReactiveModel a b c
rm Stack (a, Seq b)
stk
 | Stack (a, Seq b) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Stack (a, Seq b)
stk  = ReactiveModel a b c
rm
 | Bool
otherwise = ReactiveModel a b c -> Seq b -> ReactiveModel a b c
forall b a c.
Event b =>
ReactiveModel a b c -> Seq b -> ReactiveModel a b c
triggerEvents ReactiveModel a b c
rm' (Seq b
evx Seq b -> b -> Seq b
forall a. Seq a -> a -> Seq a
|> b
forall a. Event a => a
undoStackChangedEvent)
 where ((a
bx,Seq b
evx),Stack (a, Seq b)
xs) = Stack (a, Seq b) -> ((a, Seq b), Stack (a, Seq b))
forall a. Stack a -> (a, Stack a)
pop Stack (a, Seq b)
stk
       rm' :: ReactiveModel a b c
rm' = ReactiveModel a b c
rm { basicModel :: a
basicModel     = a
bx
                , previousModels :: Stack (a, Seq b)
previousModels = Stack (a, Seq b)
xs
                , nextModels :: Stack (a, Seq b)
nextModels     = (a, Seq b) -> Stack (a, Seq b) -> Stack (a, Seq b)
forall a. a -> [a] -> [a]
push (ReactiveModel a b c -> a
forall a b c. Event b => ReactiveModel a b c -> a
basicModel ReactiveModel a b c
rm, Seq b
evx) (ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
nextModels ReactiveModel a b c
rm)
                }

-- | Redo one step
redo :: Event b => ReactiveModel a b c -> ReactiveModel a b c
redo :: ReactiveModel a b c -> ReactiveModel a b c
redo ReactiveModel a b c
rm = ReactiveModel a b c -> Stack (a, Seq b) -> ReactiveModel a b c
forall b a c.
Event b =>
ReactiveModel a b c -> Stack (a, Seq b) -> ReactiveModel a b c
redo' ReactiveModel a b c
rm (ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
nextModels ReactiveModel a b c
rm)

redo' :: Event b => ReactiveModel a b c -> Stack (a , Seq b) -> ReactiveModel a b c
redo' :: ReactiveModel a b c -> Stack (a, Seq b) -> ReactiveModel a b c
redo' ReactiveModel a b c
rm Stack (a, Seq b)
stk
  | Stack (a, Seq b) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Stack (a, Seq b)
stk  = ReactiveModel a b c
rm
  | Bool
otherwise = ReactiveModel a b c -> Seq b -> ReactiveModel a b c
forall b a c.
Event b =>
ReactiveModel a b c -> Seq b -> ReactiveModel a b c
triggerEvents ReactiveModel a b c
rm' (Seq b
evx Seq b -> b -> Seq b
forall a. Seq a -> a -> Seq a
|> b
forall a. Event a => a
undoStackChangedEvent)
 where ((a
bx, Seq b
evx),Stack (a, Seq b)
xs) = Stack (a, Seq b) -> ((a, Seq b), Stack (a, Seq b))
forall a. Stack a -> (a, Stack a)
pop Stack (a, Seq b)
stk
       rm' :: ReactiveModel a b c
rm' = ReactiveModel a b c
rm { basicModel :: a
basicModel     = a
bx
                , previousModels :: Stack (a, Seq b)
previousModels = (a, Seq b) -> Stack (a, Seq b) -> Stack (a, Seq b)
forall a. a -> [a] -> [a]
push (ReactiveModel a b c -> a
forall a b c. Event b => ReactiveModel a b c -> a
basicModel ReactiveModel a b c
rm, Seq b
evx) (ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
previousModels ReactiveModel a b c
rm)
                , nextModels :: Stack (a, Seq b)
nextModels     = Stack (a, Seq b)
xs
                }

-- | Clear the undo stack (remove all known previous and next models)
clearUndoStack :: Event b => ReactiveModel a b c -> ReactiveModel a b c
clearUndoStack :: ReactiveModel a b c -> ReactiveModel a b c
clearUndoStack ReactiveModel a b c
rm =
  case (ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
previousModels ReactiveModel a b c
rm, ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
nextModels ReactiveModel a b c
rm) of
   ([],[]) -> ReactiveModel a b c
rm
   (Stack (a, Seq b), Stack (a, Seq b))
_       -> let rm' :: ReactiveModel a b c
rm' = ReactiveModel a b c
rm { previousModels :: Stack (a, Seq b)
previousModels = Stack (a, Seq b)
forall a. Stack a
Stk.empty
                           , nextModels :: Stack (a, Seq b)
nextModels     = Stack (a, Seq b)
forall a. Stack a
Stk.empty
                           }
              in 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 ReactiveModel a b c
rm' b
forall a. Event a => a
undoStackChangedEvent

-- | Apply a change to all the models in the undo stack
onUndoStack :: Event b => ReactiveModel a b c -> (a -> a) -> ReactiveModel a b c
onUndoStack :: ReactiveModel a b c -> (a -> a) -> ReactiveModel a b c
onUndoStack ReactiveModel a b c
rm a -> a
f = ReactiveModel a b c
rm { previousModels :: Stack (a, Seq b)
previousModels = ((a, Seq b) -> (a, Seq b)) -> Stack (a, Seq b) -> Stack (a, Seq b)
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> (a, Seq b) -> (a, Seq b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> a
f) (Stack (a, Seq b) -> Stack (a, Seq b))
-> Stack (a, Seq b) -> Stack (a, Seq b)
forall a b. (a -> b) -> a -> b
$ ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
previousModels ReactiveModel a b c
rm
                      , nextModels :: Stack (a, Seq b)
nextModels     = ((a, Seq b) -> (a, Seq b)) -> Stack (a, Seq b) -> Stack (a, Seq b)
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> (a, Seq b) -> (a, Seq b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> a
f) (Stack (a, Seq b) -> Stack (a, Seq b))
-> Stack (a, Seq b) -> Stack (a, Seq b)
forall a b. (a -> b) -> a -> b
$ ReactiveModel a b c -> Stack (a, Seq b)
forall a b c. Event b => ReactiveModel a b c -> Stack (a, Seq b)
nextModels ReactiveModel a b c
rm
                      }