{-# LANGUAGE ExistentialQuantification #-}
module Hails.MVC.Model.ReactiveModel
( ReactiveModel (basicModel)
, Event
, emptyRM
, pendingEvents
, pendingHandlers
, onBasicModel
, onEvent
, onEvents
, getPendingHandler
, eventHandlers
, prepareEventHandlers
, triggerEvent
, triggerEvents
)
where
import qualified Data.Foldable as F
import qualified Data.Map as M
import Data.Sequence ((|>), (><), Seq, ViewL(..), viewl)
import qualified Data.Sequence as Seq
class (Eq a, Ord a) => Event a where
data Event b => ReactiveModel a b c = ReactiveModel
{ ReactiveModel a b c -> a
basicModel :: a
, 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 -> Map b (Seq c) -> Seq b -> Seq c -> ReactiveModel a b c
ReactiveModel
{ basicModel :: a
basicModel = a
emptyBM
, 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