@@ -266,6 +266,86 @@ throttle t e = do
266266 delayed <- delay t outE
267267 return outE
268268
269+data ThrottleState b
270+ = Immediate
271+ | Buffered (ThrottleBuffer b)
272+
273+data ThrottleBuffer b
274+ = BEmpty -- Empty conflicts with lens, and hiding it would require turning
275+ -- on PatternSynonyms
276+ | Full b
277+
278+instance Semigroup b => Semigroup (ThrottleBuffer b) where
279+ BEmpty <> x = x
280+ x@(Full _) <> BEmpty = x
281+ Full b1 <> Full b2 = Full $ b1 <> b2
282+ {-# INLINE (<>) #-}
283+
284+instance Semigroup b => Monoid (ThrottleBuffer b) where
285+ mempty = BEmpty
286+ {-# INLINE mempty #-}
287+ mappend = (<>)
288+ {-# INLINE mappend #-}
289+
290+-- | Throttle an input event, ensuring that the output event doesn't occur more often than you are ready for it. If the input event occurs too
291+-- frequently, the output event will contain semigroup-based summaries of the input firings that happened since the last output firing.
292+-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.
293+-- The first parameter is a function that receives access to the output event, and should construct an event that fires when the receiver is
294+-- ready for more input. For example, using @delay 20@ would give a simple time-based throttle.
295+throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a)
296+-- Invariants:
297+-- * Immediate mode must turn off whenever output is produced.
298+-- * Output must be produced whenever immediate mode turns from on to off.
299+-- * Immediate mode can only go from off to on when the delayed event fires.
300+-- * Every input firing must go into either an immediate output firing or the
301+-- buffer, but not both.
302+-- * An existing full buffer must either stay in the buffer or go to output,
303+-- but not both.
304+throttleBatchWithLag lag e = do
305+ let f state x = case x of -- (Just $ newState, out)
306+ This a -> -- If only the input event fires
307+ case state of
308+ Immediate -> -- and we're in immediate mode
309+ -- Immediate mode turns off, and the buffer is empty.
310+ -- We fire the output event with the input event value immediately.
311+ (Just $ Buffered $ BEmpty, Just a)
312+ Buffered b -> -- and we're not in immediate mode
313+ -- Immediate mode remains off, and we accumulate the input value.
314+ -- We don't fire the output event.
315+ (Just $ Buffered $ b <> Full a, Nothing)
316+ That _ -> -- If only the delayed output event fires,
317+ case state of
318+ Immediate -> -- and we're in immediate mode
319+ -- Nothing happens.
320+ (Nothing, Nothing)
321+ Buffered BEmpty -> -- and the buffer is empty:
322+ -- Immediate mode turns back on, and the buffer remains empty.
323+ -- We don't fire.
324+ (Just Immediate, Nothing)
325+ Buffered (Full b) -> -- and the buffer is full:
326+ -- Immediate mode remains off, and the buffer is cleared.
327+ -- We fire with the buffered value.
328+ (Just $ Buffered BEmpty, Just b)
329+ These a _ -> -- If both the input and delayed output event fire simultaneously:
330+ case state of
331+ Immediate -> -- and we're in immediate mode
332+ -- Immediate mode turns off, and the buffer is empty.
333+ -- We fire with the input event's value, as it is the most recent we have seen at this moment.
334+ (Just $ Buffered BEmpty, Just a)
335+ Buffered BEmpty -> -- and the buffer is empty:
336+ -- Immediate mode stays off, and the buffer remains empty.
337+ -- We fire with the input event's value.
338+ (Just $ Buffered BEmpty, Just a)
339+ Buffered (Full b) -> -- and the buffer is full:
340+ -- Immediate mode remains off, and the buffer is cleared.
341+ -- We fire with everything including the buffered value.
342+ (Just $ Buffered BEmpty, Just (b <> a))
343+ rec (_stateDyn, outE) <- mapAccumMaybeDyn f
344+ Immediate -- We start in immediate mode with an empty buffer.
345+ (align e delayed)
346+ delayed <- lag (void outE)
347+ return outE
348+
269349#ifdef USE_TEMPLATE_HASKELL
270350makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo
271351#else