git.iko.soy/patch
on 032e6b2 help sign in
patch/src/Reflex/Time.hs
374 lines 18 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveTraversable #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE RecursiveDo #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TupleSections #-}
10{-# LANGUAGE TypeFamilies #-}
11#ifdef USE_TEMPLATE_HASKELL
12{-# LANGUAGE TemplateHaskell #-}
13#endif
14module Reflex.Time where
16import Reflex.Class
17import Reflex.Dynamic
18import Reflex.PerformEvent.Class
19import Reflex.PostBuild.Class
20import Reflex.TriggerEvent.Class
22import Control.Concurrent
23import qualified Control.Concurrent.Thread.Delay as Concurrent
24import Control.Lens hiding ((|>))
25import Control.Monad
26import Control.Monad.Fix
27import Control.Monad.IO.Class
28import Data.Align
29import Data.Data (Data)
30import Data.Fixed
31import Data.Semigroup
32import Data.Sequence (Seq, (|>))
33import qualified Data.Sequence as Seq
34import Data.These
35import Data.Time.Clock
36import Data.Typeable
37import GHC.Generics (Generic)
38import System.Random
40data TickInfo
41 = TickInfo { _tickInfo_lastUTC :: UTCTime
42 -- ^ UTC time immediately after the last tick.
43 , _tickInfo_n :: Integer
44 -- ^ Number of time periods since t0
45 , _tickInfo_alreadyElapsed :: NominalDiffTime
46 -- ^ Amount of time already elapsed in the current tick period.
47 }
48 deriving (Eq, Ord, Show, Typeable)
50-- | Special case of 'tickLossyFrom' that uses the post-build event to start the
51-- tick thread.
52tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)
53tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild
55-- | Special case of 'tickLossyFrom' that uses the post-build event to start the
56-- tick thread and the time of the post-build as the tick basis time.
57tickLossyFromPostBuildTime :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> m (Event t TickInfo)
58tickLossyFromPostBuildTime dt = do
59 postBuild <- getPostBuild
60 postBuildTime <- performEvent $ liftIO getCurrentTime <$ postBuild
61 tickLossyFrom' $ (dt,) <$> postBuildTime
63-- | Send events over time with the given basis time and interval
64-- If the system starts running behind, occurrences will be dropped rather than buffered
65-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time
66tickLossyFrom
67 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
68 => NominalDiffTime
69 -- ^ The length of a tick interval
70 -> UTCTime
71 -- ^ The basis time from which intervals count
72 -> Event t a
73 -- ^ Event that starts a tick generation thread. Usually you want this to
74 -- be something like the result of getPostBuild that only fires once. But
75 -- there could be uses for starting multiple timer threads.
76 -> m (Event t TickInfo)
77tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e
79-- | Generalization of tickLossyFrom that takes dt and t0 in the event.
80tickLossyFrom'
81 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
82 => Event t (NominalDiffTime, UTCTime)
83 -- ^ Event that starts a tick generation thread. Usually you want this to
84 -- be something like the result of getPostBuild that only fires once. But
85 -- there could be uses for starting multiple timer threads.
86 -> m (Event t TickInfo)
87tickLossyFrom' e = do
88 rec result <- performEventAsync $ callAtNextInterval <$> leftmost [e, snd <$> result]
89 return $ fst <$> result
90 where callAtNextInterval pair cb = void $ liftIO $ forkIO $ do
91 tick <- uncurry getCurrentTick pair
92 Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000
93 cb (tick, pair)
95clockLossy :: (MonadIO m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), PostBuild t m, MonadHold t m, MonadFix m) => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo)
96clockLossy dt t0 = do
97 initial <- liftIO $ getCurrentTick dt t0
98 e <- tickLossy dt t0
99 holdDyn initial e
101getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo
102getCurrentTick dt t0 = do
103 t <- getCurrentTime
104 let offset = t `diffUTCTime` t0
105 (n, alreadyElapsed) = offset `divMod'` dt
106 return $ TickInfo t n alreadyElapsed
108-- | Delay an Event's occurrences by a given amount in seconds.
109delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
110delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
111 Concurrent.delay $ ceiling $ dt * 1000000
112 cb a
114-- | Send events with Poisson timing with the given basis and rate
115-- Each occurrence of the resulting event will contain the index of
116-- the current interval, with 0 representing the basis time
117poissonLossyFrom
118 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
119 => g
120 -> Double
121 -- ^ Poisson event rate (Hz)
122 -> UTCTime
123 -- ^ Baseline time for events
124 -> Event t a
125 -- ^ Event that starts a tick generation thread. Usually you want this to
126 -- be something like the result of getPostBuild that only fires once. But
127 -- there could be uses for starting multiple timer threads.
128 -- Start sending events in response to the event parameter.
129 -> m (Event t TickInfo)
130poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate
133-- | Send events with Poisson timing with the given basis and rate
134-- Each occurrence of the resulting event will contain the index of
135-- the current interval, with 0 representing the basis time.
136-- Automatically begin sending events when the DOM is built
137poissonLossy
138 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
139 => g
140 -> Double
141 -- ^ Poisson event rate (Hz)
142 -> UTCTime
143 -- ^ Baseline time for events
144 -> m (Event t TickInfo)
145poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild
147-- | Send events with inhomogeneous Poisson timing with the given basis
148-- and variable rate. Provide a maxRate that you expect to support.
149inhomogeneousPoissonFrom
150 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
151 => g
152 -> Behavior t Double
153 -> Double
154 -> UTCTime
155 -> Event t a
156 -> m (Event t TickInfo)
157inhomogeneousPoissonFrom rnd rate maxRate t0 e = do
159 -- Create a thread for producing homogeneous poisson events
160 -- along with random Doubles (usage of Double's explained below)
161 ticksWithRateRand <- performEventAsync $
162 fmap callAtNextInterval e
164 -- Filter homogeneous events according to associated
165 -- random values and the current rate parameter
166 return $ attachWithMaybe filterFun rate ticksWithRateRand
168 where
170 -- Inhomogeneous poisson processes are built from faster
171 -- homogeneous ones by randomly dropping events from the
172 -- fast process. For each fast homogeneous event, choose
173 -- a uniform random sample from (0, rMax). If the
174 -- inhomogeneous rate at this moment is greater than the
175 -- random sample, then keep this event, otherwise drop it
176 filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo
177 filterFun r (tInfo, p)
178 | r >= p = Just tInfo
179 | otherwise = Nothing
181 callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0
183 go tTargetLast lastGen cb lastN = do
184 t <- getCurrentTime
186 -- Generate random numbers for this poisson interval (u)
187 -- and sample-retention likelihood (p)
188 let (u, nextGen) = randomR (0,1) lastGen
189 (p :: Double, nextGen') = randomR (0,maxRate) nextGen
191 -- Inter-event interval is drawn from exponential
192 -- distribution accourding to u
193 let dt = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime
194 nEvents = lastN + 1
195 alreadyElapsed = diffUTCTime t tTargetLast
196 tTarget = addUTCTime dt tTargetLast
197 thisDelay = realToFrac $ diffUTCTime tTarget t :: Double
198 Concurrent.delay $ ceiling $ thisDelay * 1000000
199 _ <- cb (TickInfo t nEvents alreadyElapsed, p)
200 go tTarget nextGen' cb nEvents
202-- | Send events with inhomogeneous Poisson timing with the given basis
203-- and variable rate. Provide a maxRate that you expect to support
204inhomogeneousPoisson
205 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
206 => g
207 -> Behavior t Double
208 -> Double
209 -> UTCTime
210 -> m (Event t TickInfo)
211inhomogeneousPoisson rnd rate maxRate t0 =
212 inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
214-- | Block occurrences of an Event until the given number of seconds elapses without
215-- the Event firing, at which point the last occurrence of the Event will fire.
216debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
217debounce dt e = do
218 n :: Dynamic t Integer <- count e
219 let tagged = attachPromptlyDynWith (,) n e
220 delayed <- delay dt tagged
221 return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed
223-- | When the given 'Event' occurs, wait the given amount of time and collect
224-- all occurrences during that time. Then, fire the output 'Event' with the
225-- collected output.
226batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a))
227batchOccurrences t newValues = do
228 let f s x = (Just newState, out)
229 where newState = case x of
230 This a -> s |> a
231 That _ -> mempty
232 These a _ -> Seq.singleton a
233 out = case x of
234 This _ -> if Seq.null s then Just () else Nothing
235 That _ -> Nothing
236 These _ _ -> Just ()
237 rec (buffer, toDelay) <- mapAccumMaybe f mempty $ align newValues delayed
238 delayed <- delay t toDelay
239 return $ tag buffer delayed
241-- | Throttle an input event, ensuring that at least a given amount of time passes between occurrences of the output event. If the input event occurs too
242-- frequently, the output event occurs with the most recently seen input value after the given delay passes since the last occurrence of the output.
243-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.
244throttle :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
245throttle t e = do
246 let f (immediate, buffer) x = case x of -- (Just newState, out)
247 This a -- If only the input event fires
248 | immediate -> -- and we're in immediate mode
249 -- Immediate mode turns off, and the buffer is empty.
250 -- We fire the output event with the input event value immediately.
251 (Just (False, Nothing), Just a)
252 | otherwise -> -- and we're not in immediate mode
253 -- Immediate mode remains off, and we replace the contents of the buffer (if any) with the input value.
254 -- We don't fire the output event.
255 (Just (False, Just a), Nothing)
256 That _ -> -- If only the delayed output event fires,
257 case buffer of
258 Nothing -> -- and the buffer is empty:
259 -- Immediate mode turns back on, and the buffer remains empty.
260 -- We don't fire.
261 (Just (True, Nothing), Nothing)
262 Just b -> -- and the buffer is full:
263 -- Immediate mode remains off, and the buffer is cleared.
264 -- We fire with the buffered value.
265 (Just (False, Nothing), Just b)
266 These a _ -> -- If both the input and delayed output event fire simultaneously:
267 -- Immediate mode turns off, and the buffer is empty.
268 -- We fire with the input event's value, as it is the most recent we have seen at this moment.
269 (Just (False, Nothing), Just a)
270 rec (_, outE) <- mapAccumMaybeDyn f (True, Nothing) $ align e delayed -- We start in immediate mode with an empty buffer.
271 delayed <- delay t outE
272 return outE
274data ThrottleState b
275 = ThrottleState_Immediate
276 | ThrottleState_Buffered (ThrottleBuffer b)
277 deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)
279data ThrottleBuffer b
280 = ThrottleBuffer_Empty -- Empty conflicts with lens, and hiding it would require turning
281 -- on PatternSynonyms
282 | ThrottleBuffer_Full b
283 deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)
285instance Semigroup b => Semigroup (ThrottleBuffer b) where
286 x <> y = case x of
287 ThrottleBuffer_Empty -> y
288 ThrottleBuffer_Full b1 -> case y of
289 ThrottleBuffer_Empty -> x
290 ThrottleBuffer_Full b2 -> ThrottleBuffer_Full $ b1 <> b2
291 {-# INLINE (<>) #-}
293instance Semigroup b => Monoid (ThrottleBuffer b) where
294 mempty = ThrottleBuffer_Empty
295 {-# INLINE mempty #-}
296 mappend = (<>)
297 {-# INLINE mappend #-}
299-- | 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
300-- frequently, the output event will contain semigroup-based summaries of the input firings that happened since the last output firing.
301-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.
302-- The first parameter is a function that receives access to the output event, and should construct an event that fires when the receiver is
303-- ready for more input. For example, using @delay 20@ would give a simple time-based throttle.
304--
305-- NB: The provided lag function must *actually* delay the event.
306throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a)
307-- Invariants:
308-- * Immediate mode must turn off whenever output is produced.
309-- * Output must be produced whenever immediate mode turns from on to off.
310-- * Immediate mode can only go from off to on when the delayed event fires.
311-- * Every input firing must go into either an immediate output firing or the
312-- buffer, but not both.
313-- * An existing full buffer must either stay in the buffer or go to output,
314-- but not both.
315throttleBatchWithLag lag e = do
316 let f state x = case x of -- (Just $ newState, out)
317 This a -> -- If only the input event fires
318 case state of
319 ThrottleState_Immediate -> -- and we're in immediate mode
320 -- Immediate mode turns off, and the buffer is empty.
321 -- We fire the output event with the input event value immediately.
322 (Just $ ThrottleState_Buffered $ ThrottleBuffer_Empty, Just a)
323 ThrottleState_Buffered b -> -- and we're not in immediate mode
324 -- Immediate mode remains off, and we accumulate the input value.
325 -- We don't fire the output event.
326 (Just $ ThrottleState_Buffered $ b <> ThrottleBuffer_Full a, Nothing)
327 That _ -> -- If only the delayed output event fires,
328 case state of
329 ThrottleState_Immediate -> -- and we're in immediate mode
330 -- Nothing happens.
331 (Nothing, Nothing)
332 ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:
333 -- Immediate mode turns back on, and the buffer remains empty.
334 -- We don't fire.
335 (Just ThrottleState_Immediate, Nothing)
336 ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:
337 -- Immediate mode remains off, and the buffer is cleared.
338 -- We fire with the buffered value.
339 (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just b)
340 These a _ -> -- If both the input and delayed output event fire simultaneously:
341 case state of
342 ThrottleState_Immediate -> -- and we're in immediate mode
343 -- Immediate mode turns off, and the buffer is empty.
344 -- We fire with the input event's value, as it is the most recent we have seen at this moment.
345 (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)
346 ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:
347 -- Immediate mode stays off, and the buffer remains empty.
348 -- We fire with the input event's value.
349 (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)
350 ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:
351 -- Immediate mode remains off, and the buffer is cleared.
352 -- We fire with everything including the buffered value.
353 (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just (b <> a))
354 rec (_stateDyn, outE) <- mapAccumMaybeDyn f
355 ThrottleState_Immediate -- We start in immediate mode with an empty buffer.
356 (align e delayed)
357 delayed <- lag (void outE)
358 return outE
360#ifdef USE_TEMPLATE_HASKELL
361makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo
362#else
363tickInfo_lastUTC :: Lens' TickInfo UTCTime
364tickInfo_lastUTC f (TickInfo x1 x2 x3) = (\y -> TickInfo y x2 x3) <$> f x1
365{-# INLINE tickInfo_lastUTC #-}
367tickInfo_n :: Lens' TickInfo Integer
368tickInfo_n f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 y x3) <$> f x2
369{-# INLINE tickInfo_n #-}
371tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime
372tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3
373{-# INLINE tickInfo_alreadyElapsed #-}
374#endif