content: {-# 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
    { basicModel      :: a
    , previousModels  :: Stack (a, Seq b )
    , nextModels      :: Stack (a, Seq b )
    , 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
    , previousModels  = Stk.empty
    , nextModels      = Stk.empty
    , 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
  
  -- | 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 rm f evs = triggerEvent rm' undoStackChangedEvent
    where rm' = rm { basicModel     = f (basicModel rm)
                   , previousModels = (basicModel rm, Seq.fromList evs) : previousModels rm
                   , nextModels     = 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 rm evs =
    case pvs of
     ((bx, evx):xs) -> rm { previousModels = (bx, evx >< Seq.fromList evs):xs }
     _              -> rm
   where pvs = previousModels rm
  
  -- | Undo one step
  undo :: Event b => ReactiveModel a b c -> ReactiveModel a b c
  undo rm = undo' rm (previousModels rm)
  
  undo' :: Event b => ReactiveModel a b c -> Stack (a, Seq b) -> ReactiveModel a b c
  undo' rm stk
   | null stk  = rm
   | otherwise = triggerEvents rm' (evx |> undoStackChangedEvent)
   where ((bx,evx),xs) = pop stk
         rm' = rm { basicModel     = bx
                  , previousModels = xs
                  , nextModels     = push (basicModel rm, evx) (nextModels rm)
                  }
  
  -- | Redo one step
  redo :: Event b => ReactiveModel a b c -> ReactiveModel a b c
  redo rm = redo' rm (nextModels rm)
  
  redo' :: Event b => ReactiveModel a b c -> Stack (a , Seq b) -> ReactiveModel a b c
  redo' rm stk
    | null stk  = rm
    | otherwise = triggerEvents rm' (evx |> undoStackChangedEvent)
   where ((bx, evx),xs) = pop stk
         rm' = rm { basicModel     = bx
                  , previousModels = push (basicModel rm, evx) (previousModels rm)
                  , nextModels     = xs
                  }
  
  -- | Clear the undo stack (remove all known previous and next models)
  clearUndoStack :: Event b => ReactiveModel a b c -> ReactiveModel a b c
  clearUndoStack rm =
    case (previousModels rm, nextModels rm) of
     ([],[]) -> rm
     _       -> let rm' = rm { previousModels = Stk.empty
                             , nextModels     = Stk.empty
                             }
                in triggerEvent rm' 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 rm f = rm { previousModels = map (first f) $ previousModels rm
                        , nextModels     = map (first f) $ nextModels rm
                        }
  