{-# LANGUAGE LambdaCase #-}
module Xmobar.Run.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 { Period -> Int64
rate :: Int64, Period -> Int64
next :: Int64, Period -> TMVar Tick
tick :: TMVar Tick }
data UnCoalesceException = UnCoalesceException deriving Int -> UnCoalesceException -> ShowS
[UnCoalesceException] -> ShowS
UnCoalesceException -> String
(Int -> UnCoalesceException -> ShowS)
-> (UnCoalesceException -> String)
-> ([UnCoalesceException] -> ShowS)
-> Show UnCoalesceException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnCoalesceException -> ShowS
showsPrec :: Int -> UnCoalesceException -> ShowS
$cshow :: UnCoalesceException -> String
show :: UnCoalesceException -> String
$cshowList :: [UnCoalesceException] -> ShowS
showList :: [UnCoalesceException] -> ShowS
Show
instance Exception UnCoalesceException
{-# NOINLINE periodsVar #-}
periodsVar :: TVar (Maybe Periods)
periodsVar :: TVar (Maybe Periods)
periodsVar = IO (TVar (Maybe Periods)) -> TVar (Maybe Periods)
forall a. IO a -> a
unsafePerformIO (IO (TVar (Maybe Periods)) -> TVar (Maybe Periods))
-> IO (TVar (Maybe Periods)) -> TVar (Maybe Periods)
forall a b. (a -> b) -> a -> b
$ Maybe Periods -> IO (TVar (Maybe Periods))
forall a. a -> IO (TVar a)
newTVarIO Maybe Periods
forall a. Maybe a
Nothing
now :: IO Int64
now :: IO Int64
now = do
posix <- IO POSIXTime
getPOSIXTime
return $ floor (10 * posix)
newPeriod :: Int64 -> IO (Unique, Period)
newPeriod :: Int64 -> IO (Unique, Period)
newPeriod Int64
r = do
u <- IO Unique
newUnique
t <- now
v <- newEmptyTMVarIO
let t' = Int64
t Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
t Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`mod` Int64
r
return (u, Period { rate = r, next = t', tick = v })
doEveryTenthSeconds :: Int -> IO () -> IO ()
doEveryTenthSeconds :: Int -> IO () -> IO ()
doEveryTenthSeconds Int
r IO ()
action =
Int -> IO () -> IO ()
doEveryTenthSecondsCoalesced Int
r IO ()
action IO () -> (UnCoalesceException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \UnCoalesceException
UnCoalesceException ->
Int -> IO () -> IO ()
doEveryTenthSecondsSleeping Int
r IO ()
action
doEveryTenthSecondsCoalesced :: Int -> IO () -> IO ()
doEveryTenthSecondsCoalesced :: Int -> IO () -> IO ()
doEveryTenthSecondsCoalesced Int
r IO ()
action = do
(u, p) <- Int64 -> IO (Unique, Period)
newPeriod (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r)
bracket_ (push u p) (pop u) $ forever $ bracket (wait p) done $ const action
where
push :: Unique -> Period -> IO ()
push Unique
u Period
p = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Periods) -> (Maybe Periods -> Maybe Periods) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Maybe Periods)
periodsVar ((Maybe Periods -> Maybe Periods) -> STM ())
-> (Maybe Periods -> Maybe Periods) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
Just Periods
periods -> Periods -> Maybe Periods
forall a. a -> Maybe a
Just (Periods -> Maybe Periods) -> Periods -> Maybe Periods
forall a b. (a -> b) -> a -> b
$ Unique -> Period -> Periods -> Periods
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Unique
u Period
p Periods
periods
Maybe Periods
Nothing -> UnCoalesceException -> Maybe Periods
forall a e. (HasCallStack, Exception e) => e -> a
throw UnCoalesceException
UnCoalesceException
pop :: Unique -> IO ()
pop Unique
u = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Periods) -> (Maybe Periods -> Maybe Periods) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Maybe Periods)
periodsVar ((Maybe Periods -> Maybe Periods) -> STM ())
-> (Maybe Periods -> Maybe Periods) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
Just Periods
periods -> Periods -> Maybe Periods
forall a. a -> Maybe a
Just (Periods -> Maybe Periods) -> Periods -> Maybe Periods
forall a b. (a -> b) -> a -> b
$ Unique -> Periods -> Periods
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Unique
u Periods
periods
Maybe Periods
Nothing -> Maybe Periods
forall a. Maybe a
Nothing
wait :: Period -> IO (TMVar ())
wait Period
p = STM Tick -> IO Tick
forall a. STM a -> IO a
atomically (TMVar Tick -> STM Tick
forall a. TMVar a -> STM a
takeTMVar (TMVar Tick -> STM Tick) -> TMVar Tick -> STM Tick
forall a b. (a -> b) -> a -> b
$ Period -> TMVar Tick
tick Period
p) IO Tick -> (Tick -> IO (TMVar ())) -> IO (TMVar ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Tick TMVar ()
doneVar -> TMVar () -> IO (TMVar ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TMVar ()
doneVar
Tick
UnCoalesce -> UnCoalesceException -> IO (TMVar ())
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO UnCoalesceException
UnCoalesceException
done :: TMVar () -> IO ()
done TMVar ()
doneVar = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
doneVar ()
doEveryTenthSecondsSleeping :: Int -> IO () -> IO ()
doEveryTenthSecondsSleeping :: Int -> IO () -> IO ()
doEveryTenthSecondsSleeping Int
r IO ()
action = IO ()
forall {b}. IO b
go
where go :: IO b
go = IO ()
action IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
tenthSeconds Int
r IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
go
tenthSeconds :: Int -> IO ()
tenthSeconds :: Int -> IO ()
tenthSeconds Int
s | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
x = do Int -> IO ()
threadDelay (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100000)
Int -> IO ()
tenthSeconds (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x)
| Bool
otherwise = Int -> IO ()
threadDelay (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100000)
where x :: Int
x = (Int
forall a. Bounded a => a
maxBound :: Int) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100000
withTimer :: (IO () -> IO ()) -> IO a -> IO a
withTimer :: forall a. (IO () -> IO ()) -> IO a -> IO a
withTimer IO () -> IO ()
pauseRefresh IO a
action =
IO () -> (Async () -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (IO ()
timerThread IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
cleanup) ((Async () -> IO a) -> IO a) -> (Async () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> Async () -> IO a
forall a b. a -> b -> a
const IO a
action
where
timerThread :: IO ()
timerThread = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Periods) -> Maybe Periods -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Periods)
periodsVar (Maybe Periods -> STM ()) -> Maybe Periods -> STM ()
forall a b. (a -> b) -> a -> b
$ Periods -> Maybe Periods
forall a. a -> Maybe a
Just Periods
forall k a. Map k a
M.empty
(IO () -> IO ()) -> IO ()
timerLoop IO () -> IO ()
pauseRefresh
cleanup :: IO ()
cleanup = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Periods) -> STM (Maybe Periods)
forall a. TVar a -> STM a
readTVar TVar (Maybe Periods)
periodsVar STM (Maybe Periods) -> (Maybe Periods -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Periods
periods -> do
Periods -> (Period -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Periods
periods Period -> STM ()
unCoalesceTimer'
TVar (Maybe Periods) -> Maybe Periods -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Periods)
periodsVar Maybe Periods
forall a. Maybe a
Nothing
Maybe Periods
Nothing -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
timerLoop :: (IO () -> IO ()) -> IO ()
timerLoop :: (IO () -> IO ()) -> IO ()
timerLoop IO () -> IO ()
pauseRefresh = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
tNow <- IO Int64
now
(toFire, tMaybeNext) <- atomically $ do
periods <- fromJust <$> readTVar periodsVar
let toFire = Int64 -> Periods -> [(Unique, Period)]
timersToFire Int64
tNow Periods
periods
let periods' = Int64 -> Periods -> Periods
advanceTimers Int64
tNow Periods
periods
let tMaybeNext = Periods -> Maybe Int64
nextFireTime Periods
periods'
writeTVar periodsVar $ Just periods'
return (toFire, tMaybeNext)
pauseRefresh $ do
timeoutVar <- registerDelay $ case tMaybeNext of
Just Int64
tNext -> Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int64
tNext Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
tNow) Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
`max` Int64
10) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100000
Maybe Int64
Nothing -> Int
1000000
fired <- fireTimers toFire
timeouted <- waitForTimers timeoutVar fired
unCoalesceTimers timeouted
delayUntilNextFire
advanceTimers :: Int64 -> Periods -> Periods
advanceTimers :: Int64 -> Periods -> Periods
advanceTimers Int64
t = (Period -> Period) -> Periods -> Periods
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Period -> Period
advance
where
advance :: Period -> Period
advance Period
p | Period -> Int64
next Period
p Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
t = Period
p { next = t - t `mod` rate p + rate p }
| Bool
otherwise = Period
p
timersToFire :: Int64 -> Periods -> [(Unique, Period)]
timersToFire :: Int64 -> Periods -> [(Unique, Period)]
timersToFire Int64
t Periods
periods = [ (Unique
u, Period
p) | (Unique
u, Period
p) <- Periods -> [(Unique, Period)]
forall k a. Map k a -> [(k, a)]
M.toList Periods
periods, Period -> Int64
next Period
p Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
t ]
nextFireTime :: Periods -> Maybe Int64
nextFireTime :: Periods -> Maybe Int64
nextFireTime Periods
periods
| Periods -> Bool
forall k a. Map k a -> Bool
M.null Periods
periods = Maybe Int64
forall a. Maybe a
Nothing
| Bool
otherwise = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ [Int64] -> Int64
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ Period -> Int64
next Period
p | Period
p <- Periods -> [Period]
forall k a. Map k a -> [a]
M.elems Periods
periods ]
fireTimers :: [(Unique, Period)] -> IO [(Unique, TMVar ())]
fireTimers :: [(Unique, Period)] -> IO [(Unique, TMVar ())]
fireTimers [(Unique, Period)]
toFire = STM [(Unique, TMVar ())] -> IO [(Unique, TMVar ())]
forall a. STM a -> IO a
atomically (STM [(Unique, TMVar ())] -> IO [(Unique, TMVar ())])
-> STM [(Unique, TMVar ())] -> IO [(Unique, TMVar ())]
forall a b. (a -> b) -> a -> b
$ [(Unique, Period)]
-> ((Unique, Period) -> STM (Unique, TMVar ()))
-> STM [(Unique, TMVar ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Unique, Period)]
toFire (((Unique, Period) -> STM (Unique, TMVar ()))
-> STM [(Unique, TMVar ())])
-> ((Unique, Period) -> STM (Unique, TMVar ()))
-> STM [(Unique, TMVar ())]
forall a b. (a -> b) -> a -> b
$ \(Unique
u, Period
p) -> do
doneVar <- STM (TMVar ())
forall a. STM (TMVar a)
newEmptyTMVar
putTMVar (tick p) (Tick doneVar)
return (u, doneVar)
waitForTimers :: TVar Bool -> [(Unique, TMVar ())] -> IO [Unique]
waitForTimers :: TVar Bool -> [(Unique, TMVar ())] -> IO [Unique]
waitForTimers TVar Bool
timeoutVar [(Unique, TMVar ())]
fired = STM [Unique] -> IO [Unique]
forall a. STM a -> IO a
atomically (STM [Unique] -> IO [Unique]) -> STM [Unique] -> IO [Unique]
forall a b. (a -> b) -> a -> b
$ do
timeoutOver <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
timeoutVar
dones <- forM fired $ \(Unique
u, TMVar ()
doneVar) -> do
done <- Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> STM (Maybe ()) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar () -> STM (Maybe ())
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar ()
doneVar
return (u, done)
guard $ timeoutOver || all snd dones
return [u | (u, False) <- dones]
unCoalesceTimers :: [Unique] -> IO ()
unCoalesceTimers :: [Unique] -> IO ()
unCoalesceTimers [Unique]
timers = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
periods <- Maybe Periods -> Periods
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Periods -> Periods) -> STM (Maybe Periods) -> STM Periods
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe Periods) -> STM (Maybe Periods)
forall a. TVar a -> STM a
readTVar TVar (Maybe Periods)
periodsVar
periods' <- foldrM unCoalesceTimer periods timers
writeTVar periodsVar $ Just periods'
unCoalesceTimer :: Unique -> Periods -> STM Periods
unCoalesceTimer :: Unique -> Periods -> STM Periods
unCoalesceTimer Unique
u Periods
periods = do
Period -> STM ()
unCoalesceTimer' (Periods
periods Periods -> Unique -> Period
forall k a. Ord k => Map k a -> k -> a
M.! Unique
u)
Periods -> STM Periods
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Periods -> STM Periods) -> Periods -> STM Periods
forall a b. (a -> b) -> a -> b
$ Unique
u Unique -> Periods -> Periods
forall k a. Ord k => k -> Map k a -> Map k a
`M.delete` Periods
periods
unCoalesceTimer' :: Period -> STM ()
unCoalesceTimer' :: Period -> STM ()
unCoalesceTimer' Period
p = do
_ <- TMVar Tick -> STM (Maybe Tick)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar (Period -> TMVar Tick
tick Period
p)
putTMVar (tick p) UnCoalesce
delayUntilNextFire :: IO ()
delayUntilNextFire :: IO ()
delayUntilNextFire = do
Just periods <- TVar (Maybe Periods) -> IO (Maybe Periods)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe Periods)
periodsVar
let tMaybeNext = Periods -> Maybe Int64
nextFireTime Periods
periods
tNow <- now
delayVar <- case tMaybeNext of
Just Int64
tNext -> do
let maxDelay :: Int
maxDelay = (Int
forall a. Bounded a => a
maxBound :: Int) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100000
delay :: Int64
delay = (Int64
tNext Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
tNow) Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
`min` Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxDelay
delayUsec :: Int
delayUsec = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
delay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100000
Int -> IO (TVar Bool)
registerDelay Int
delayUsec
Maybe Int64
Nothing -> Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
atomically $ do
delayOver <- readTVar delayVar
periods' <- fromJust <$> readTVar periodsVar
let tMaybeNext' = Periods -> Maybe Int64
nextFireTime Periods
periods'
guard $ delayOver || tMaybeNext /= tMaybeNext'