{-# 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 = forall a. a -> IO (TMVar a)
newTMVarIO ()
refreshLock :: TMVar () -> IO a -> IO a
refreshLock :: forall a. TMVar () -> IO a -> IO a
refreshLock TMVar ()
var = forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
lock IO ()
unlock
where
lock :: IO ()
lock = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar ()
var
unlock :: IO ()
unlock = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ 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
forall a. TMVar a -> STM a
takeTMVar TMVar ()
var
a
r <- STM a
action
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
var ()
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 = forall a. IO a -> IO a
withDeferSignals forall a b. (a -> b) -> a -> b
$ do
[[(Runnable, String, String)]]
cls <- 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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. IO (TMVar a)
newEmptyTMVarIO forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TMVar SignalType)
confSig
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isJust Maybe (TMVar SignalType)
confSig) forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> IO ()
setupSignalHandler TMVar SignalType
sig
TMVar ()
refLock <- IO (TMVar ())
newRefreshLock
forall a. (IO () -> IO ()) -> IO a -> IO a
withTimer (forall a. TMVar () -> IO a -> IO a
refreshLock TMVar ()
refLock) forall a b. (a -> b) -> a -> b
$
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a b. (a -> b) -> a -> b
$ TMVar SignalType
-> (Runnable, String, String) -> IO ([Async ()], TVar String)
startCommand TMVar SignalType
sig) [[(Runnable, String, String)]]
cls)
forall a. [[([Async ()], a)]] -> IO ()
cleanupThreads
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 :: forall a. [[([Async ()], a)]] -> IO ()
cleanupThreads [[([Async ()], a)]]
vars =
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[([Async ()], a)]]
vars) forall a b. (a -> b) -> a -> b
$ \([Async ()]
asyncs, a
_) ->
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Async ()]
asyncs 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 <- forall a. a -> IO (TVar a)
newTVarIO ([] :: [String])
ThreadId
_ <- IO () -> IO ThreadId
forkIO (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
forall (m :: * -> *) a. Monad m => a -> m a
return TVar [String]
tv
where
handler :: String -> SomeException -> IO ()
handler String
thing (SomeException e
e) =
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"Thread " forall a. [a] -> [a] -> [a]
++ String
thing forall a. [a] -> [a] -> [a]
++ String
" failed: " forall a. [a] -> [a] -> [a]
++ 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)
| forall e. Exec e => e -> String
alias Runnable
com forall a. Eq a => a -> a -> Bool
== String
"" = do TVar String
var <- forall a. a -> IO (TVar a)
newTVarIO String
is
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar String
var (String
s forall a. [a] -> [a] -> [a]
++ String
ss)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], TVar String
var)
| Bool
otherwise = do TVar String
var <- forall a. a -> IO (TVar a)
newTVarIO String
is
let cb :: String -> IO ()
cb String
str = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar String
var (String
s forall a. [a] -> [a] -> [a]
++ String
str forall a. [a] -> [a] -> [a]
++ String
ss)
Async ()
a1 <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall e. Exec e => e -> (String -> IO ()) -> IO ()
start Runnable
com String -> IO ()
cb
Async ()
a2 <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall e. Exec e => e -> (Maybe SignalType -> IO ()) -> IO ()
trigger Runnable
com forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
(forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
sig)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Async ()
a1, Async ()
a2], TVar String
var)
where is :: String
is = String
s forall a. [a] -> [a] -> [a]
++ String
"Updating..." 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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar () -> STM a -> STM a
refreshLockT TMVar ()
pauser forall a b. (a -> b) -> a -> b
$ do
[String]
nv <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a} {a}. [(a, TVar [a])] -> STM [a]
concatV [[([Async ()], TVar String)]]
vs
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([String]
nv forall a. Eq a => a -> a -> Bool
/= [String]
ov)
forall a. TVar a -> a -> STM ()
writeTVar TVar [String]
tvar [String]
nv
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
nv
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. TVar a -> STM a
readTVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)