MasseR/home-assistant-controller
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Explicit state

Browse Source
This commit is contained in:
MasseR
2026-09-12 20:09:42 +03:00
parent e16010bf2f
commit b20320c779
7 changed files with 259 additions and 253 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/AFRP.hs
+221 -186
View File
@@ -3,12 +3,13 @@
module AFRP
( Mealy(..)
, Auto(..)
, eff
, withEntities
, Event(..)
, hold
, events
, switch
-- , switch
, preMapAccum
, preMapAccumRequest
, mapAccum
@@ -23,7 +24,6 @@ module AFRP
, Pair(..)
, Request(..)
, edge
, dropFirst
, duration
, tag
, isEvent
@@ -31,28 +31,32 @@ module AFRP
, sample
, rollup
, sliding
, fixed
, debounce
, currentTime
, onEvent
, save
, load
, stepAuto
, stepAutoSerializing
) where
import Control.Category (Category(..), (>>>))
import Prelude hiding ((.), id)
import Control.Arrow (Arrow(..), ArrowChoice(..))
import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime, utcToLocalTime)
import Data.Time (UTCTime (UTCTime), NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime, utcToLocalTime, Day (..), diffTimeToPicoseconds, picosecondsToDiffTime)
import Data.Either (fromLeft)
import Data.Bool (bool)
import Data.Monoid (Endo(..))
import Data.UUID (UUID)
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Serialize (Get, Putter, runPut, Serialize (put), runGet)
import Data.Serialize (Get, Putter, runPut, Serialize (put), runGet, get)
import qualified Data.ByteString as B
import Control.Exception (IOException, handle, throwIO)
import System.IO.Error (isDoesNotExistError)
import GHC.Generics (Generic)
import Data.Sequence (Seq, (|>))
import qualified Data.Foldable as F
import Control.Monad.IO.Class (MonadIO, liftIO)
data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) }
@@ -99,38 +103,38 @@ data Request = Request
data Auto m a b
= Fun (a -> b) -- Stateless variant, needed at least for 'id'
| forall s. Stateful !(Codec s) !(State s) !(State s -> a -> m (b, State s)) -- State is explicitly part of it
= Fun (Request -> a -> b) -- Stateless variant, needed at least for 'id'
| forall s. Stateful !(Codec s) !(State s) !(State s -> Request -> a -> m (b, State s)) -- State is explicitly part of it
instance Monad m => Functor (Auto m a) where
fmap f = \case
Fun x -> Fun $ f . x
Stateful codec s x -> Stateful codec s $ \s' a -> do
(a',s'') <- x s' a
Fun x -> Fun $ \req -> f . x req
Stateful codec s x -> Stateful codec s $ \s' req a -> do
(a',s'') <- x s' req a
pure (f a', s'')
instance Monad m => Applicative (Auto m a) where
pure a = Fun (const a)
pure a = Fun (\_req -> const a)
fa <*> fb =
case (fa,fb) of
(Fun af, Fun bf) -> Fun (af <*> bf)
(Fun af, Fun bf) -> Fun $ \req -> (af req <*> bf req)
(Stateful codec s af, Fun bf) -> Stateful codec s
(\s' x -> do
let a = bf x
(h, s'') <- af s' x
(\s' req x -> do
let a = bf req x
(h, s'') <- af s' req x
pure (h a, s'')
)
(Fun af, Stateful codec s bf) -> Stateful codec s
(\s' x -> do
(a, s'') <- bf s' x
let h = af x
(\s' req x -> do
(a, s'') <- bf s' req x
let h = af req x
pure (h a, s'')
)
(Stateful acodec as af, Stateful bcodec bs bf) -> Stateful (mergeCodec acodec bcodec) (mergeState as bs)
(\s' x -> do
(a, as') <- bf (snd <$> s') x
(h, bs') <- af (fst <$> s') x
(\s' req x -> do
(a, as') <- bf (snd <$> s') req x
(h, bs') <- af (fst <$> s') req x
pure (h a, mergeState bs' as')
)
@@ -140,58 +144,62 @@ instance (Monad m, Semigroup b) => Semigroup (Auto m a b) where
case (fa,fb) of
(Fun af, Fun bf) -> Fun (af <> bf)
(Stateful codec s af, Fun bf) -> Stateful codec s
(\s' a -> do
(ab, s'') <- af s' a
let bb = bf a
(\s' req a -> do
(ab, s'') <- af s' req a
let bb = bf req a
pure (ab <> bb, s'')
)
(Fun af, Stateful codec s bf) -> Stateful codec s
(\s' a -> do
let ab = af a
(bb, s'') <- bf s' a
(\s' req a -> do
let ab = af req a
(bb, s'') <- bf s' req a
pure (ab <> bb, s'')
)
(Stateful acodec as af , Stateful bcodec bs bf) -> Stateful (mergeCodec acodec bcodec) (mergeState as bs)
(\s a -> do
(ab, as'') <- af (fst <$> s) a
(bb, bs'') <- bf (snd <$> s) a
(\s req a -> do
(ab, as'') <- af (fst <$> s) req a
(bb, bs'') <- bf (snd <$> s) req a
pure (ab <> bb, mergeState as'' bs'')
)
instance (Monad m, Monoid b) => Monoid (Auto m a b) where
mempty = Fun $ \_req _ -> mempty
instance Monad m => Category (Auto m) where
id = Fun id
id = Fun $ \_ -> id
af . ag =
case (af, ag) of
(Fun f, Fun g) -> Fun (f . g)
(Stateful codec s f, Fun g) -> Stateful codec s (\s' -> f s' . g)
(Fun f, Stateful codec s g) -> Stateful codec s (\s' -> fmap (first f) . g s')
(Fun f, Fun g) -> Fun (\req -> f req . g req)
(Stateful codec s f, Fun g) -> Stateful codec s (\s' req -> f s' req . g req)
(Fun f, Stateful codec s g) -> Stateful codec s (\s' req -> fmap (first (f req)) . g s' req)
(Stateful fcodec fs f , Stateful gcodec gs g) ->
Stateful (mergeCodec fcodec gcodec) (mergeState fs gs) (\s a -> do
(b, s') <- g (snd <$> s) a
(c, s'') <- f (fst <$> s) b
Stateful (mergeCodec fcodec gcodec) (mergeState fs gs) (\s req a -> do
(b, s') <- g (snd <$> s) req a
(c, s'') <- f (fst <$> s) req b
pure (c, mergeState s'' s'))
instance Monad m => Arrow (Auto m) where
arr = Fun
arr f = Fun $ const f
first = \case
Fun f -> Fun $ first f
Stateful codec s f -> Stateful codec s $ \s' (b,d) -> do
(c, s'') <- f s' b
Fun f -> Fun $ \req -> first (f req)
Stateful codec s f -> Stateful codec s $ \s' req (b,d) -> do
(c, s'') <- f s' req b
pure ((c,d), s'')
instance Monad m => ArrowChoice (Auto m) where
left = \case
Fun f -> Fun $
Fun f -> Fun $ \req ->
\case
Left b -> Left $ f b
Left b -> Left $ f req b
Right d -> Right d
Stateful codec s f -> Stateful codec s $ \s' -> \case
Stateful codec s f -> Stateful codec s $ \s' req -> \case
Right d -> pure (Right d, s')
Left b -> do
(c, s'') <- f s' b
(c, s'') <- f s' req b
pure (Left c, s'')
serialize :: Auto m a b -> B.ByteString
@@ -240,27 +248,24 @@ load path a = handle defaultOnMissingFile (flip deserialize a <$> B.readFile pat
-- trigger subscriptions.
data Mealy eff a b = Mealy
{ entities :: S.Set T.Text
, runMealy :: forall m. Monad m => (forall x. eff x -> m x) -> Request -> a -> m (Pair b (Mealy eff a b))
, runMealy :: forall m. Monad m => (forall x. eff x -> m x) -> Auto m a b
}
instance Semigroup b => Semigroup (Mealy eff a b) where
Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt r a -> do
Pair x af' <- af nt r a
Pair x' bf' <- bf nt r a
pure (Pair (x <> x') (af' <> bf'))
Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt -> af nt <> bf nt
instance Monoid b => Monoid (Mealy eff a b) where
mempty = m
where
m = Mealy mempty $ \_ _ _ -> pure (Pair mempty m)
mempty = Mealy mempty $ \_nt -> mempty
-- where
-- m = Mealy mempty $ \_ _ _ -> pure (Pair mempty m)
eff :: (Request -> a -> eff b) -> Mealy eff a b
eff f = m
where
m = Mealy mempty $ \nt req x ->
nt (f req x) >>= \b -> pure (Pair b m)
eff f = Mealy mempty $ \nt -> do
Stateful (Codec get put) (State () False) $ \s req a -> do
b <- nt (f req a)
pure (b, s)
-- | Override the static entity set of an arrow. Use when a combinator
-- (e.g. 'switch') hides continuation entities from the runtime's
@@ -269,53 +274,32 @@ withEntities :: S.Set T.Text -> Mealy eff a b -> Mealy eff a b
withEntities es (Mealy _ f) = Mealy es f
instance Category (Mealy eff) where
id = Mealy mempty (\_ _ x -> pure (Pair x id))
(Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt t a -> do
Pair b g' <- g nt t a
Pair c f' <- f nt t b
pure (Pair c (f' . g'))
id = Mealy mempty (\_ -> id)
(Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt -> do
f nt . g nt
instance Arrow (Mealy eff) where
arr f = mealy
where
mealy = Mealy mempty $ \_ _ b -> pure (Pair (f b) mealy)
first (Mealy st f) = Mealy st $ \nt t (b,d) -> do
Pair c f' <- f nt t b
pure (Pair (c, d) (first f'))
arr f = Mealy mempty $ \_nt -> arr f
first (Mealy st f) = Mealy st $ \nt -> first (f nt)
instance ArrowChoice (Mealy eff) where
left (Mealy st f) = lm
where
lm = Mealy st $ \nt t -> \case
Left b -> do
Pair c f' <- f nt t b
pure (Pair (Left c) (left f'))
Right d -> pure (Pair (Right d) lm)
left (Mealy st f) = Mealy st $ \nt -> left (f nt)
-- ArrowLoop is incompatible with strict Pair (strict fields prevent
-- the lazy knot-tying that mfix requires with loop).
-- instance ArrowLoop (Mealy eff) where
-- loop (Mealy st f) = Mealy st $ \nt t b -> do
-- Pair (c,_) f' <- mfix $ \(Pair (_,d) _) -> f nt t (b,d)
-- pure (Pair c (loop f'))
instance Functor (Mealy eff a) where
fmap f (Mealy st g) = Mealy st $ \nt t a -> do
Pair b g' <- g nt t a
pure (Pair (f b) (fmap f g'))
fmap f (Mealy st g) = Mealy st $ \nt -> fmap f (g nt)
instance Applicative (Mealy eff a) where
pure b = Mealy mempty $ \_ _ _ -> pure (Pair b (pure b))
Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt t a -> do
b' <- x nt t a
let Pair x' xNext = b'
Pair f' fNext <- f nt t a
pure (Pair (f' x') (fNext <*> xNext))
pure b = Mealy mempty $ \_ -> pure b
Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt ->
f nt <*> x nt
data Event a
= Tick
| Event a
deriving (Show, Eq, Functor, Foldable, Traversable)
deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
instance Serialize a => Serialize (Event a)
instance Semigroup (Event a) where
(<>) = lMerge
@@ -323,10 +307,18 @@ instance Semigroup (Event a) where
instance Monoid (Event a) where
mempty = Tick
hold :: a -> Mealy eff (Event a) a
hold a = Mealy mempty $ \_ _ -> \case
Tick -> pure (Pair a (hold a))
Event a' -> pure (Pair a' (hold a'))
hold :: (Serialize a, Eq a) => a -> Mealy m (Event a) a
hold def = preMapAccum step def id
where
step prev = \case
Tick -> prev
Event new -> new
-- hold :: a -> Mealy eff (Event a) a
-- hold a = Mealy mempty $ \_ _ -> \case
-- Tick -> pure (Pair a (hold a))
-- Event a' -> pure (Pair a' (hold a'))
events :: Mealy eff (Event a) (Either () a)
events = arr $ \case
@@ -340,51 +332,77 @@ isEvent _ = True
tag :: b -> Event a -> Event b
tag b ev = b <$ ev
switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
switch (Mealy st f) s = Mealy st $ \nt t a -> do
Pair (b, ev) f' <- f nt t a
case ev of
Tick -> pure (Pair b (switch f' s))
Event x -> runMealy (s x) nt t a
-- switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
-- switch (Mealy st f) s = Mealy st $ \nt t a -> do
-- Pair (b, ev) f' <- f nt t a
-- case ev of
-- Tick -> pure (Pair b (switch f' s))
-- Event x -> runMealy (s x) nt t a
sample :: Mealy eff (a, Event b) (Event a)
sample = arr (uncurry tag)
preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
preMapAccum f x extract = go x
where
go b = Mealy mempty $ \_ _ a ->
let next = f b a
in pure (Pair (extract b) (go next))
preMapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
preMapAccumRequest f x extract = go x
preMapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b
preMapAccum' f x extract = Stateful (Codec get put) (State x False) (\s _req a -> pure $ step s a)
where
go b = Mealy mempty $ \_ t a ->
let next = f t b a
in pure (Pair (extract b) (go next))
step :: State x -> a -> (b, State x)
step s a = let s' = f (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
mapAccum f x extract = go x
where
go b = Mealy mempty $ \_ _ a ->
let next = f b a
in pure (Pair (extract next) (go next))
mapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
mapAccumRequest f x extract = go x
mapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
mapAccum step x extract = Mealy mempty $ \_nt -> mapAccum' step x extract
preMapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
preMapAccum step x extract = Mealy mempty $ \_nt -> preMapAccum' step x extract
mapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b
mapAccum' f x extract = Stateful (Codec get put) (State x False) (\s _req a -> pure $ step s a)
where
go b = Mealy mempty $ \_ t a ->
let next = f t b a
in pure (Pair (extract next) (go next))
step :: State x -> a -> (b, State x)
step s a = let s' = f (state s) a in (extract s', State s' (dirty s || state s /= s'))
preMapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
preMapAccumRequest step x extract = Mealy mempty $ \_ -> preMapAccumRequest' step x extract
preMapAccumRequest' :: forall m x a b. (Serialize x, Eq x, Monad m) => (Request -> x -> a -> x) -> x -> (x -> b) -> Auto m a b
preMapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s req a -> pure $ step s req a)
where
step :: State x -> Request -> a -> (b, State x)
step s req a = let s' = f req (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
mapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
mapAccumRequest step x extract = Mealy mempty $ \_ -> mapAccumRequest' step x extract
mapAccumRequest' :: forall m x a b. (Monad m, Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Auto m a b
mapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s req a -> pure $ step s req a)
where
step :: State x -> Request -> a -> (b, State x)
step s req a = let s' = f req (state s) a in (extract s', State s' (dirty s || state s /= s'))
data DelayState x a = DelayState
{ pending :: x
, output :: !(Event a)
}
deriving (Generic, Eq)
instance (Serialize x, Serialize a) => Serialize (DelayState x a)
delayEvent :: NominalDiffTime -> Mealy eff (Event a) (Event a)
newtype SerializeUTCTime = SerializeUTCTime UTCTime
deriving Eq
-- TODO: Needs '\x -> pure x == get (put x)' test
instance Serialize SerializeUTCTime where
put (SerializeUTCTime (UTCTime day time)) = do
put (toModifiedJulianDay day)
put (diffTimeToPicoseconds time)
get = do
day <- ModifiedJulianDay <$> get
time <- picosecondsToDiffTime <$> get
pure $ SerializeUTCTime (UTCTime day time)
delayEvent :: (Eq a, Serialize a) => NominalDiffTime -> Mealy eff (Event a) (Event a)
delayEvent delay =
mapAccumRequest step initial output
where
@@ -396,17 +414,17 @@ delayEvent delay =
queued =
case input of
Tick -> pending st
Event x -> pending st ++ [(delay `addUTCTime` now, x)]
Event x -> pending st ++ [(SerializeUTCTime $ delay `addUTCTime` now, x)]
in case queued of
(due, x) : rest
(SerializeUTCTime due, x) : rest
| due <= now ->
DelayState rest (Event x)
_ ->
DelayState queued Tick
debounce :: NominalDiffTime -> Mealy eff (Event a) (Event a)
debounce :: (Serialize a, Eq a) => NominalDiffTime -> Mealy eff (Event a) (Event a)
debounce delay =
mapAccumRequest step initial output
where
@@ -415,13 +433,13 @@ debounce delay =
let now = requestTime req
held = case input of
Tick -> pending st
Event x -> Just (delay `addUTCTime` now, x)
Event x -> Just (SerializeUTCTime $ delay `addUTCTime` now, x)
in case held of
Just (due, x)
Just (SerializeUTCTime due, x)
| due <= now -> DelayState Nothing (Event x)
_ -> DelayState held Tick
changes :: Eq a => Mealy eff a (Event a)
changes :: (Serialize a, Eq a) => Mealy eff a (Event a)
changes = mapAccum go Nothing (maybe Tick snd)
where
go :: Eq a => Maybe (a, Event a) -> a -> Maybe (a, Event a)
@@ -454,86 +472,103 @@ lMerge (Event a) _ = Event a
lMerge Tick (Event a) = Event a
edge :: Mealy eff Bool (Event ())
edge = go False
where
go True = Mealy mempty $ \_ _ -> \case
True -> pure (Pair Tick (go True))
False -> pure (Pair Tick (go False))
go False = Mealy mempty $ \_ _ -> \case
True -> pure (Pair (Event ()) (go True))
False -> pure (Pair Tick (go False))
edge =
mapAccum
(\(_, current) new -> (current, new))
(False, False)
(\(old, current) ->
if not old && current
then Event ()
else Tick)
-- | Drop the first 'Event' and pass through everything after. Useful for
-- ignoring a self-triggered event (e.g. a service call that changes the
-- very entity the arrow listens to).
dropFirst :: Mealy eff (Event a) (Event a)
dropFirst = go False
where
go seen = Mealy mempty $ \_ _ input ->
case input of
Event _ | not seen -> pure (Pair Tick (go True))
_ -> pure (Pair input (go seen))
duration :: forall eff a. Mealy eff a NominalDiffTime
duration = mapAccumRequest go (Nothing @(UTCTime, NominalDiffTime)) (maybe 0 snd)
duration = mapAccumRequest go (Nothing @(SerializeUTCTime, SerializeUTCTime)) (maybe 0 delta)
where
go :: Request -> Maybe (UTCTime, NominalDiffTime) -> a -> Maybe (UTCTime, NominalDiffTime)
go req Nothing _ = Just (requestTime req, requestTime req `diffUTCTime` requestTime req)
go req (Just (startTime, _)) _ = Just (startTime, requestTime req `diffUTCTime` startTime)
delta :: (SerializeUTCTime, SerializeUTCTime) -> NominalDiffTime
delta (SerializeUTCTime start, SerializeUTCTime end) = end `diffUTCTime` start
go :: Request -> Maybe (SerializeUTCTime, SerializeUTCTime) -> a -> Maybe (SerializeUTCTime, SerializeUTCTime)
go req Nothing _ = Just (SerializeUTCTime $ requestTime req, SerializeUTCTime $ requestTime req)
go req (Just (startTime, _)) _ = Just (startTime, SerializeUTCTime $ requestTime req)
-- | Rollup, hold back bursty messages
--
-- Consider a case where you have a bursty set of data. You care to get an immediate response,
-- but don't want to spam the output
-- Consider a case where you have a bursty set of data. You care to get an immediate response,
-- but don't want to spam the output.
rollup
:: Int -- ^ How many items to pass through before burst protection
-> Int -- ` How many seconds to collect the bursty data
:: (Serialize a, Eq a)
=> Int -- ^ How many items to pass through before burst protection
-> Int -- ^ How many seconds to collect the bursty data
-> Mealy eff (Event a) (Event [a])
rollup limit seconds = mapAccumRequest go (Left Tick) (either id (\(_, _, _, ev) -> ev))
rollup limit seconds =
mapAccumRequest
go
(Left Tick)
(either id (\(_, _, _, ev) -> ev))
where
e a = Endo ([a] ++)
go :: Request -> Either (Event [a]) (UTCTime, Int, Endo [a], Event [a]) -> Event a -> Either (Event [a]) (UTCTime, Int, Endo [a], Event [a])
go _ (Left _) Tick = Left Tick
go req (Left _) (Event a) = Right (addUTCTime (fromIntegral seconds) (requestTime req), 1, mempty, Event [a])
go req (Right (end, n, acc, _)) Tick
| requestTime req >= end = Left (Event $ appEndo acc [])
| otherwise = Right (end, n, acc, Tick)
go req (Right (end, n, acc, _)) (Event a)
| requestTime req >= end = Left (Event $ appEndo acc [a])
| n < limit = Right (end, n+1, acc, Event [a])
| otherwise = Right (end, n+1, acc <> e a, Tick)
go
:: Request
-> Either (Event [a]) (SerializeUTCTime, Int, Seq a, Event [a])
-> Event a
-> Either (Event [a]) (SerializeUTCTime, Int, Seq a, Event [a])
go _ (Left _) Tick =
Left Tick
go req (Left _) (Event a) =
Right
( SerializeUTCTime $ addUTCTime (fromIntegral seconds) (requestTime req)
, 1
, mempty
, Event [a]
)
go req (Right (SerializeUTCTime end, n, acc, _)) Tick
| requestTime req >= end =
Left (Event $ F.toList acc)
| otherwise =
Right (SerializeUTCTime end, n, acc, Tick)
go req (Right (SerializeUTCTime end, n, acc, _)) (Event a)
| requestTime req >= end =
Left (Event $ F.toList (acc |> a))
| n < limit =
Right (SerializeUTCTime end, n + 1, acc, Event [a])
| otherwise =
Right (SerializeUTCTime end, n + 1, acc |> a, Tick)
-- Sliding window into the events
sliding :: Int -> Mealy eff (Event a) [a]
sliding :: (Serialize a, Eq a) => Int -> Mealy eff (Event a) [a]
sliding size = mapAccum go [] id
where
go :: [a] -> Event a -> [a]
go acc Tick = acc
go acc (Event a) = let xs = acc ++ [a] in drop (max 0 (length xs - size)) xs
fixed :: Int -> Mealy eff (Event a) [a]
fixed seconds = mapAccumRequest go Nothing (maybe [] ((`appEndo` []) . snd))
where
e a = Endo ([a] ++)
go :: Request -> Maybe (UTCTime, Endo [a]) -> Event a -> Maybe (UTCTime, Endo [a])
go req Nothing Tick = Just (addUTCTime (fromIntegral seconds) (requestTime req), mempty)
go req Nothing (Event a) = Just (addUTCTime (fromIntegral seconds) (requestTime req), e a)
go req (Just (end, acc)) ev =
case ev of
Tick | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, mempty)
| otherwise -> Just (end, acc)
Event a | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, e a)
| otherwise -> Just (end, acc <> e a)
currentTime :: Mealy eff a LocalTime
currentTime = Mealy mempty $ \_ Request{requestTime, requestTimeZone} _ ->
pure (Pair (utcToLocalTime requestTimeZone requestTime) currentTime)
currentTime = Mealy mempty $ \_nt -> Fun $ \Request{requestTime, requestTimeZone} _ ->
utcToLocalTime requestTimeZone requestTime
stepAuto :: Monad m => Auto m a b -> Request -> a -> m (b, Auto m a b)
stepAuto (Fun f) req a = pure (f req a, Fun f)
stepAuto (Stateful codec s f) req a = do
(b, s') <- f s req a
pure (b, Stateful codec s' f)
stepAutoSerializing :: MonadIO m => FilePath -> Auto m a b -> Request -> a -> m (b, Auto m a b)
stepAutoSerializing path f req a = do
(b,x) <- stepAuto f req a
y <- liftIO $ save path x
pure (b,y)
onEvent :: Mealy eff a () -> Mealy eff (Event a) ()
onEvent f = events >>> (arr (const ()) ||| f)