{-# LANGUAGE ExistentialQuantification #-}
module Hails.MVC.Model.ReactiveModel
( ReactiveModel (basicModel)
, Event(..)
, emptyRM
, pendingEvents
, pendingHandlers
, nextModels
, previousModels
, onBasicModel
, onEvent
, onEvents
, getPendingHandler
, eventHandlers
, prepareEventHandlers
, triggerEvent
, triggerEvents
, recordChange
, onUndo
, undo
, redo
, clearUndoStack
, onUndoStack
)
where
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
class (Eq a, Ord a) => Event a where
undoStackChangedEvent :: a
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
}
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
}
onBasicModel :: Event b => ReactiveModel a b c -> (a -> a) -> ReactiveModel a b c
onBasicModel rm f = rm { basicModel = f (basicModel rm) }
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
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
triggerEvents :: Event b => ReactiveModel a b c -> Seq b -> ReactiveModel a b c
triggerEvents = F.foldl triggerEvent
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)
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
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
}
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 :: 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 :: 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
}
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
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
}