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