1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
-- |
-- Module: Xmobar.App.CommandThreads
-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: unportable
-- Created: Fri Jan 28, 2022 03:20
--
--
-- Running a thread for each defined Command
--
------------------------------------------------------------------------------
module Xmobar.App.CommandThreads ( initLoop
, loop
, newRefreshLock
, refreshLock) 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 = newTMVarIO ()
refreshLock :: TMVar () -> IO a -> IO a
refreshLock var = bracket_ lock unlock
where
lock = atomically $ takeTMVar var
unlock = atomically $ putTMVar var ()
refreshLockT :: TMVar () -> STM a -> STM a
refreshLockT var action = do
takeTMVar var
r <- action
putTMVar var ()
return r
type StartFunction = TMVar SignalType
-> TMVar ()
-> [[([Async ()], TVar String)]]
-> IO ()
loop :: Config -> StartFunction -> IO ()
loop conf starter = withDeferSignals $ do
cls <- mapM (parseTemplate (commands conf) (sepChar conf))
(splitTemplate (alignSep conf) (template conf))
let confSig = unSignalChan (signal conf)
sig <- maybe newEmptyTMVarIO pure confSig
unless (isJust confSig) $ setupSignalHandler sig
refLock <- newRefreshLock
withTimer (refreshLock refLock) $
bracket (mapM (mapM $ startCommand sig) cls)
cleanupThreads
$ \vars -> do
starter sig refLock vars
cleanupThreads :: [[([Async ()], a)]] -> IO ()
cleanupThreads vars =
for_ (concat vars) $ \(asyncs, _) ->
for_ asyncs cancel
-- | Initialises context for an event loop, returning a TVar that
-- will hold the current list of values computed by commands.
initLoop :: TMVar SignalType -> TMVar () -> [[([Async ()], TVar String)]]
-> IO (TVar [String])
initLoop sig lock vs = do
tv <- newTVarIO ([] :: [String])
_ <- forkIO (handle (handler "checker") (checker tv [] vs sig lock))
#ifdef DBUS
runIPC sig
#endif
return tv
where
handler thing (SomeException e) =
void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e)
-- | Runs a command as an independent thread and returns its Async handles
-- and the TVar the command will be writing to.
startCommand :: TMVar SignalType
-> (Runnable,String,String)
-> IO ([Async ()], TVar String)
startCommand sig (com,s,ss)
| alias com == "" = do var <- newTVarIO is
atomically $ writeTVar var (s ++ ss)
return ([], var)
| otherwise = do var <- newTVarIO is
let cb str = atomically $ writeTVar var (s ++ str ++ ss)
a1 <- async $ start com cb
a2 <- async $ trigger com $ maybe (return ())
(atomically . putTMVar sig)
return ([a1, a2], var)
where is = s ++ "Updating..." ++ ss
-- | Send signal to eventLoop every time a var is updated
checker :: TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> TMVar ()
-> IO ()
checker tvar ov vs sig pauser = do
nval <- atomically $ refreshLockT pauser $ do
nv <- mapM concatV vs
guard (nv /= ov)
writeTVar tvar nv
return nv
atomically $ putTMVar sig Wakeup
checker tvar nval vs sig pauser
where
concatV = fmap concat . mapM (readTVar . snd)
|
