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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
{-# LANGUAGE LambdaCase #-}
------------------------------------------------------------------------------
-- |
-- 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
, tenthSeconds
, withTimer
) where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (withAsync)
import Control.Concurrent.STM
import Control.Exception
import Control.Monad (forever, forM, guard)
import Data.Foldable (foldrM)
import Data.IORef
import Data.Int (Int64)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (isJust)
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 Tick = Tick (TMVar ()) | TimeOut
data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar Tick }
data TimeOutException = TimeOutException deriving Show
instance Exception TimeOutException
{-# 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 (coalesced) with other timers to minimize the number
-- of wakeups and unnecessary redraws. If the action takes too long (one
-- second or when the next timer is due), coalescing is disabled for it and it
-- falls back to periodic sleep.
doEveryTenthSeconds :: Int -> IO () -> IO ()
doEveryTenthSeconds r action = do
Just t <- readIORef timer
doEveryTenthSecondsCoalesced t r action `catch` \TimeOutException ->
doEveryTenthSecondsSleeping r action
-- | Perform a given action every N tenths of a second,
-- coalesce with other timers using a given Timer instance.
doEveryTenthSecondsCoalesced :: Timer -> Int -> IO () -> IO ()
doEveryTenthSecondsCoalesced (Timer periodsVar) r action = do
(u, p) <- newPeriod (fromIntegral r)
bracket_ (push u p) (pop u) $ forever $ bracket (wait p) done $ const action
where
push u p = atomically $ modifyTVar periodsVar (M.insert u p)
pop u = atomically $ modifyTVar periodsVar (M.delete u)
wait p = atomically (takeTMVar $ tick p) >>= \case
Tick doneVar -> return doneVar
TimeOut -> throwIO TimeOutException
done doneVar = atomically $ putTMVar doneVar ()
-- | Perform a given action every N tenths of a second,
-- making no attempt to synchronize with other timers.
doEveryTenthSecondsSleeping :: Int -> IO () -> IO ()
doEveryTenthSecondsSleeping r action = go
where go = action >> tenthSeconds r >> go
-- | Sleep for a given amount of tenths of a second.
--
-- (Work around the Int max bound: since threadDelay takes an Int, it
-- is not possible to set a thread delay grater than about 45 minutes.
-- With a little recursion we solve the problem.)
tenthSeconds :: Int -> IO ()
tenthSeconds s | s >= x = do threadDelay (x * 100000)
tenthSeconds (s - x)
| otherwise = threadDelay (s * 100000)
where x = (maxBound :: Int) `div` 100000
-- | 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
tNow <- now
(toFire, tMaybeNext) <- atomically $ do
periods <- readTVar periodsVar
let toFire = timersToFire tNow periods
let periods' = advanceTimers tNow periods
let tMaybeNext = nextFireTime periods'
writeTVar periodsVar periods'
return (toFire, tMaybeNext)
pauseRefresh $ do
-- To avoid multiple refreshes, pause refreshing for up to 1 second,
-- fire timers and wait for them to finish (update their text).
-- Those that need more time (e.g. weather monitors) will be dropped
-- from timer coalescing and will fall back to periodic sleep.
timeoutVar <- registerDelay $ case tMaybeNext of
Just tNext -> fromIntegral ((tNext - tNow) `max` 10) * 100000
Nothing -> 1000000
fired <- fireTimers toFire
timeouted <- waitForTimers timeoutVar fired
timeoutTimers timeouted periodsVar
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 -> [(Unique, Period)]
timersToFire t periods = [ (u, p) | (u, p) <- M.toList periods, next p <= t ]
nextFireTime :: Periods -> Maybe Int64
nextFireTime periods
| M.null periods = Nothing
| otherwise = Just $ minimum [ next p | p <- M.elems periods ]
fireTimers :: [(Unique, Period)] -> IO [(Unique, TMVar ())]
fireTimers toFire = atomically $ forM toFire $ \(u, p) -> do
doneVar <- newEmptyTMVar
putTMVar (tick p) (Tick doneVar)
return (u, doneVar)
waitForTimers :: TVar Bool -> [(Unique, TMVar ())] -> IO [Unique]
waitForTimers timeoutVar fired = atomically $ do
timeoutOver <- readTVar timeoutVar
dones <- forM fired $ \(u, doneVar) -> do
done <- isJust <$> tryReadTMVar doneVar
return (u, done)
guard $ timeoutOver || all snd dones
return [u | (u, False) <- dones]
-- | Handle slow timers (drop and signal them to stop coalescing).
timeoutTimers :: [Unique] -> TVar Periods -> IO ()
timeoutTimers timers periodsVar = atomically $ do
periods <- readTVar periodsVar
periods' <- foldrM timeoutTimer periods timers
writeTVar periodsVar periods'
timeoutTimer :: Unique -> Periods -> STM Periods
timeoutTimer u periods = do
putTMVar (tick (periods M.! u)) TimeOut
return $ u `M.delete` 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'
|
