{-# LANGUAGE CPP #-}
module Xmobar.Run.Loop (LoopFunction, loop) where
import Control.Concurrent (forkIO)
import Control.Exception (bracket_, bracket, handle, SomeException(..))
import Control.Concurrent.STM
import Control.Concurrent.Async (Async, async, cancel)
import Control.Monad (guard, void, unless)
import Data.Maybe (isJust)
import Data.Foldable (for_)
import Xmobar.System.Signal
import Xmobar.Config.Types
import Xmobar.Run.Runnable (Runnable)
import Xmobar.Run.Exec (start, trigger, alias)
import Xmobar.Run.Template
import Xmobar.Run.Timer (withTimer)
#ifdef DBUS
import Xmobar.System.DBus
#endif
newRefreshLock :: IO (TMVar ())
newRefreshLock :: IO (TMVar ())
newRefreshLock = () -> IO (TMVar ())
forall a. a -> IO (TMVar a)
newTMVarIO ()
refreshLock :: TMVar () -> IO a -> IO a
refreshLock :: forall a. TMVar () -> IO a -> IO a
refreshLock TMVar ()
var = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
lock IO ()
unlock
where
lock :: IO ()
lock = 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 -> STM a
takeTMVar TMVar ()
var
unlock :: IO ()
unlock = 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 ()
var ()
refreshLockT :: TMVar () -> STM a -> STM a
refreshLockT :: forall a. TMVar () -> STM a -> STM a
refreshLockT TMVar ()
var STM a
action = do
TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
var
r <- STM a
action
putTMVar var ()
return r
type LoopFunction = TMVar SignalType -> TVar [String] -> IO ()
loop :: Config -> LoopFunction -> IO ()
loop :: Config -> LoopFunction -> IO ()
loop Config
conf LoopFunction
looper = IO () -> IO ()
forall a. IO a -> IO a
withDeferSignals (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
cls <- (String -> IO [(Runnable, String, String)])
-> [String] -> IO [[(Runnable, String, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Runnable] -> String -> String -> IO [(Runnable, String, String)]
parseTemplate (Config -> [Runnable]
commands Config
conf) (Config -> String
sepChar Config
conf))
(String -> String -> [String]
splitTemplate (Config -> String
alignSep Config
conf) (Config -> String
template Config
conf))
let confSig = SignalChan -> Maybe (TMVar SignalType)
unSignalChan (Config -> SignalChan
signal Config
conf)
sig <- maybe newEmptyTMVarIO pure confSig
unless (isJust confSig) $ setupSignalHandler sig
refLock <- newRefreshLock
withTimer (refreshLock refLock) $
bracket (mapM (mapM $ startCommand sig) cls)
cleanupThreads
$ \[[([Async ()], TVar String)]]
vars -> do
tv <- TMVar SignalType
-> TMVar () -> [[([Async ()], TVar String)]] -> IO (TVar [String])
initLoop TMVar SignalType
sig TMVar ()
refLock [[([Async ()], TVar String)]]
vars
looper sig tv
cleanupThreads :: [[([Async ()], a)]] -> IO ()
cleanupThreads :: forall a. [[([Async ()], a)]] -> IO ()
cleanupThreads [[([Async ()], a)]]
vars =
[([Async ()], a)] -> (([Async ()], a) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([[([Async ()], a)]] -> [([Async ()], a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[([Async ()], a)]]
vars) ((([Async ()], a) -> IO ()) -> IO ())
-> (([Async ()], a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \([Async ()]
asyncs, a
_) ->
[Async ()] -> (Async () -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Async ()]
asyncs Async () -> IO ()
forall a. Async a -> IO ()
cancel
initLoop :: TMVar SignalType -> TMVar () -> [[([Async ()], TVar String)]]
-> IO (TVar [String])
initLoop :: TMVar SignalType
-> TMVar () -> [[([Async ()], TVar String)]] -> IO (TVar [String])
initLoop TMVar SignalType
sig TMVar ()
lock [[([Async ()], TVar String)]]
vs = do
tv <- [String] -> IO (TVar [String])
forall a. a -> IO (TVar a)
newTVarIO ([] :: [String])
_ <- forkIO (handle (handler "checker") (checker tv [] vs sig lock))
#ifdef DBUS
runIPC sig
#endif
return tv
where
handler :: String -> SomeException -> IO ()
handler String
thing (SomeException e
e) =
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"Thread " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
thing String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e)
startCommand :: TMVar SignalType
-> (Runnable,String,String)
-> IO ([Async ()], TVar String)
startCommand :: TMVar SignalType
-> (Runnable, String, String) -> IO ([Async ()], TVar String)
startCommand TMVar SignalType
sig (Runnable
com,String
s,String
ss)
| Runnable -> String
forall e. Exec e => e -> String
alias Runnable
com String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do var <- String -> IO (TVar String)
forall a. a -> IO (TVar a)
newTVarIO String
is
atomically $ writeTVar var (s ++ ss)
return ([], var)
| Bool
otherwise = do var <- String -> IO (TVar String)
forall a. a -> IO (TVar a)
newTVarIO String
is
let cb String
str = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar String -> String -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar String
var (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss)
a1 <- async $ start com cb
a2 <- async $ trigger com $ maybe (return ())
(atomically . putTMVar sig)
return ([a1, a2], var)
where is :: String
is = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Updating..." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss
checker :: TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> TMVar ()
-> IO ()
checker :: TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> TMVar ()
-> IO ()
checker TVar [String]
tvar [String]
ov [[([Async ()], TVar String)]]
vs TMVar SignalType
sig TMVar ()
pauser = do
nval <- STM [String] -> IO [String]
forall a. STM a -> IO a
atomically (STM [String] -> IO [String]) -> STM [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM [String] -> STM [String]
forall a. TMVar () -> STM a -> STM a
refreshLockT TMVar ()
pauser (STM [String] -> STM [String]) -> STM [String] -> STM [String]
forall a b. (a -> b) -> a -> b
$ do
nv <- ([([Async ()], TVar String)] -> STM String)
-> [[([Async ()], TVar String)]] -> STM [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [([Async ()], TVar String)] -> STM String
forall {a} {a}. [(a, TVar [a])] -> STM [a]
concatV [[([Async ()], TVar String)]]
vs
guard (nv /= ov)
writeTVar tvar nv
return nv
atomically $ putTMVar sig Wakeup
checker tvar nval vs sig pauser
where
concatV :: [(a, TVar [a])] -> STM [a]
concatV = ([[a]] -> [a]) -> STM [[a]] -> STM [a]
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (STM [[a]] -> STM [a])
-> ([(a, TVar [a])] -> STM [[a]]) -> [(a, TVar [a])] -> STM [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, TVar [a]) -> STM [a]) -> [(a, TVar [a])] -> STM [[a]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar (TVar [a] -> STM [a])
-> ((a, TVar [a]) -> TVar [a]) -> (a, TVar [a]) -> STM [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, TVar [a]) -> TVar [a]
forall a b. (a, b) -> b
snd)