@@ -1,218 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE RecursiveDo #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
7−module Reflex.Dom.Time where
8−
9−import Reflex.Class
10−import Reflex.Dynamic
11−import Reflex.PerformEvent.Class
12−import Reflex.PostBuild.Class
13−import Reflex.TriggerEvent.Class
14−
15−import Control.Concurrent
16−import qualified Control.Concurrent.Thread.Delay as Concurrent
17−import Control.Monad
18−import Control.Monad.Fix
19−import Control.Monad.IO.Class
20−import Data.Align
21−import Data.Fixed
22−import Data.Sequence (Seq, (|>))
23−import qualified Data.Sequence as Seq
24−import Data.These
25−import Data.Time.Clock
26−import Data.Typeable
27−import System.Random
28−
29−data 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)
38−
39−-- | Special case of tickLossyFrom that uses the post-build event to start the
40−-- tick thread.
41−tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)
42−tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild
43−
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
47−tickLossyFrom
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)
56−tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e
57−
58−-- | Generalization of tickLossyFrom that takes dt and t0 in the event.
59−tickLossyFrom'
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)
66−tickLossyFrom' 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)
73−
74−clockLossy :: (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)
75−clockLossy dt t0 = do
76− initial <- liftIO $ getCurrentTick dt t0
77− e <- tickLossy dt t0
78− holdDyn initial e
79−
80−getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo
81−getCurrentTick dt t0 = do
82− t <- getCurrentTime
83− let offset = t `diffUTCTime` t0
84− (n, alreadyElapsed) = offset `divMod'` dt
85− return $ TickInfo t n alreadyElapsed
86−
87−-- | Delay an Event's occurrences by a given amount in seconds.
88−delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
89−delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
90− Concurrent.delay $ ceiling $ dt * 1000000
91− cb a
92−
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
96−poissonLossyFrom
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)
109−poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate
110−
111−
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
116−poissonLossy
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)
124−poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild
125−
126−-- | Send events with inhomogeneous Poisson timing with the given basis
127−-- and variable rate. Provide a maxRate that you expect to support.
128−inhomogeneousPoissonFrom
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)
136−inhomogeneousPoissonFrom rnd rate maxRate t0 e = do
137−
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
142−
143− -- Filter homogeneous events according to associated
144− -- random values and the current rate parameter
145− return $ attachWithMaybe filterFun rate ticksWithRateRand
146−
147− where
148−
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
159−
160− callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0
161−
162− go tTargetLast lastGen cb lastN = do
163− t <- getCurrentTime
164−
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
169−
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
180−
181−-- | Send events with inhomogeneous Poisson timing with the given basis
182−-- and variable rate. Provide a maxRate that you expect to support
183−inhomogeneousPoisson
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)
190−inhomogeneousPoisson rnd rate maxRate t0 =
191− inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
192−
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.
195−debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
196−debounce 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
201−
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.
205−batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a))
206−batchOccurrences 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