blob: ba423def49d77cae033a34046ed8f1d3bb054d60 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
module Ticker where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Function
import Data.Time.Clock.POSIX
import Data.Typeable
data ScheduleTick = ScheduleTick Int deriving (Show, Typeable)
instance Exception ScheduleTick
newtype Ticker = Ticker ThreadId
-- | Fork a thread that will invoke an STM transaction whenever a tick event
-- occurs. The first tick happens immediately, later ticks must be scheduled
-- with 'scheduleTick'.
forkTicker :: (POSIXTime -> STM ()) -> IO Ticker
forkTicker tick = do
getPOSIXTime >>= atomically . tick
tid <- forkIO $ fix $ \loop -> do
getPOSIXTime >>= atomically . tick
catch loop $ \(ScheduleTick interval) -> do
threadDelay interval
when (interval >= 0) loop
return $ Ticker tid
-- | Schedule the next tick. If you supply a negative number, the ticker
-- thread will terminate. Otherwise, the next tick will be scheduled for the
-- given number of microseconds from now.
--
-- Note: If a tick was scheduled to happen sooner, that tick will be canceled
-- in favor of this one. Only one tick is scheduled at a time.
scheduleTick :: Ticker -> Int -> IO ()
scheduleTick (Ticker tid) usecs = throwTo tid (ScheduleTick usecs)
|
