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
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
------------------------------------------------------------------------------
-- |
-- Module: Xmobar.App.Timer
-- Copyright: (c) 2019 Tomáš Janoušek
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: Tomáš Janoušek <tomi@nomi.cz>
-- Stability: unstable
--
-- Timer coalescing for recurring actions.
--
------------------------------------------------------------------------------
module Xmobar.App.Timer (doEveryTenthSeconds, withTimer) where
import Control.Concurrent.Async (withAsync)
import Control.Concurrent.STM
import Control.Exception (bracket, bracket_)
import Control.Monad (forever, forM, forM_, guard)
import Data.IORef
import Data.Int (Int64)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Unique
import System.IO.Unsafe (unsafePerformIO)
newtype Timer = Timer (TVar Periods)
type Periods = Map Unique Period
data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar (TMVar ()) }
{-# NOINLINE timer #-}
timer :: IORef (Maybe Timer)
timer = unsafePerformIO (newIORef Nothing)
now :: IO Int64
now = do
posix <- getPOSIXTime
return $ floor (10 * posix)
newPeriod :: Int64 -> IO (Unique, Period)
newPeriod r = do
u <- newUnique
t <- now
v <- atomically newEmptyTMVar
let t' = t - t `mod` r
return (u, Period { rate = r, next = t', tick = v })
-- | Perform a given action every N tenths of a second.
--
-- The timer is aligned with other timers to minimize the number of wakeups
-- and unnecessary redraws.
doEveryTenthSeconds :: Int -> IO () -> IO ()
doEveryTenthSeconds r action = do
Just t <- readIORef timer
doEveryTenthSeconds' t r action
doEveryTenthSeconds' :: Timer -> Int -> IO () -> IO ()
doEveryTenthSeconds' (Timer periodsVar) r action = do
(u, p) <- newPeriod (fromIntegral r)
bracket_ (push u p) (pop u) $ forever $
bracket (atomically $ takeTMVar $ tick p)
(\doneVar -> atomically $ putTMVar doneVar ())
(const action)
where
push u p = atomically $ modifyTVar periodsVar (M.insert u p)
pop u = atomically $ modifyTVar periodsVar (M.delete u)
-- | Start the timer coordination thread.
withTimer :: (IO () -> IO ()) -> IO a -> IO a
withTimer pauseRefresh action = do
periodsVar <- atomically $ newTVar M.empty
withAsync (timerLoop pauseRefresh periodsVar) $ \_ ->
bracket_
(writeIORef timer (Just (Timer periodsVar)))
(writeIORef timer Nothing) -- TODO: kill all periods?
action
timerLoop :: (IO () -> IO ()) -> TVar Periods -> IO ()
timerLoop pauseRefresh periodsVar = forever $ do
t <- now
toFire <- atomically $ do
periods <- readTVar periodsVar
writeTVar periodsVar (advanceTimers t periods)
return (timersToFire t periods)
pauseRefresh $ do
-- Fire timers ...
doneVars <- atomically $ forM toFire $ \p -> do
doneVar <- newEmptyTMVar
putTMVar (tick p) doneVar
return doneVar
-- ... and wait for them to avoid unnecessary redraws.
atomically $ forM_ doneVars takeTMVar
delayUntilNextFire periodsVar
advanceTimers :: Int64 -> Periods -> Periods
advanceTimers t = M.map advance
where
advance p | next p <= t = p { next = t - t `mod` rate p + rate p }
| otherwise = p
timersToFire :: Int64 -> Periods -> [Period]
timersToFire t periods = [ p | p <- M.elems periods, next p <= t ]
nextFireTime :: Periods -> Maybe Int64
nextFireTime periods
| M.null periods = Nothing
| otherwise = Just $ minimum [ next p | p <- M.elems periods ]
delayUntilNextFire :: TVar Periods -> IO ()
delayUntilNextFire periodsVar = do
tMaybeNext <- fmap nextFireTime $ readTVarIO periodsVar
tNow <- now
delayVar <- case tMaybeNext of
Just tNext -> do
-- Work around the Int max bound: threadDelay takes an Int, we can
-- only sleep for so long, which is okay, we'll just check timers
-- sooner and sleep again.
let maxDelay = (maxBound :: Int) `div` 100000
delay = (tNext - tNow) `min` fromIntegral maxDelay
delayUsec = fromIntegral delay * 100000
registerDelay delayUsec
Nothing -> atomically $ newTVar False
atomically $ do
delayOver <- readTVar delayVar
tMaybeNext' <- fmap nextFireTime $ readTVar periodsVar
-- Return also if a new period is added (it may fire sooner).
guard $ delayOver || tMaybeNext /= tMaybeNext'
|
