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