git.iko.soy/patch
on c2b8ccd help sign in
patch/src/Reflex/Time.hs
240 lines 9.9 kB history raw
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 #-}
11module Reflex.Time where
13import Reflex.Class
14import Reflex.Dynamic
15import Reflex.PerformEvent.Class
16import Reflex.PostBuild.Class
17import Reflex.TriggerEvent.Class
19import Control.Concurrent
20import qualified Control.Concurrent.Thread.Delay as Concurrent
21import Control.Lens hiding ((|>))
22import Control.Monad
23import Control.Monad.Fix
24import Control.Monad.IO.Class
25import Data.Align
26import Data.Fixed
27import Data.Sequence (Seq, (|>))
28import qualified Data.Sequence as Seq
29import Data.These
30import Data.Time.Clock
31import Data.Typeable
32import System.Random
34data 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)
44-- | Special case of tickLossyFrom that uses the post-build event to start the
45-- tick thread.
46tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)
47tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild
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
52tickLossyFrom
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)
61tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e
63-- | Generalization of tickLossyFrom that takes dt and t0 in the event.
64tickLossyFrom'
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)
71tickLossyFrom' 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)
79clockLossy :: (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)
80clockLossy dt t0 = do
81 initial <- liftIO $ getCurrentTick dt t0
82 e <- tickLossy dt t0
83 holdDyn initial e
85getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo
86getCurrentTick dt t0 = do
87 t <- getCurrentTime
88 let offset = t `diffUTCTime` t0
89 (n, alreadyElapsed) = offset `divMod'` dt
90 return $ TickInfo t n alreadyElapsed
92-- | Delay an Event's occurrences by a given amount in seconds.
93delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
94delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
95 Concurrent.delay $ ceiling $ dt * 1000000
96 cb a
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
101poissonLossyFrom
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)
114poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate
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
121poissonLossy
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)
129poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild
131-- | Send events with inhomogeneous Poisson timing with the given basis
132-- and variable rate. Provide a maxRate that you expect to support.
133inhomogeneousPoissonFrom
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)
141inhomogeneousPoissonFrom rnd rate maxRate t0 e = do
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
148 -- Filter homogeneous events according to associated
149 -- random values and the current rate parameter
150 return $ attachWithMaybe filterFun rate ticksWithRateRand
152 where
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
165 callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0
167 go tTargetLast lastGen cb lastN = do
168 t <- getCurrentTime
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
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
186-- | Send events with inhomogeneous Poisson timing with the given basis
187-- and variable rate. Provide a maxRate that you expect to support
188inhomogeneousPoisson
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)
195inhomogeneousPoisson rnd rate maxRate t0 =
196 inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
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.
200debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
201debounce 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
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.
210batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a))
211batchOccurrences 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
225#ifdef USE_TEMPLATE_HASKELL
226makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo
227#else
228tickInfo_lastUTC :: Lens' TickInfo UTCTime
229tickInfo_lastUTC f (TickInfo x1 x2 x3) = (\y -> TickInfo y x2 x3) <$> f x1
230{-# INLINE tickInfo_lastUTC #-}
232tickInfo_n :: Lens' TickInfo Integer
233tickInfo_n f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 y x3) <$> f x2
234{-# INLINE tickInfo_n #-}
236tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime
237tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3
238{-# INLINE tickInfo_alreadyElapsed #-}
239#endif