{-# LANGUAGE FlexibleContexts, TypeApplications, TupleSections #-}
module XMonad.Hooks.StatusBar (
StatusBarConfig(..),
withSB,
withEasySB,
defToggleStrutsKey,
statusBarProp,
statusBarPropTo,
statusBarGeneric,
statusBarPipe,
dynamicSBs,
dynamicEasySBs,
xmonadPropLog,
xmonadPropLog',
xmonadDefProp,
spawnStatusBar,
killStatusBar,
killAllStatusBars,
startAllStatusBars,
) where
import Control.Exception (SomeException, try)
import Data.IORef (newIORef, readIORef, writeIORef)
import qualified Codec.Binary.UTF8.String as UTF8 (encode)
import qualified Data.Map as M
import System.IO (hClose)
import System.Posix.Signals (sigTERM, signalProcessGroup)
import System.Posix.Types (ProcessID)
import Foreign.C (CChar)
import XMonad
import XMonad.Prelude
import XMonad.Util.Run
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Layout.LayoutModifier
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.Rescreen
import XMonad.Hooks.StatusBar.PP
import qualified XMonad.StackSet as W
data StatusBarConfig = StatusBarConfig { StatusBarConfig -> X ()
sbLogHook :: X ()
, StatusBarConfig -> X ()
sbStartupHook :: X ()
, StatusBarConfig -> X ()
sbCleanupHook :: X ()
}
instance Semigroup StatusBarConfig where
StatusBarConfig X ()
l X ()
s X ()
c <> :: StatusBarConfig -> StatusBarConfig -> StatusBarConfig
<> StatusBarConfig X ()
l' X ()
s' X ()
c' =
X () -> X () -> X () -> StatusBarConfig
StatusBarConfig (X ()
l X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> X ()
l') (X ()
s X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> X ()
s') (X ()
c X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> X ()
c')
instance Monoid StatusBarConfig where
mempty :: StatusBarConfig
mempty = X () -> X () -> X () -> StatusBarConfig
StatusBarConfig X ()
forall a. Monoid a => a
mempty X ()
forall a. Monoid a => a
mempty X ()
forall a. Monoid a => a
mempty
instance Default StatusBarConfig where
def :: StatusBarConfig
def = StatusBarConfig
forall a. Monoid a => a
mempty
withSB :: LayoutClass l Window
=> StatusBarConfig
-> XConfig l
-> XConfig l
withSB :: forall (l :: * -> *).
LayoutClass l Window =>
StatusBarConfig -> XConfig l -> XConfig l
withSB (StatusBarConfig X ()
lh X ()
sh X ()
ch) XConfig l
conf = XConfig l
conf
{ logHook = logHook conf *> lh
, startupHook = startupHook conf *> ch *> sh
}
withEasySB :: LayoutClass l Window
=> StatusBarConfig
-> (XConfig Layout -> (KeyMask, KeySym))
-> XConfig l
-> XConfig (ModifiedLayout AvoidStruts l)
withEasySB :: forall (l :: * -> *).
LayoutClass l Window =>
StatusBarConfig
-> (XConfig Layout -> (KeyMask, Window))
-> XConfig l
-> XConfig (ModifiedLayout AvoidStruts l)
withEasySB StatusBarConfig
sb XConfig Layout -> (KeyMask, Window)
k XConfig l
conf = XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l)
forall (a :: * -> *). XConfig a -> XConfig a
docks (XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l))
-> (XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l))
-> XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusBarConfig
-> XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l)
forall (l :: * -> *).
LayoutClass l Window =>
StatusBarConfig -> XConfig l -> XConfig l
withSB StatusBarConfig
sb (XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l))
-> XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l)
forall a b. (a -> b) -> a -> b
$ XConfig l
conf
{ layoutHook = avoidStruts (layoutHook conf)
, keys = (<>) <$> keys' <*> keys conf
}
where
k' :: XConfig Layout -> (KeyMask, Window)
k' XConfig Layout
conf' = case XConfig Layout -> (KeyMask, Window)
k XConfig Layout
conf' of
(KeyMask
0, Window
0) ->
XConfig Layout -> (KeyMask, Window)
forall (t :: * -> *). XConfig t -> (KeyMask, Window)
defToggleStrutsKey XConfig Layout
conf'
(KeyMask, Window)
key -> (KeyMask, Window)
key
keys' :: XConfig Layout -> Map (KeyMask, Window) (X ())
keys' = ((KeyMask, Window) -> X () -> Map (KeyMask, Window) (X ())
forall k a. k -> a -> Map k a
`M.singleton` ToggleStruts -> X ()
forall a. Message a => a -> X ()
sendMessage ToggleStruts
ToggleStruts) ((KeyMask, Window) -> Map (KeyMask, Window) (X ()))
-> (XConfig Layout -> (KeyMask, Window))
-> XConfig Layout
-> Map (KeyMask, Window) (X ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConfig Layout -> (KeyMask, Window)
k'
defToggleStrutsKey :: XConfig t -> (KeyMask, KeySym)
defToggleStrutsKey :: forall (t :: * -> *). XConfig t -> (KeyMask, Window)
defToggleStrutsKey XConfig{modMask :: forall (l :: * -> *). XConfig l -> KeyMask
modMask = KeyMask
modm} = (KeyMask
modm, Window
xK_b)
statusBarProp :: String
-> X PP
-> StatusBarConfig
statusBarProp :: String -> X PP -> StatusBarConfig
statusBarProp = String -> String -> X PP -> StatusBarConfig
statusBarPropTo String
xmonadDefProp
statusBarPropTo :: String
-> String
-> X PP
-> StatusBarConfig
statusBarPropTo :: String -> String -> X PP -> StatusBarConfig
statusBarPropTo String
prop String
cmd X PP
pp = String -> X () -> StatusBarConfig
statusBarGeneric String
cmd (X () -> StatusBarConfig) -> X () -> StatusBarConfig
forall a b. (a -> b) -> a -> b
$
String -> String -> X ()
xmonadPropLog' String
prop (String -> X ()) -> X String -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PP -> X String
dynamicLogString (PP -> X String) -> X PP -> X String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X PP
pp
statusBarGeneric :: String
-> X ()
-> StatusBarConfig
statusBarGeneric :: String -> X () -> StatusBarConfig
statusBarGeneric String
cmd X ()
lh = StatusBarConfig
forall a. Default a => a
def
{ sbLogHook = lh
, sbStartupHook = spawnStatusBar cmd
, sbCleanupHook = killStatusBar cmd
}
statusBarPipe :: String
-> X PP
-> IO StatusBarConfig
statusBarPipe :: String -> X PP -> IO StatusBarConfig
statusBarPipe String
cmd X PP
xpp = do
IORef (Maybe Handle)
hRef <- Maybe Handle -> IO (IORef (Maybe Handle))
forall a. a -> IO (IORef a)
newIORef Maybe Handle
forall a. Maybe a
Nothing
StatusBarConfig -> IO StatusBarConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StatusBarConfig -> IO StatusBarConfig)
-> StatusBarConfig -> IO StatusBarConfig
forall a b. (a -> b) -> a -> b
$ StatusBarConfig
forall a. Default a => a
def
{ sbStartupHook = io (writeIORef hRef . Just =<< spawnPipe cmd)
, sbLogHook = do
h' <- io (readIORef hRef)
whenJust h' $ \Handle
h -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> (String -> IO ()) -> String -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
h (String -> X ()) -> X String -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PP -> X String
dynamicLogString (PP -> X String) -> X PP -> X String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X PP
xpp
, sbCleanupHook = io
$ readIORef hRef
>>= (`whenJust` hClose)
>> writeIORef hRef Nothing
}
newtype ActiveSBs = ASB {ActiveSBs -> [(ScreenId, StatusBarConfig)]
getASBs :: [(ScreenId, StatusBarConfig)]}
instance ExtensionClass ActiveSBs where
initialValue :: ActiveSBs
initialValue = [(ScreenId, StatusBarConfig)] -> ActiveSBs
ASB []
dynamicSBs :: (ScreenId -> IO StatusBarConfig) -> XConfig l -> XConfig l
dynamicSBs :: forall (l :: * -> *).
(ScreenId -> IO StatusBarConfig) -> XConfig l -> XConfig l
dynamicSBs ScreenId -> IO StatusBarConfig
f XConfig l
conf = X () -> XConfig l -> XConfig l
forall (l :: * -> *). X () -> XConfig l -> XConfig l
addAfterRescreenHook ((ScreenId -> IO StatusBarConfig) -> X ()
updateSBs ScreenId -> IO StatusBarConfig
f) (XConfig l -> XConfig l) -> XConfig l -> XConfig l
forall a b. (a -> b) -> a -> b
$ XConfig l
conf
{ startupHook = startupHook conf >> killAllStatusBars >> updateSBs f
, logHook = logHook conf >> logSBs
}
dynamicEasySBs :: LayoutClass l Window
=> (ScreenId -> IO StatusBarConfig)
-> XConfig l
-> XConfig (ModifiedLayout AvoidStruts l)
dynamicEasySBs :: forall (l :: * -> *).
LayoutClass l Window =>
(ScreenId -> IO StatusBarConfig)
-> XConfig l -> XConfig (ModifiedLayout AvoidStruts l)
dynamicEasySBs ScreenId -> IO StatusBarConfig
f XConfig l
conf =
XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l)
forall (a :: * -> *). XConfig a -> XConfig a
docks (XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l))
-> (XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l))
-> XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScreenId -> IO StatusBarConfig)
-> XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l)
forall (l :: * -> *).
(ScreenId -> IO StatusBarConfig) -> XConfig l -> XConfig l
dynamicSBs ScreenId -> IO StatusBarConfig
f (XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l))
-> XConfig (ModifiedLayout AvoidStruts l)
-> XConfig (ModifiedLayout AvoidStruts l)
forall a b. (a -> b) -> a -> b
$ XConfig l
conf { layoutHook = avoidStruts (layoutHook conf) }
updateSBs :: (ScreenId -> IO StatusBarConfig) -> X ()
updateSBs :: (ScreenId -> IO StatusBarConfig) -> X ()
updateSBs ScreenId -> IO StatusBarConfig
f = do
[ScreenId]
actualScreens <- (WindowSet -> X [ScreenId]) -> X [ScreenId]
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X [ScreenId]) -> X [ScreenId])
-> (WindowSet -> X [ScreenId]) -> X [ScreenId]
forall a b. (a -> b) -> a -> b
$ [ScreenId] -> X [ScreenId]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScreenId] -> X [ScreenId])
-> (WindowSet -> [ScreenId]) -> WindowSet -> X [ScreenId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Screen String (Layout Window) Window ScreenId ScreenDetail
-> ScreenId)
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
-> [ScreenId]
forall a b. (a -> b) -> [a] -> [b]
map Screen String (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen ([Screen String (Layout Window) Window ScreenId ScreenDetail]
-> [ScreenId])
-> (WindowSet
-> [Screen String (Layout Window) Window ScreenId ScreenDetail])
-> WindowSet
-> [ScreenId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
forall i l a s sd. StackSet i l a s sd -> [Screen i l a s sd]
W.screens
([(ScreenId, StatusBarConfig)]
toKeep, [(ScreenId, StatusBarConfig)]
toKill) <-
((ScreenId, StatusBarConfig) -> Bool)
-> [(ScreenId, StatusBarConfig)]
-> ([(ScreenId, StatusBarConfig)], [(ScreenId, StatusBarConfig)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ScreenId -> [ScreenId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ScreenId]
actualScreens) (ScreenId -> Bool)
-> ((ScreenId, StatusBarConfig) -> ScreenId)
-> (ScreenId, StatusBarConfig)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScreenId, StatusBarConfig) -> ScreenId
forall a b. (a, b) -> a
fst) ([(ScreenId, StatusBarConfig)]
-> ([(ScreenId, StatusBarConfig)], [(ScreenId, StatusBarConfig)]))
-> (ActiveSBs -> [(ScreenId, StatusBarConfig)])
-> ActiveSBs
-> ([(ScreenId, StatusBarConfig)], [(ScreenId, StatusBarConfig)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSBs -> [(ScreenId, StatusBarConfig)]
getASBs (ActiveSBs
-> ([(ScreenId, StatusBarConfig)], [(ScreenId, StatusBarConfig)]))
-> X ActiveSBs
-> X ([(ScreenId, StatusBarConfig)], [(ScreenId, StatusBarConfig)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> X ActiveSBs
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
[StatusBarConfig] -> X ()
cleanSBs (((ScreenId, StatusBarConfig) -> StatusBarConfig)
-> [(ScreenId, StatusBarConfig)] -> [StatusBarConfig]
forall a b. (a -> b) -> [a] -> [b]
map (ScreenId, StatusBarConfig) -> StatusBarConfig
forall a b. (a, b) -> b
snd [(ScreenId, StatusBarConfig)]
toKill)
let missing :: [ScreenId]
missing = [ScreenId]
actualScreens [ScreenId] -> [ScreenId] -> [ScreenId]
forall a. Eq a => [a] -> [a] -> [a]
\\ ((ScreenId, StatusBarConfig) -> ScreenId)
-> [(ScreenId, StatusBarConfig)] -> [ScreenId]
forall a b. (a -> b) -> [a] -> [b]
map (ScreenId, StatusBarConfig) -> ScreenId
forall a b. (a, b) -> a
fst [(ScreenId, StatusBarConfig)]
toKeep
[(ScreenId, StatusBarConfig)]
added <- IO [(ScreenId, StatusBarConfig)] -> X [(ScreenId, StatusBarConfig)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [(ScreenId, StatusBarConfig)]
-> X [(ScreenId, StatusBarConfig)])
-> IO [(ScreenId, StatusBarConfig)]
-> X [(ScreenId, StatusBarConfig)]
forall a b. (a -> b) -> a -> b
$ (ScreenId -> IO (ScreenId, StatusBarConfig))
-> [ScreenId] -> IO [(ScreenId, StatusBarConfig)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\ScreenId
s -> (ScreenId
s,) (StatusBarConfig -> (ScreenId, StatusBarConfig))
-> IO StatusBarConfig -> IO (ScreenId, StatusBarConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScreenId -> IO StatusBarConfig
f ScreenId
s) [ScreenId]
missing
((ScreenId, StatusBarConfig) -> X ())
-> [(ScreenId, StatusBarConfig)] -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (StatusBarConfig -> X ()
sbStartupHook (StatusBarConfig -> X ())
-> ((ScreenId, StatusBarConfig) -> StatusBarConfig)
-> (ScreenId, StatusBarConfig)
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScreenId, StatusBarConfig) -> StatusBarConfig
forall a b. (a, b) -> b
snd) [(ScreenId, StatusBarConfig)]
added
ActiveSBs -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put ([(ScreenId, StatusBarConfig)] -> ActiveSBs
ASB ([(ScreenId, StatusBarConfig)]
toKeep [(ScreenId, StatusBarConfig)]
-> [(ScreenId, StatusBarConfig)] -> [(ScreenId, StatusBarConfig)]
forall a. [a] -> [a] -> [a]
++ [(ScreenId, StatusBarConfig)]
added))
logSBs :: X ()
logSBs :: X ()
logSBs = X ActiveSBs
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get X ActiveSBs -> (ActiveSBs -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((ScreenId, StatusBarConfig) -> X ())
-> [(ScreenId, StatusBarConfig)] -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (StatusBarConfig -> X ()
sbLogHook (StatusBarConfig -> X ())
-> ((ScreenId, StatusBarConfig) -> StatusBarConfig)
-> (ScreenId, StatusBarConfig)
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScreenId, StatusBarConfig) -> StatusBarConfig
forall a b. (a, b) -> b
snd) ([(ScreenId, StatusBarConfig)] -> X ())
-> (ActiveSBs -> [(ScreenId, StatusBarConfig)])
-> ActiveSBs
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSBs -> [(ScreenId, StatusBarConfig)]
getASBs
cleanSBs :: [StatusBarConfig] -> X ()
cleanSBs :: [StatusBarConfig] -> X ()
cleanSBs = (StatusBarConfig -> X ()) -> [StatusBarConfig] -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ StatusBarConfig -> X ()
sbCleanupHook
xmonadDefProp :: String
xmonadDefProp :: String
xmonadDefProp = String
"_XMONAD_LOG"
xmonadPropLog :: String -> X ()
xmonadPropLog :: String -> X ()
xmonadPropLog = String -> String -> X ()
xmonadPropLog' String
xmonadDefProp
xmonadPropLog' :: String
-> String
-> X ()
xmonadPropLog' :: String -> String -> X ()
xmonadPropLog' String
prop String
msg = do
Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
Window
r <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
Window
xlog <- String -> X Window
getAtom String
prop
Window
ustring <- String -> X Window
getAtom String
"UTF8_STRING"
IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> Window -> CInt -> [CChar] -> IO ()
changeProperty8 Display
d Window
r Window
xlog Window
ustring CInt
propModeReplace (String -> [CChar]
encodeCChar String
msg)
where
encodeCChar :: String -> [CChar]
encodeCChar :: String -> [CChar]
encodeCChar = (Word8 -> CChar) -> [Word8] -> [CChar]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> CChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [CChar]) -> (String -> [Word8]) -> String -> [CChar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
UTF8.encode
newtype StatusBarPIDs = StatusBarPIDs { StatusBarPIDs -> Map String ProcessID
getPIDs :: M.Map String ProcessID }
deriving (Int -> StatusBarPIDs -> ShowS
[StatusBarPIDs] -> ShowS
StatusBarPIDs -> String
(Int -> StatusBarPIDs -> ShowS)
-> (StatusBarPIDs -> String)
-> ([StatusBarPIDs] -> ShowS)
-> Show StatusBarPIDs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StatusBarPIDs -> ShowS
showsPrec :: Int -> StatusBarPIDs -> ShowS
$cshow :: StatusBarPIDs -> String
show :: StatusBarPIDs -> String
$cshowList :: [StatusBarPIDs] -> ShowS
showList :: [StatusBarPIDs] -> ShowS
Show, ReadPrec [StatusBarPIDs]
ReadPrec StatusBarPIDs
Int -> ReadS StatusBarPIDs
ReadS [StatusBarPIDs]
(Int -> ReadS StatusBarPIDs)
-> ReadS [StatusBarPIDs]
-> ReadPrec StatusBarPIDs
-> ReadPrec [StatusBarPIDs]
-> Read StatusBarPIDs
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS StatusBarPIDs
readsPrec :: Int -> ReadS StatusBarPIDs
$creadList :: ReadS [StatusBarPIDs]
readList :: ReadS [StatusBarPIDs]
$creadPrec :: ReadPrec StatusBarPIDs
readPrec :: ReadPrec StatusBarPIDs
$creadListPrec :: ReadPrec [StatusBarPIDs]
readListPrec :: ReadPrec [StatusBarPIDs]
Read)
instance ExtensionClass StatusBarPIDs where
initialValue :: StatusBarPIDs
initialValue = Map String ProcessID -> StatusBarPIDs
StatusBarPIDs Map String ProcessID
forall a. Monoid a => a
mempty
extensionType :: StatusBarPIDs -> StateExtension
extensionType = StatusBarPIDs -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension
killStatusBar :: String
-> X ()
killStatusBar :: String -> X ()
killStatusBar String
cmd = do
(StatusBarPIDs -> Maybe ProcessID) -> X (Maybe ProcessID)
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets (String -> Map String ProcessID -> Maybe ProcessID
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
cmd (Map String ProcessID -> Maybe ProcessID)
-> (StatusBarPIDs -> Map String ProcessID)
-> StatusBarPIDs
-> Maybe ProcessID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusBarPIDs -> Map String ProcessID
getPIDs) X (Maybe ProcessID) -> (Maybe ProcessID -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe ProcessID -> (ProcessID -> X ()) -> X ())
-> (ProcessID -> X ()) -> Maybe ProcessID -> X ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe ProcessID -> (ProcessID -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> (ProcessID -> IO ()) -> ProcessID -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessID -> IO ()
killPid)
(StatusBarPIDs -> StatusBarPIDs) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify (Map String ProcessID -> StatusBarPIDs
StatusBarPIDs (Map String ProcessID -> StatusBarPIDs)
-> (StatusBarPIDs -> Map String ProcessID)
-> StatusBarPIDs
-> StatusBarPIDs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Map String ProcessID -> Map String ProcessID
forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
cmd (Map String ProcessID -> Map String ProcessID)
-> (StatusBarPIDs -> Map String ProcessID)
-> StatusBarPIDs
-> Map String ProcessID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusBarPIDs -> Map String ProcessID
getPIDs)
killPid :: ProcessID -> IO ()
killPid :: ProcessID -> IO ()
killPid ProcessID
pidToKill = IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (CInt -> ProcessID -> IO ()
signalProcessGroup CInt
sigTERM ProcessID
pidToKill)
spawnStatusBar :: String
-> X ()
spawnStatusBar :: String -> X ()
spawnStatusBar String
cmd = do
ProcessID
newPid <- String -> X ProcessID
forall (m :: * -> *). MonadIO m => String -> m ProcessID
spawnPID String
cmd
(StatusBarPIDs -> StatusBarPIDs) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify (Map String ProcessID -> StatusBarPIDs
StatusBarPIDs (Map String ProcessID -> StatusBarPIDs)
-> (StatusBarPIDs -> Map String ProcessID)
-> StatusBarPIDs
-> StatusBarPIDs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProcessID -> Map String ProcessID -> Map String ProcessID
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
cmd ProcessID
newPid (Map String ProcessID -> Map String ProcessID)
-> (StatusBarPIDs -> Map String ProcessID)
-> StatusBarPIDs
-> Map String ProcessID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusBarPIDs -> Map String ProcessID
getPIDs)
killAllStatusBars :: X ()
killAllStatusBars :: X ()
killAllStatusBars =
(StatusBarPIDs -> [ProcessID]) -> X [ProcessID]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets (Map String ProcessID -> [ProcessID]
forall k a. Map k a -> [a]
M.elems (Map String ProcessID -> [ProcessID])
-> (StatusBarPIDs -> Map String ProcessID)
-> StatusBarPIDs
-> [ProcessID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusBarPIDs -> Map String ProcessID
getPIDs) X [ProcessID] -> ([ProcessID] -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> ([ProcessID] -> IO ()) -> [ProcessID] -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProcessID -> IO ()) -> [ProcessID] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ProcessID -> IO ()
killPid X () -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StatusBarPIDs -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Map String ProcessID -> StatusBarPIDs
StatusBarPIDs Map String ProcessID
forall a. Monoid a => a
mempty)
startAllStatusBars :: X ()
startAllStatusBars :: X ()
startAllStatusBars = X ActiveSBs
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get X ActiveSBs -> (ActiveSBs -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((ScreenId, StatusBarConfig) -> X ())
-> [(ScreenId, StatusBarConfig)] -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (StatusBarConfig -> X ()
sbStartupHook (StatusBarConfig -> X ())
-> ((ScreenId, StatusBarConfig) -> StatusBarConfig)
-> (ScreenId, StatusBarConfig)
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScreenId, StatusBarConfig) -> StatusBarConfig
forall a b. (a, b) -> b
snd) ([(ScreenId, StatusBarConfig)] -> X ())
-> (ActiveSBs -> [(ScreenId, StatusBarConfig)])
-> ActiveSBs
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSBs -> [(ScreenId, StatusBarConfig)]
getASBs