{-# 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
{ 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
}
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
}
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) }
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
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
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
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)
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
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
}
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 :: 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 :: 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
}
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
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
}