{-# 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 :: 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 :: TMVar () -> STM a -> STM a
refreshLockT TMVar ()
var STM a
action = do
TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
var
a
r <- STM a
action
TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
var ()
a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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
[[(Runnable, String, String)]]
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)
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 :: Maybe (TMVar SignalType)
confSig = SignalChan -> Maybe (TMVar SignalType)
unSignalChan (Config -> SignalChan
signal Config
conf)
TMVar SignalType
sig <- IO (TMVar SignalType)
-> (TMVar SignalType -> IO (TMVar SignalType))
-> Maybe (TMVar SignalType)
-> IO (TMVar SignalType)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (TMVar SignalType)
forall a. IO (TMVar a)
newEmptyTMVarIO TMVar SignalType -> IO (TMVar SignalType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TMVar SignalType)
confSig
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (TMVar SignalType) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TMVar SignalType)
confSig) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> IO ()
setupSignalHandler TMVar SignalType
sig
TMVar ()
refLock <- IO (TMVar ())
newRefreshLock
(IO () -> IO ()) -> IO () -> IO ()
forall a. (IO () -> IO ()) -> IO a -> IO a
withTimer (TMVar () -> IO () -> IO ()
forall a. TMVar () -> IO a -> IO a
refreshLock TMVar ()
refLock) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO [[([Async ()], TVar String)]]
-> ([[([Async ()], TVar String)]] -> IO ())
-> ([[([Async ()], TVar String)]] -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (([(Runnable, String, String)] -> IO [([Async ()], TVar String)])
-> [[(Runnable, String, String)]]
-> IO [[([Async ()], TVar String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Runnable, String, String) -> IO ([Async ()], TVar String))
-> [(Runnable, String, String)] -> IO [([Async ()], TVar String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Runnable, String, String) -> IO ([Async ()], TVar String))
-> [(Runnable, String, String)] -> IO [([Async ()], TVar String)])
-> ((Runnable, String, String) -> IO ([Async ()], TVar String))
-> [(Runnable, String, String)]
-> IO [([Async ()], TVar String)]
forall a b. (a -> b) -> a -> b
$ TMVar SignalType
-> (Runnable, String, String) -> IO ([Async ()], TVar String)
startCommand TMVar SignalType
sig) [[(Runnable, String, String)]]
cls)
[[([Async ()], TVar String)]] -> IO ()
forall a. [[([Async ()], a)]] -> IO ()
cleanupThreads
(([[([Async ()], TVar String)]] -> IO ()) -> IO ())
-> ([[([Async ()], TVar String)]] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[[([Async ()], TVar String)]]
vars -> do
TVar [String]
tv <- TMVar SignalType
-> TMVar () -> [[([Async ()], TVar String)]] -> IO (TVar [String])
initLoop TMVar SignalType
sig TMVar ()
refLock [[([Async ()], TVar String)]]
vars
LoopFunction
looper TMVar SignalType
sig TVar [String]
tv
cleanupThreads :: [[([Async ()], a)]] -> IO ()
cleanupThreads :: [[([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
TVar [String]
tv <- [String] -> IO (TVar [String])
forall a. a -> IO (TVar a)
newTVarIO ([] :: [String])
ThreadId
_ <- IO () -> IO ThreadId
forkIO ((SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (String -> SomeException -> IO ()
handler String
"checker") (TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> TMVar ()
-> IO ()
checker TVar [String]
tv [] [[([Async ()], TVar String)]]
vs TMVar SignalType
sig TMVar ()
lock))
#ifdef DBUS
runIPC sig
#endif
TVar [String] -> IO (TVar [String])
forall (m :: * -> *) a. Monad m => a -> m a
return TVar [String]
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 TVar String
var <- String -> IO (TVar String)
forall a. a -> IO (TVar a)
newTVarIO String
is
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
ss)
([Async ()], TVar String) -> IO ([Async ()], TVar String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], TVar String
var)
| Bool
otherwise = do TVar String
var <- String -> IO (TVar String)
forall a. a -> IO (TVar a)
newTVarIO String
is
let cb :: String -> IO ()
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)
Async ()
a1 <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Runnable -> (String -> IO ()) -> IO ()
forall e. Exec e => e -> (String -> IO ()) -> IO ()
start Runnable
com String -> IO ()
cb
Async ()
a2 <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Runnable -> (Maybe SignalType -> IO ()) -> IO ()
forall e. Exec e => e -> (Maybe SignalType -> IO ()) -> IO ()
trigger Runnable
com ((Maybe SignalType -> IO ()) -> IO ())
-> (Maybe SignalType -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (SignalType -> IO ()) -> Maybe SignalType -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (SignalType -> STM ()) -> SignalType -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
sig)
([Async ()], TVar String) -> IO ([Async ()], TVar String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Async ()
a1, Async ()
a2], TVar String
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
[String]
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
[String]
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)
mapM [([Async ()], TVar String)] -> STM String
forall a a. [(a, TVar [a])] -> STM [a]
concatV [[([Async ()], TVar String)]]
vs
Bool -> STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([String]
nv [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= [String]
ov)
TVar [String] -> [String] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [String]
tvar [String]
nv
[String] -> STM [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
nv
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
sig SignalType
Wakeup
TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> TMVar ()
-> IO ()
checker TVar [String]
tvar [String]
nval [[([Async ()], TVar String)]]
vs TMVar SignalType
sig TMVar ()
pauser
where
concatV :: [(a, TVar [a])] -> STM [a]
concatV = ([[a]] -> [a]) -> STM [[a]] -> STM [a]
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)
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)