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