{-# LANGUAGE LambdaCase #-}
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, for_)
import Data.Int (Int64)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (isJust, fromJust)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Unique
import System.IO.Unsafe (unsafePerformIO)
type Periods = Map Unique Period
data Tick = Tick (TMVar ()) | UnCoalesce
data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar Tick }
data UnCoalesceException = UnCoalesceException deriving Show
instance Exception UnCoalesceException
{-# NOINLINE periodsVar #-}
periodsVar :: TVar (Maybe Periods)
periodsVar = unsafePerformIO $ newTVarIO 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 })
doEveryTenthSeconds :: Int -> IO () -> IO ()
doEveryTenthSeconds r action =
doEveryTenthSecondsCoalesced r action `catch` \UnCoalesceException ->
doEveryTenthSecondsSleeping r action
doEveryTenthSecondsCoalesced :: Int -> IO () -> IO ()
doEveryTenthSecondsCoalesced 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 $ \case
Just periods -> Just $ M.insert u p periods
Nothing -> throw UnCoalesceException
pop u = atomically $ modifyTVar' periodsVar $ \case
Just periods -> Just $ M.delete u periods
Nothing -> Nothing
wait p = atomically (takeTMVar $ tick p) >>= \case
Tick doneVar -> return doneVar
UnCoalesce -> throwIO UnCoalesceException
done doneVar = atomically $ putTMVar doneVar ()
doEveryTenthSecondsSleeping :: Int -> IO () -> IO ()
doEveryTenthSecondsSleeping r action = go
where go = action >> tenthSeconds r >> go
tenthSeconds :: Int -> IO ()
tenthSeconds s | s >= x = do threadDelay (x * 100000)
tenthSeconds (s - x)
| otherwise = threadDelay (s * 100000)
where x = (maxBound :: Int) `div` 100000
withTimer :: (IO () -> IO ()) -> IO a -> IO a
withTimer pauseRefresh action =
withAsync (timerThread `finally` cleanup) $ const action
where
timerThread = do
atomically $ writeTVar periodsVar $ Just M.empty
timerLoop pauseRefresh
cleanup = atomically $ readTVar periodsVar >>= \case
Just periods -> do
for_ periods unCoalesceTimer'
writeTVar periodsVar Nothing
Nothing -> return ()
timerLoop :: (IO () -> IO ()) -> IO ()
timerLoop pauseRefresh = forever $ do
tNow <- now
(toFire, tMaybeNext) <- atomically $ do
periods <- fromJust <$> readTVar periodsVar
let toFire = timersToFire tNow periods
let periods' = advanceTimers tNow periods
let tMaybeNext = nextFireTime periods'
writeTVar periodsVar $ Just periods'
return (toFire, tMaybeNext)
pauseRefresh $ do
timeoutVar <- registerDelay $ case tMaybeNext of
Just tNext -> fromIntegral ((tNext - tNow) `max` 10) * 100000
Nothing -> 1000000
fired <- fireTimers toFire
timeouted <- waitForTimers timeoutVar fired
unCoalesceTimers timeouted
delayUntilNextFire
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]
unCoalesceTimers :: [Unique] -> IO ()
unCoalesceTimers timers = atomically $ do
periods <- fromJust <$> readTVar periodsVar
periods' <- foldrM unCoalesceTimer periods timers
writeTVar periodsVar $ Just periods'
unCoalesceTimer :: Unique -> Periods -> STM Periods
unCoalesceTimer u periods = do
unCoalesceTimer' (periods M.! u)
return $ u `M.delete` periods
unCoalesceTimer' :: Period -> STM ()
unCoalesceTimer' p = do
_ <- tryTakeTMVar (tick p)
putTMVar (tick p) UnCoalesce
delayUntilNextFire :: IO ()
delayUntilNextFire = do
Just periods <- readTVarIO periodsVar
let tMaybeNext = nextFireTime periods
tNow <- now
delayVar <- case tMaybeNext of
Just tNext -> do
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
periods' <- fromJust <$> readTVar periodsVar
let tMaybeNext' = nextFireTime periods'
guard $ delayOver || tMaybeNext /= tMaybeNext'