git.iko.soy/reflex-dom
on efaaa52 help sign in
reflex-dom/src/Reflex/Dom/Time.hs
218 lines 9.3 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE RecursiveDo #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeFamilies #-}
7module Reflex.Dom.Time where
9import Reflex.Class
10import Reflex.Dynamic
11import Reflex.PerformEvent.Class
12import Reflex.PostBuild.Class
13import Reflex.TriggerEvent.Class
15import Control.Concurrent
16import qualified Control.Concurrent.Thread.Delay as Concurrent
17import Control.Monad
18import Control.Monad.Fix
19import Control.Monad.IO.Class
20import Data.Align
21import Data.Fixed
22import Data.Sequence (Seq, (|>))
23import qualified Data.Sequence as Seq
24import Data.These
25import Data.Time.Clock
26import Data.Typeable
27import System.Random
29data TickInfo
30 = TickInfo { _tickInfo_lastUTC :: UTCTime
31 -- ^ UTC time immediately after the last tick.
32 , _tickInfo_n :: Integer
33 -- ^ Number of time periods since t0
34 , _tickInfo_alreadyElapsed :: NominalDiffTime
35 -- ^ Amount of time already elapsed in the current tick period.
36 }
37 deriving (Eq, Ord, Show, Typeable)
39-- | Special case of tickLossyFrom that uses the post-build event to start the
40-- tick thread.
41tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)
42tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild
44-- | Send events over time with the given basis time and interval
45-- If the system starts running behind, occurrences will be dropped rather than buffered
46-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time
47tickLossyFrom
48 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
49 => NominalDiffTime
50 -> UTCTime
51 -> Event t a
52 -- ^ Event that starts a tick generation thread. Usually you want this to
53 -- be something like the result of getPostBuild that only fires once. But
54 -- there could be uses for starting multiple timer threads.
55 -> m (Event t TickInfo)
56tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e
58-- | Generalization of tickLossyFrom that takes dt and t0 in the event.
59tickLossyFrom'
60 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
61 => Event t (NominalDiffTime, UTCTime)
62 -- ^ Event that starts a tick generation thread. Usually you want this to
63 -- be something like the result of getPostBuild that only fires once. But
64 -- there could be uses for starting multiple timer threads.
65 -> m (Event t TickInfo)
66tickLossyFrom' e = do
67 rec result <- performEventAsync $ callAtNextInterval <$> leftmost [e, snd <$> result]
68 return $ fst <$> result
69 where callAtNextInterval pair cb = void $ liftIO $ forkIO $ do
70 tick <- uncurry getCurrentTick pair
71 Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000
72 cb (tick, pair)
74clockLossy :: (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)
75clockLossy dt t0 = do
76 initial <- liftIO $ getCurrentTick dt t0
77 e <- tickLossy dt t0
78 holdDyn initial e
80getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo
81getCurrentTick dt t0 = do
82 t <- getCurrentTime
83 let offset = t `diffUTCTime` t0
84 (n, alreadyElapsed) = offset `divMod'` dt
85 return $ TickInfo t n alreadyElapsed
87-- | Delay an Event's occurrences by a given amount in seconds.
88delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
89delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
90 Concurrent.delay $ ceiling $ dt * 1000000
91 cb a
93-- | Send events with Poisson timing with the given basis and rate
94-- Each occurence of the resulting event will contain the index of
95-- the current interval, with 0 representing the basis time
96poissonLossyFrom
97 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
98 => g
99 -> Double
100 -- ^ Poisson event rate (Hz)
101 -> UTCTime
102 -- ^ Baseline time for events
103 -> Event t a
104 -- ^ Event that starts a tick generation thread. Usually you want this to
105 -- be something like the result of getPostBuild that only fires once. But
106 -- there could be uses for starting multiple timer threads.
107 -- Start sending events in response to the event parameter.
108 -> m (Event t TickInfo)
109poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate
112-- | Send events with Poisson timing with the given basis and rate
113-- Each occurence of the resulting event will contain the index of
114-- the current interval, with 0 representing the basis time.
115-- Automatically begin sending events when the DOM is built
116poissonLossy
117 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
118 => g
119 -> Double
120 -- ^ Poisson event rate (Hz)
121 -> UTCTime
122 -- ^ Baseline time for events
123 -> m (Event t TickInfo)
124poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild
126-- | Send events with inhomogeneous Poisson timing with the given basis
127-- and variable rate. Provide a maxRate that you expect to support.
128inhomogeneousPoissonFrom
129 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
130 => g
131 -> Behavior t Double
132 -> Double
133 -> UTCTime
134 -> Event t a
135 -> m (Event t TickInfo)
136inhomogeneousPoissonFrom rnd rate maxRate t0 e = do
138 -- Create a thread for producing homogeneous poisson events
139 -- along with random Doubles (usage of Double's explained below)
140 ticksWithRateRand <- performEventAsync $
141 fmap callAtNextInterval e
143 -- Filter homogeneous events according to associated
144 -- random values and the current rate parameter
145 return $ attachWithMaybe filterFun rate ticksWithRateRand
147 where
149 -- Inhomogeneous poisson processes are built from faster
150 -- homogeneous ones by randomly dropping events from the
151 -- fast process. For each fast homogeneous event, choose
152 -- a uniform random sample from (0, rMax). If the
153 -- inhomogeneous rate at this moment is greater than the
154 -- random sample, then keep this event, otherwise drop it
155 filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo
156 filterFun r (tInfo, p)
157 | r >= p = Just tInfo
158 | otherwise = Nothing
160 callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0
162 go tTargetLast lastGen cb lastN = do
163 t <- getCurrentTime
165 -- Generate random numbers for this poisson interval (u)
166 -- and sample-retention likelihood (p)
167 let (u, nextGen) = randomR (0,1) lastGen
168 (p :: Double, nextGen') = randomR (0,maxRate) nextGen
170 -- Inter-event interval is drawn from exponential
171 -- distribution accourding to u
172 let dt = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime
173 nEvents = lastN + 1
174 alreadyElapsed = diffUTCTime t tTargetLast
175 tTarget = addUTCTime dt tTargetLast
176 thisDelay = realToFrac $ diffUTCTime tTarget t :: Double
177 Concurrent.delay $ ceiling $ thisDelay * 1000000
178 _ <- cb (TickInfo t nEvents alreadyElapsed, p)
179 go tTarget nextGen' cb nEvents
181-- | Send events with inhomogeneous Poisson timing with the given basis
182-- and variable rate. Provide a maxRate that you expect to support
183inhomogeneousPoisson
184 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
185 => g
186 -> Behavior t Double
187 -> Double
188 -> UTCTime
189 -> m (Event t TickInfo)
190inhomogeneousPoisson rnd rate maxRate t0 =
191 inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
193-- | Block occurrences of an Event until the given number of seconds elapses without
194-- the Event firing, at which point the last occurrence of the Event will fire.
195debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
196debounce dt e = do
197 n :: Dynamic t Integer <- count e
198 let tagged = attachPromptlyDynWith (,) n e
199 delayed <- delay dt tagged
200 return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed
202-- | When the given 'Event' occurs, wait the given amount of time and collect
203-- all occurrences during that time. Then, fire the output 'Event' with the
204-- collected output.
205batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a))
206batchOccurrences t newValues = do
207 let f s x = (Just newState, out)
208 where newState = case x of
209 This a -> s |> a
210 That _ -> mempty
211 These a _ -> Seq.singleton a
212 out = case x of
213 This _ -> if Seq.null s then Just () else Nothing
214 That _ -> Nothing
215 These _ _ -> Just ()
216 rec (buffer, toDelay) <- mapAccumMaybe f mempty $ align newValues delayed
217 delayed <- delay t toDelay
218 return $ tag buffer delayed