{-# 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 forall a. Semigroup a => a -> a -> a
<> X ()
l') (X ()
s forall a. Semigroup a => a -> a -> a
<> X ()
s') (X ()
c forall a. Semigroup a => a -> a -> a
<> X ()
c')
instance Monoid StatusBarConfig where
mempty :: StatusBarConfig
mempty = X () -> X () -> X () -> StatusBarConfig
StatusBarConfig forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
instance Default StatusBarConfig where
def :: StatusBarConfig
def = 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 :: X ()
logHook = forall (l :: * -> *). XConfig l -> X ()
logHook XConfig l
conf forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> X ()
lh
, startupHook :: X ()
startupHook = forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig l
conf forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> X ()
ch forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> X ()
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 = forall (a :: * -> *). XConfig a -> XConfig a
docks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: * -> *).
LayoutClass l Window =>
StatusBarConfig -> XConfig l -> XConfig l
withSB StatusBarConfig
sb forall a b. (a -> b) -> a -> b
$ XConfig l
conf
{ layoutHook :: ModifiedLayout AvoidStruts l Window
layoutHook = forall (l :: * -> *) a.
LayoutClass l a =>
l a -> ModifiedLayout AvoidStruts l a
avoidStruts (forall (l :: * -> *). XConfig l -> l Window
layoutHook XConfig l
conf)
, keys :: XConfig Layout -> Map (KeyMask, Window) (X ())
keys = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XConfig Layout -> Map (KeyMask, Window) (X ())
keys' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (KeyMask, Window) (X ())
keys XConfig l
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) ->
forall (t :: * -> *). XConfig t -> (KeyMask, Window)
defToggleStrutsKey XConfig Layout
conf'
(KeyMask, Window)
key -> (KeyMask, Window)
key
keys' :: XConfig Layout -> Map (KeyMask, Window) (X ())
keys' = (forall k a. k -> a -> Map k a
`M.singleton` forall a. Message a => a -> X ()
sendMessage ToggleStruts
ToggleStruts) 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 forall a b. (a -> b) -> a -> b
$
String -> String -> X ()
xmonadPropLog' String
prop forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PP -> X String
dynamicLogString 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 = forall a. Default a => a
def
{ sbLogHook :: X ()
sbLogHook = X ()
lh
, sbStartupHook :: X ()
sbStartupHook = String -> X ()
spawnStatusBar String
cmd
, sbCleanupHook :: X ()
sbCleanupHook = String -> X ()
killStatusBar String
cmd
}
statusBarPipe :: String
-> X PP
-> IO StatusBarConfig
statusBarPipe :: String -> X PP -> IO StatusBarConfig
statusBarPipe String
cmd X PP
xpp = do
IORef (Maybe Handle)
hRef <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def
{ sbStartupHook :: X ()
sbStartupHook = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Handle)
hRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => String -> m Handle
spawnPipe String
cmd)
, sbLogHook :: X ()
sbLogHook = do
Maybe Handle
h' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (forall a. IORef a -> IO a
readIORef IORef (Maybe Handle)
hRef)
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
h' forall a b. (a -> b) -> a -> b
$ \Handle
h -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
h forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PP -> X String
dynamicLogString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X PP
xpp
, sbCleanupHook :: X ()
sbCleanupHook = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io
forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Maybe Handle)
hRef
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
`whenJust` Handle -> IO ()
hClose)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Handle)
hRef forall a. Maybe a
Nothing
}
newtype ActiveSBs = ASB {ActiveSBs -> [(ScreenId, StatusBarConfig)]
getASBs :: [(ScreenId, StatusBarConfig)]}
instance ExtensionClass ActiveSBs where
initialValue :: ActiveSBs
initialValue = [(ScreenId, StatusBarConfig)] -> ActiveSBs
ASB []
dynamicSBs :: (ScreenId -> X StatusBarConfig) -> XConfig l -> XConfig l
dynamicSBs :: forall (l :: * -> *).
(ScreenId -> X StatusBarConfig) -> XConfig l -> XConfig l
dynamicSBs ScreenId -> X StatusBarConfig
f XConfig l
conf = forall (l :: * -> *). X () -> XConfig l -> XConfig l
addAfterRescreenHook ((ScreenId -> X StatusBarConfig) -> X ()
updateSBs ScreenId -> X StatusBarConfig
f) forall a b. (a -> b) -> a -> b
$ XConfig l
conf
{ startupHook :: X ()
startupHook = forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig l
conf forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
killAllStatusBars forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ScreenId -> X StatusBarConfig) -> X ()
updateSBs ScreenId -> X StatusBarConfig
f
, logHook :: X ()
logHook = forall (l :: * -> *). XConfig l -> X ()
logHook XConfig l
conf forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
logSBs
}
dynamicEasySBs :: LayoutClass l Window
=> (ScreenId -> X StatusBarConfig)
-> XConfig l
-> XConfig (ModifiedLayout AvoidStruts l)
dynamicEasySBs :: forall (l :: * -> *).
LayoutClass l Window =>
(ScreenId -> X StatusBarConfig)
-> XConfig l -> XConfig (ModifiedLayout AvoidStruts l)
dynamicEasySBs ScreenId -> X StatusBarConfig
f XConfig l
conf =
forall (a :: * -> *). XConfig a -> XConfig a
docks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: * -> *).
(ScreenId -> X StatusBarConfig) -> XConfig l -> XConfig l
dynamicSBs ScreenId -> X StatusBarConfig
f forall a b. (a -> b) -> a -> b
$ XConfig l
conf { layoutHook :: ModifiedLayout AvoidStruts l Window
layoutHook = forall (l :: * -> *) a.
LayoutClass l a =>
l a -> ModifiedLayout AvoidStruts l a
avoidStruts (forall (l :: * -> *). XConfig l -> l Window
layoutHook XConfig l
conf) }
updateSBs :: (ScreenId -> X StatusBarConfig) -> X ()
updateSBs :: (ScreenId -> X StatusBarConfig) -> X ()
updateSBs ScreenId -> X StatusBarConfig
f = do
[ScreenId]
actualScreens <- forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall i l a sid sd. Screen i l a sid sd -> sid
W.screen forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) <-
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ScreenId]
actualScreens) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSBs -> [(ScreenId, StatusBarConfig)]
getASBs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
[StatusBarConfig] -> X ()
cleanSBs (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(ScreenId, StatusBarConfig)]
toKill)
let missing :: [ScreenId]
missing = [ScreenId]
actualScreens forall a. Eq a => [a] -> [a] -> [a]
\\ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ScreenId, StatusBarConfig)]
toKeep
[(ScreenId, StatusBarConfig)]
added <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\ScreenId
s -> (ScreenId
s,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScreenId -> X StatusBarConfig
f ScreenId
s) [ScreenId]
missing
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (StatusBarConfig -> X ()
sbStartupHook forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(ScreenId, StatusBarConfig)]
added
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put ([(ScreenId, StatusBarConfig)] -> ActiveSBs
ASB ([(ScreenId, StatusBarConfig)]
toKeep forall a. [a] -> [a] -> [a]
++ [(ScreenId, StatusBarConfig)]
added))
logSBs :: X ()
logSBs :: X ()
logSBs = forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (StatusBarConfig -> X ()
sbLogHook forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSBs -> [(ScreenId, StatusBarConfig)]
getASBs
cleanSBs :: [StatusBarConfig] -> X ()
cleanSBs :: [StatusBarConfig] -> X ()
cleanSBs = 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
Window
r <- 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"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StatusBarPIDs] -> ShowS
$cshowList :: [StatusBarPIDs] -> ShowS
show :: StatusBarPIDs -> String
$cshow :: StatusBarPIDs -> String
showsPrec :: Int -> StatusBarPIDs -> ShowS
$cshowsPrec :: Int -> StatusBarPIDs -> ShowS
Show, ReadPrec [StatusBarPIDs]
ReadPrec StatusBarPIDs
Int -> ReadS StatusBarPIDs
ReadS [StatusBarPIDs]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StatusBarPIDs]
$creadListPrec :: ReadPrec [StatusBarPIDs]
readPrec :: ReadPrec StatusBarPIDs
$creadPrec :: ReadPrec StatusBarPIDs
readList :: ReadS [StatusBarPIDs]
$creadList :: ReadS [StatusBarPIDs]
readsPrec :: Int -> ReadS StatusBarPIDs
$creadsPrec :: Int -> ReadS StatusBarPIDs
Read)
instance ExtensionClass StatusBarPIDs where
initialValue :: StatusBarPIDs
initialValue = Map String ProcessID -> StatusBarPIDs
StatusBarPIDs forall a. Monoid a => a
mempty
extensionType :: StatusBarPIDs -> StateExtension
extensionType = forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension
killStatusBar :: String
-> X ()
killStatusBar :: String -> X ()
killStatusBar String
cmd = do
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
cmd forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusBarPIDs -> Map String ProcessID
getPIDs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessID -> IO ()
killPid)
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify (Map String ProcessID -> StatusBarPIDs
StatusBarPIDs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
cmd forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusBarPIDs -> Map String ProcessID
getPIDs)
killPid :: ProcessID -> IO ()
killPid :: ProcessID -> IO ()
killPid ProcessID
pidToKill = forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 <- forall (m :: * -> *). MonadIO m => String -> m ProcessID
spawnPID String
cmd
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify (Map String ProcessID -> StatusBarPIDs
StatusBarPIDs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
cmd ProcessID
newPid forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusBarPIDs -> Map String ProcessID
getPIDs)
killAllStatusBars :: X ()
killAllStatusBars :: X ()
killAllStatusBars =
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets (forall k a. Map k a -> [a]
M.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusBarPIDs -> Map String ProcessID
getPIDs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ProcessID -> IO ()
killPid forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Map String ProcessID -> StatusBarPIDs
StatusBarPIDs forall a. Monoid a => a
mempty)
startAllStatusBars :: X ()
startAllStatusBars :: X ()
startAllStatusBars = forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (StatusBarConfig -> X ()
sbStartupHook forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSBs -> [(ScreenId, StatusBarConfig)]
getASBs