git.iko.soy/patch
on 08414ed help sign in
patch/src/Reflex/Time.hs
284 lines 13 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE RecursiveDo #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE TypeFamilies #-}
9#ifdef USE_TEMPLATE_HASKELL
10{-# LANGUAGE TemplateHaskell #-}
11#endif
12module Reflex.Time where
14import Reflex.Class
15import Reflex.Dynamic
16import Reflex.PerformEvent.Class
17import Reflex.PostBuild.Class
18import Reflex.TriggerEvent.Class
20import Control.Concurrent
21import qualified Control.Concurrent.Thread.Delay as Concurrent
22import Control.Lens hiding ((|>))
23import Control.Monad
24import Control.Monad.Fix
25import Control.Monad.IO.Class
26import Data.Align
27import Data.Fixed
28import Data.Sequence (Seq, (|>))
29import qualified Data.Sequence as Seq
30import Data.These
31import Data.Time.Clock
32import Data.Typeable
33import System.Random
35data TickInfo
36 = TickInfo { _tickInfo_lastUTC :: UTCTime
37 -- ^ UTC time immediately after the last tick.
38 , _tickInfo_n :: Integer
39 -- ^ Number of time periods since t0
40 , _tickInfo_alreadyElapsed :: NominalDiffTime
41 -- ^ Amount of time already elapsed in the current tick period.
42 }
43 deriving (Eq, Ord, Show, Typeable)
45-- | Special case of 'tickLossyFrom' that uses the post-build event to start the
46-- tick thread.
47tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)
48tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild
50-- | Special case of 'tickLossyFrom' that uses the post-build event to start the
51-- tick thread and the time of the post-build as the tick basis time.
52tickLossyFromPostBuildTime :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> m (Event t TickInfo)
53tickLossyFromPostBuildTime dt = do
54 postBuild <- getPostBuild
55 postBuildTime <- performEvent $ liftIO getCurrentTime <$ postBuild
56 tickLossyFrom' $ (dt,) <$> postBuildTime
58-- | Send events over time with the given basis time and interval
59-- If the system starts running behind, occurrences will be dropped rather than buffered
60-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time
61tickLossyFrom
62 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
63 => NominalDiffTime
64 -- ^ The length of a tick interval
65 -> UTCTime
66 -- ^ The basis time from which intervals count
67 -> Event t a
68 -- ^ Event that starts a tick generation thread. Usually you want this to
69 -- be something like the result of getPostBuild that only fires once. But
70 -- there could be uses for starting multiple timer threads.
71 -> m (Event t TickInfo)
72tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e
74-- | Generalization of tickLossyFrom that takes dt and t0 in the event.
75tickLossyFrom'
76 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
77 => Event t (NominalDiffTime, UTCTime)
78 -- ^ Event that starts a tick generation thread. Usually you want this to
79 -- be something like the result of getPostBuild that only fires once. But
80 -- there could be uses for starting multiple timer threads.
81 -> m (Event t TickInfo)
82tickLossyFrom' e = do
83 rec result <- performEventAsync $ callAtNextInterval <$> leftmost [e, snd <$> result]
84 return $ fst <$> result
85 where callAtNextInterval pair cb = void $ liftIO $ forkIO $ do
86 tick <- uncurry getCurrentTick pair
87 Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000
88 cb (tick, pair)
90clockLossy :: (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)
91clockLossy dt t0 = do
92 initial <- liftIO $ getCurrentTick dt t0
93 e <- tickLossy dt t0
94 holdDyn initial e
96getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo
97getCurrentTick dt t0 = do
98 t <- getCurrentTime
99 let offset = t `diffUTCTime` t0
100 (n, alreadyElapsed) = offset `divMod'` dt
101 return $ TickInfo t n alreadyElapsed
103-- | Delay an Event's occurrences by a given amount in seconds.
104delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
105delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
106 Concurrent.delay $ ceiling $ dt * 1000000
107 cb a
109-- | Send events with Poisson timing with the given basis and rate
110-- Each occurrence of the resulting event will contain the index of
111-- the current interval, with 0 representing the basis time
112poissonLossyFrom
113 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
114 => g
115 -> Double
116 -- ^ Poisson event rate (Hz)
117 -> UTCTime
118 -- ^ Baseline time for events
119 -> Event t a
120 -- ^ Event that starts a tick generation thread. Usually you want this to
121 -- be something like the result of getPostBuild that only fires once. But
122 -- there could be uses for starting multiple timer threads.
123 -- Start sending events in response to the event parameter.
124 -> m (Event t TickInfo)
125poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate
128-- | Send events with Poisson timing with the given basis and rate
129-- Each occurrence of the resulting event will contain the index of
130-- the current interval, with 0 representing the basis time.
131-- Automatically begin sending events when the DOM is built
132poissonLossy
133 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
134 => g
135 -> Double
136 -- ^ Poisson event rate (Hz)
137 -> UTCTime
138 -- ^ Baseline time for events
139 -> m (Event t TickInfo)
140poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild
142-- | Send events with inhomogeneous Poisson timing with the given basis
143-- and variable rate. Provide a maxRate that you expect to support.
144inhomogeneousPoissonFrom
145 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
146 => g
147 -> Behavior t Double
148 -> Double
149 -> UTCTime
150 -> Event t a
151 -> m (Event t TickInfo)
152inhomogeneousPoissonFrom rnd rate maxRate t0 e = do
154 -- Create a thread for producing homogeneous poisson events
155 -- along with random Doubles (usage of Double's explained below)
156 ticksWithRateRand <- performEventAsync $
157 fmap callAtNextInterval e
159 -- Filter homogeneous events according to associated
160 -- random values and the current rate parameter
161 return $ attachWithMaybe filterFun rate ticksWithRateRand
163 where
165 -- Inhomogeneous poisson processes are built from faster
166 -- homogeneous ones by randomly dropping events from the
167 -- fast process. For each fast homogeneous event, choose
168 -- a uniform random sample from (0, rMax). If the
169 -- inhomogeneous rate at this moment is greater than the
170 -- random sample, then keep this event, otherwise drop it
171 filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo
172 filterFun r (tInfo, p)
173 | r >= p = Just tInfo
174 | otherwise = Nothing
176 callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0
178 go tTargetLast lastGen cb lastN = do
179 t <- getCurrentTime
181 -- Generate random numbers for this poisson interval (u)
182 -- and sample-retention likelihood (p)
183 let (u, nextGen) = randomR (0,1) lastGen
184 (p :: Double, nextGen') = randomR (0,maxRate) nextGen
186 -- Inter-event interval is drawn from exponential
187 -- distribution accourding to u
188 let dt = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime
189 nEvents = lastN + 1
190 alreadyElapsed = diffUTCTime t tTargetLast
191 tTarget = addUTCTime dt tTargetLast
192 thisDelay = realToFrac $ diffUTCTime tTarget t :: Double
193 Concurrent.delay $ ceiling $ thisDelay * 1000000
194 _ <- cb (TickInfo t nEvents alreadyElapsed, p)
195 go tTarget nextGen' cb nEvents
197-- | Send events with inhomogeneous Poisson timing with the given basis
198-- and variable rate. Provide a maxRate that you expect to support
199inhomogeneousPoisson
200 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
201 => g
202 -> Behavior t Double
203 -> Double
204 -> UTCTime
205 -> m (Event t TickInfo)
206inhomogeneousPoisson rnd rate maxRate t0 =
207 inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
209-- | Block occurrences of an Event until the given number of seconds elapses without
210-- the Event firing, at which point the last occurrence of the Event will fire.
211debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
212debounce dt e = do
213 n :: Dynamic t Integer <- count e
214 let tagged = attachPromptlyDynWith (,) n e
215 delayed <- delay dt tagged
216 return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed
218-- | When the given 'Event' occurs, wait the given amount of time and collect
219-- all occurrences during that time. Then, fire the output 'Event' with the
220-- collected output.
221batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a))
222batchOccurrences t newValues = do
223 let f s x = (Just newState, out)
224 where newState = case x of
225 This a -> s |> a
226 That _ -> mempty
227 These a _ -> Seq.singleton a
228 out = case x of
229 This _ -> if Seq.null s then Just () else Nothing
230 That _ -> Nothing
231 These _ _ -> Just ()
232 rec (buffer, toDelay) <- mapAccumMaybe f mempty $ align newValues delayed
233 delayed <- delay t toDelay
234 return $ tag buffer delayed
236-- | 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
237-- frequently, the output event occurs with the most recently seen input value after the given delay passes since the last occurrence of the output.
238-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.
239throttle :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
240throttle t e = do
241 let f (immediate, buffer) x = case x of -- (Just newState, out)
242 This a -- If only the input event fires
243 | immediate -> -- and we're in immediate mode
244 -- Immediate mode turns off, and the buffer is empty.
245 -- We fire the output event with the input event value immediately.
246 (Just (False, Nothing), Just a)
247 | otherwise -> -- and we're not in immediate mode
248 -- Immediate mode remains off, and we replace the contents of the buffer (if any) with the input value.
249 -- We don't fire the output event.
250 (Just (False, Just a), Nothing)
251 That _ -> -- If only the delayed output event fires,
252 case buffer of
253 Nothing -> -- and the buffer is empty:
254 -- Immediate mode turns back on, and the buffer remains empty.
255 -- We don't fire.
256 (Just (True, Nothing), Nothing)
257 Just b -> -- and the buffer is full:
258 -- Immediate mode remains off, and the buffer is cleared.
259 -- We fire with the buffered value.
260 (Just (False, Nothing), Just b)
261 These a _ -> -- If both the input and delayed output event fire simultaneously:
262 -- Immediate mode turns off, and the buffer is empty.
263 -- We fire with the input event's value, as it is the most recent we have seen at this moment.
264 (Just (False, Nothing), Just a)
265 rec (_, outE) <- mapAccumMaybeDyn f (True, Nothing) $ align e delayed -- We start in immediate mode with an empty buffer.
266 delayed <- delay t outE
267 return outE
269#ifdef USE_TEMPLATE_HASKELL
270makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo
271#else
272tickInfo_lastUTC :: Lens' TickInfo UTCTime
273tickInfo_lastUTC f (TickInfo x1 x2 x3) = (\y -> TickInfo y x2 x3) <$> f x1
274{-# INLINE tickInfo_lastUTC #-}
276tickInfo_n :: Lens' TickInfo Integer
277tickInfo_n f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 y x3) <$> f x2
278{-# INLINE tickInfo_n #-}
280tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime
281tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3
282{-# INLINE tickInfo_alreadyElapsed #-}
283#endif