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