{-# 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
   , 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
                      }