1{-# LANGUAGE LambdaCase #-}
2------------------------------------------------------------------------------
3-- |
4-- Module: Xmobar.App.Timer
5-- Copyright: (c) 2019, 2020 Tomáš Janoušek
6-- License: BSD3-style (see LICENSE)
7--
8-- Maintainer: Tomáš Janoušek <tomi@nomi.cz>
9-- Stability: unstable
10--
11-- Timer coalescing for recurring actions.
12--
13------------------------------------------------------------------------------
14
15module Xmobar.App.Timer
16    ( doEveryTenthSeconds
17    , tenthSeconds
18    , withTimer
19    ) where
20
21import Control.Concurrent (threadDelay)
22import Control.Concurrent.Async (withAsync)
23import Control.Concurrent.STM
24import Control.Exception
25import Control.Monad (forever, forM, guard)
26import Data.Foldable (foldrM, for_)
27import Data.Int (Int64)
28import Data.Map (Map)
29import qualified Data.Map as M
30import Data.Maybe (isJust, fromJust)
31import Data.Time.Clock.POSIX (getPOSIXTime)
32import Data.Unique
33import System.IO.Unsafe (unsafePerformIO)
34
35type Periods = Map Unique Period
36
37data Tick = Tick (TMVar ()) | UnCoalesce
38
39data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar Tick }
40
41data UnCoalesceException = UnCoalesceException deriving Show
42instance Exception UnCoalesceException
43
44{-# NOINLINE periodsVar #-}
45periodsVar :: TVar (Maybe Periods)
46periodsVar = unsafePerformIO $ newTVarIO Nothing
47
48now :: IO Int64
49now = do
50    posix <- getPOSIXTime
51    return $ floor (10 * posix)
52
53newPeriod :: Int64 -> IO (Unique, Period)
54newPeriod r = do
55    u <- newUnique
56    t <- now
57    v <- newEmptyTMVarIO
58    let t' = t - t `mod` r
59    return (u, Period { rate = r, next = t', tick = v })
60
61-- | Perform a given action every N tenths of a second.
62--
63-- The timer is aligned (coalesced) with other timers to minimize the number
64-- of wakeups and unnecessary redraws. If the action takes too long (one
65-- second or when the next timer is due), coalescing is disabled for it and it
66-- falls back to periodic sleep.
67doEveryTenthSeconds :: Int -> IO () -> IO ()
68doEveryTenthSeconds r action =
69    doEveryTenthSecondsCoalesced r action `catch` \UnCoalesceException ->
70        doEveryTenthSecondsSleeping r action
71
72-- | Perform a given action every N tenths of a second,
73-- coalesce with other timers using a given Timer instance.
74doEveryTenthSecondsCoalesced :: Int -> IO () -> IO ()
75doEveryTenthSecondsCoalesced r action = do
76    (u, p) <- newPeriod (fromIntegral r)
77    bracket_ (push u p) (pop u) $ forever $ bracket (wait p) done $ const action
78    where
79        push u p = atomically $ modifyTVar' periodsVar $ \case
80            Just periods -> Just $ M.insert u p periods
81            Nothing -> throw UnCoalesceException
82        pop u = atomically $ modifyTVar' periodsVar $ \case
83            Just periods -> Just $ M.delete u periods
84            Nothing -> Nothing
85
86        wait p = atomically (takeTMVar $ tick p) >>= \case
87            Tick doneVar -> return doneVar
88            UnCoalesce -> throwIO UnCoalesceException
89        done doneVar = atomically $ putTMVar doneVar ()
90
91-- | Perform a given action every N tenths of a second,
92-- making no attempt to synchronize with other timers.
93doEveryTenthSecondsSleeping :: Int -> IO () -> IO ()
94doEveryTenthSecondsSleeping r action = go
95    where go = action >> tenthSeconds r >> go
96
97-- | Sleep for a given amount of tenths of a second.
98--
99-- (Work around the Int max bound: since threadDelay takes an Int, it
100-- is not possible to set a thread delay grater than about 45 minutes.
101-- With a little recursion we solve the problem.)
102tenthSeconds :: Int -> IO ()
103tenthSeconds s | s >= x = do threadDelay (x * 100000)
104                             tenthSeconds (s - x)
105               | otherwise = threadDelay (s * 100000)
106               where x = (maxBound :: Int) `div` 100000
107
108-- | Start the timer coordination thread and perform a given IO action (this
109-- is meant to surround the entire xmobar execution), terminating the timer
110-- thread afterwards.
111--
112-- Additionally, if the timer thread fails, individual
113-- 'doEveryTenthSecondsCoalesced' invocations that are waiting to be
114-- coordinated by it are notified to fall back to periodic sleeping.
115--
116-- The timer thread _will_ fail immediately when running in a non-threaded
117-- RTS.
118withTimer :: (IO () -> IO ()) -> IO a -> IO a
119withTimer pauseRefresh action =
120    withAsync (timerThread `finally` cleanup) $ const action
121    where
122        timerThread = do
123            atomically $ writeTVar periodsVar $ Just M.empty
124            timerLoop pauseRefresh
125
126        cleanup = atomically $ readTVar periodsVar >>= \case
127            Just periods -> do
128                for_ periods unCoalesceTimer'
129                writeTVar periodsVar Nothing
130            Nothing -> return ()
131
132timerLoop :: (IO () -> IO ()) -> IO ()
133timerLoop pauseRefresh = forever $ do
134    tNow <- now
135    (toFire, tMaybeNext) <- atomically $ do
136        periods <- fromJust <$> readTVar periodsVar
137        let toFire = timersToFire tNow periods
138        let periods' = advanceTimers tNow periods
139        let tMaybeNext = nextFireTime periods'
140        writeTVar periodsVar $ Just periods'
141        return (toFire, tMaybeNext)
142    pauseRefresh $ do
143        -- To avoid multiple refreshes, pause refreshing for up to 1 second,
144        -- fire timers and wait for them to finish (update their text).
145        -- Those that need more time (e.g. weather monitors) will be dropped
146        -- from timer coalescing and will fall back to periodic sleep.
147        timeoutVar <- registerDelay $ case tMaybeNext of
148            Just tNext -> fromIntegral ((tNext - tNow) `max` 10) * 100000
149            Nothing -> 1000000
150        fired <- fireTimers toFire
151        timeouted <- waitForTimers timeoutVar fired
152        unCoalesceTimers timeouted
153    delayUntilNextFire
154
155advanceTimers :: Int64 -> Periods -> Periods
156advanceTimers t = M.map advance
157    where
158        advance p | next p <= t = p { next = t - t `mod` rate p + rate p }
159                  | otherwise = p
160
161timersToFire :: Int64 -> Periods -> [(Unique, Period)]
162timersToFire t periods = [ (u, p) | (u, p) <- M.toList periods, next p <= t ]
163
164nextFireTime :: Periods -> Maybe Int64
165nextFireTime periods
166    | M.null periods = Nothing
167    | otherwise = Just $ minimum [ next p | p <- M.elems periods ]
168
169fireTimers :: [(Unique, Period)] -> IO [(Unique, TMVar ())]
170fireTimers toFire = atomically $ forM toFire $ \(u, p) -> do
171    doneVar <- newEmptyTMVar
172    putTMVar (tick p) (Tick doneVar)
173    return (u, doneVar)
174
175waitForTimers :: TVar Bool -> [(Unique, TMVar ())] -> IO [Unique]
176waitForTimers timeoutVar fired = atomically $ do
177    timeoutOver <- readTVar timeoutVar
178    dones <- forM fired $ \(u, doneVar) -> do
179        done <- isJust <$> tryReadTMVar doneVar
180        return (u, done)
181    guard $ timeoutOver || all snd dones
182    return [u | (u, False) <- dones]
183
184-- | Handle slow timers (drop and signal them to stop coalescing).
185unCoalesceTimers :: [Unique] -> IO ()
186unCoalesceTimers timers = atomically $ do
187    periods <- fromJust <$> readTVar periodsVar
188    periods' <- foldrM unCoalesceTimer periods timers
189    writeTVar periodsVar $ Just periods'
190
191unCoalesceTimer :: Unique -> Periods -> STM Periods
192unCoalesceTimer u periods = do
193    unCoalesceTimer' (periods M.! u)
194    return $ u `M.delete` periods
195
196unCoalesceTimer' :: Period -> STM ()
197unCoalesceTimer' p = do
198    _ <- tryTakeTMVar (tick p)
199    putTMVar (tick p) UnCoalesce
200
201delayUntilNextFire :: IO ()
202delayUntilNextFire = do
203    Just periods <- readTVarIO periodsVar
204    let tMaybeNext = nextFireTime periods
205    tNow <- now
206    delayVar <- case tMaybeNext of
207        Just tNext -> do
208            -- Work around the Int max bound: threadDelay takes an Int, we can
209            -- only sleep for so long, which is okay, we'll just check timers
210            -- sooner and sleep again.
211            let maxDelay = (maxBound :: Int) `div` 100000
212                delay = (tNext - tNow) `min` fromIntegral maxDelay
213                delayUsec = fromIntegral delay * 100000
214            registerDelay delayUsec
215        Nothing -> newTVarIO False
216    atomically $ do
217        delayOver <- readTVar delayVar
218        periods' <- fromJust <$> readTVar periodsVar
219        let tMaybeNext' = nextFireTime periods'
220        -- Return also if a new period is added (it may fire sooner).
221        guard $ delayOver || tMaybeNext /= tMaybeNext'
222