ENH make xmobar plugins crap out when icon font doesn't exist

This commit is contained in:
Nathan Dwarshuis 2022-07-04 00:36:41 -04:00
parent 05c0b6a116
commit 3644efe205
3 changed files with 279 additions and 181 deletions

View File

@ -16,15 +16,11 @@ import Data.List
import Data.Maybe import Data.Maybe
import DBus.Client import DBus.Client
import DBus.Internal
import System.Directory import System.Directory
import System.Exit import System.Exit
import System.IO import System.IO
import System.IO.Error import System.IO.Error
-- import System.Process
-- ( readProcessWithExitCode
-- )
import Xmobar.Plugins.Bluetooth import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard import Xmobar.Plugins.ClevoKeyboard
@ -42,6 +38,7 @@ import XMonad.Hooks.DynamicLog (wrap)
import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.Command.Power (hasBattery)
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Screensaver (ssSignalDep) import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import XMonad.Internal.Process import XMonad.Internal.Process
@ -50,30 +47,82 @@ import XMonad.Internal.Process
) )
import XMonad.Internal.Shell import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T import qualified XMonad.Internal.Theme as T
import Xmobar import Xmobar hiding
( iconOffset
)
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
main :: IO () main :: IO ()
main = do main = do
sysClient <- getDBusClient True db <- connectDBus
sesClient <- getDBusClient False c <- evalConfig db
ff <- evalFonts disconnectDBus db
cs <- getAllCommands =<< rightPlugins sysClient sesClient
d <- cfgDir <$> getDirectories
-- this is needed to prevent waitForProcess error when forking in plugins (eg -- this is needed to prevent waitForProcess error when forking in plugins (eg
-- alsacmd) -- alsacmd)
_ <- installHandler sigCHLD Default Nothing _ <- installHandler sigCHLD Default Nothing
-- this is needed to see any printed messages -- this is needed to see any printed messages
hFlush stdout hFlush stdout
mapM_ (maybe skip disconnect) [sysClient, sesClient] xmobar c
xmobar $ config ff cs d
config :: (BarFont -> BarMetaFont) -> BarRegions -> String -> Config evalConfig :: DBusState -> IO Config
config ff br confDir = defaultConfig evalConfig db = do
{ font = fontString ff firstFont cs <- getAllCommands =<< rightPlugins db
, additionalFonts = fontString ff <$> restFonts bf <- getTextFont
, textOffset = fontOffset ff firstFont (ifs, ios) <- getIconFonts
, textOffsets = fontOffset ff <$> restFonts d <- cfgDir <$> getDirectories
return $ config bf ifs ios cs d
--------------------------------------------------------------------------------
-- | toplevel configuration
-- | The text font family
textFont :: Always T.FontBuilder
textFont = T.fontFeature "XMobar Text Font" "DejaVu Sans Mono"
-- | Offset of the text in the bar
textFontOffset :: Int
textFontOffset = 16
-- | Attributes for the bar font (size, weight, etc)
textFontData :: T.FontData
textFontData = T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
-- | The icon font family
iconFont :: Sometimes T.FontBuilder
iconFont = sometimes1 "XMobar Icon Font" sfn root
where
fam = "Symbols Nerd Font"
sfn = "Font family for " ++ singleQuote fam
root = IORoot id $ T.fontTree fam
-- | Offsets for the icons in the bar (relative to the text offset)
iconOffset :: BarFont -> Int
iconOffset IconSmall = 0
iconOffset IconMedium = 1
iconOffset IconLarge = 1
iconOffset IconXLarge = 2
-- | Sizes (in pixels) for the icon fonts
iconSize :: BarFont -> Int
iconSize IconSmall = 13
iconSize IconMedium = 15
iconSize IconLarge = 18
iconSize IconXLarge = 20
-- | Attributes for icon fonts
iconFontData :: Int -> T.FontData
iconFontData s = T.defFontData { T.pixelsize = Just s, T.size = Nothing }
-- | Global configuration
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
-- only one) text font, and all other fonts are icon fonts. If this assumption
-- changes the code will need to change significantly
config :: String -> [String] -> [Int] -> BarRegions -> FilePath -> Config
config bf ifs ios br confDir = defaultConfig
{ font = bf
, additionalFonts = ifs
, textOffset = textFontOffset
, textOffsets = ios
, bgColor = T.bgColor , bgColor = T.bgColor
, fgColor = T.fgColor , fgColor = T.fgColor
, position = BottomSize C 100 24 , position = BottomSize C 100 24
@ -96,6 +145,121 @@ config ff br confDir = defaultConfig
, commands = csRunnable <$> concatRegions br , commands = csRunnable <$> concatRegions br
} }
--------------------------------------------------------------------------------
-- | plugin features
--
-- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
getAllCommands right = do
let left =
[ CmdSpec
{ csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader
}
]
return $ BarRegions
{ brLeft = left
, brCenter = []
, brRight = catMaybes right
}
rightPlugins :: DBusState -> IO [Maybe CmdSpec]
rightPlugins DBusState { dbSesClient = ses, dbSysClient = sys }
= mapM evalFeature
[ Left getWireless
, Left $ getEthernet sys
, Left $ getVPN sys
, Left $ getBt sys
, Left getAlsa
, Left getBattery
, Left $ getBl ses
, Left $ getCk ses
, Left $ getSs ses
, Right getLock
, always' "date indicator" dateCmd
]
where
always' n = Right . Always n . Always_ . FallbackAlone
type BarFeature = Sometimes CmdSpec
getWireless :: BarFeature
getWireless = sometimes1 "wireless status indicator" "sysfs path"
$ IORoot wirelessCmd
$ Only $ readInterface "get wifi interface" isWireless
getEthernet :: Maybe Client -> BarFeature
getEthernet cl = iconDBus "ethernet status indicator" root tree
where
root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
tree = And1 (Only readEth) (Only_ devDep)
readEth = readInterface "read ethernet interface" isEthernet
getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" root tree
where
root useIcon = IORoot_ (batteryCmd useIcon)
tree = Only_ $ sysTest "Test if battery is present" hasBattery
getVPN :: Maybe Client -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd vpnDep test
where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
getBt :: Maybe Client -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
getAlsa :: BarFeature
getAlsa = iconIO_ "volume level indicator" root $ Only_ $ sysExe "alsactl"
where
root useIcon = IORoot_ (alsaCmd useIcon)
getBl :: Maybe Client -> BarFeature
getBl = xmobarDBus "Intel backlight indicator" intelBacklightSignalDep blCmd
getCk :: Maybe Client -> BarFeature
getCk = xmobarDBus "Clevo keyboard indicator" clevoKeyboardSignalDep ckCmd
getSs :: Maybe Client -> BarFeature
getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
getLock :: Always CmdSpec
getLock = always1 "lock indicator" "icon indicator" root $ lockCmd False
where
root = IORoot_ (lockCmd True) $ Only_ iconDependency
--------------------------------------------------------------------------------
-- | bar feature constructors
xmobarDBus :: String -> DBusDependency_ -> (Bool -> CmdSpec) -> Maybe Client -> BarFeature
xmobarDBus n dep cmd cl = iconDBus_ n root (Only_ dep)
where
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
iconIO_ :: String -> (Bool -> IOTree_ -> Root CmdSpec) -> IOTree_ -> BarFeature
iconIO_ = iconSometimes' And_ Only_
iconDBus :: String -> (Bool -> DBusTree p -> Root CmdSpec)
-> DBusTree p -> BarFeature
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
iconDBus_ :: String -> (Bool -> DBusTree_ -> Root CmdSpec) -> DBusTree_
-> BarFeature
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String
-> (Bool -> t -> Root CmdSpec) -> t -> BarFeature
iconSometimes' c d n r t = Sometimes n
[ Subfeature icon "icon indicator" Error
, Subfeature text "text indicator" Error
]
where
icon = r True $ c t $ d iconDependency
text = r False t
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | command specifications -- | command specifications
@ -124,15 +288,17 @@ wirelessCmd iface = CmdSpec
] 5 ] 5
} }
ethernetCmd :: String -> CmdSpec ethernetCmd :: Bool -> String -> CmdSpec
ethernetCmd iface = CmdSpec ethernetCmd icon iface = CmdSpec
{ csAlias = iface { csAlias = iface
, csRunnable = Run , csRunnable = Run
$ Device (iface, fontifyText IconMedium "\xf0e8", colors) $ Device (iface, text, colors)
} }
where
text = if icon then fontifyText IconMedium "\xf0e8" else "ETH"
batteryCmd :: CmdSpec batteryCmd :: Bool -> CmdSpec
batteryCmd = CmdSpec batteryCmd icon = CmdSpec
{ csAlias = "battery" { csAlias = "battery"
, csRunnable = Run , csRunnable = Run
$ Battery $ Battery
@ -144,64 +310,75 @@ batteryCmd = CmdSpec
, "--high", T.fgColor , "--high", T.fgColor
, "--" , "--"
, "-P" , "-P"
, "-o" , fontify "\xf0e7" , "-o" , fontify "\xf0e7" "BAT"
, "-O" , fontify "\xf1e6" , "-O" , fontify "\xf1e6" "AC"
, "-i" , fontify "\xf1e6" , "-i" , fontify "\xf1e6" "AC"
] 50 ] 50
} }
where where
fontify = fontifyText IconSmall fontify i t = if icon then fontifyText IconSmall i else t ++ ": "
vpnCmd :: CmdSpec vpnCmd :: Bool -> CmdSpec
vpnCmd = CmdSpec vpnCmd icon = CmdSpec
{ csAlias = vpnAlias { csAlias = vpnAlias
, csRunnable = Run $ VPN (fontifyText IconMedium "\xf023", colors) , csRunnable = Run $ VPN (text, colors)
}
btCmd :: CmdSpec
btCmd = CmdSpec
{ csAlias = btAlias
, csRunnable = Run
$ Bluetooth (fontify "\xf5b0", fontify "\xf5ae") colors
} }
where where
fontify = fontifyText IconLarge text = if icon then fontifyText IconMedium "\xf023" else "VPN"
alsaCmd :: CmdSpec btCmd :: Bool -> CmdSpec
alsaCmd = CmdSpec btCmd icon = CmdSpec
{ csAlias = btAlias
, csRunnable = Run
$ Bluetooth (fontify "\xf5b0" "+", fontify "\xf5ae" "-") colors
}
where
fontify i t = if icon then fontifyText IconLarge i else "BT" ++ t
alsaCmd :: Bool -> CmdSpec
alsaCmd icon = CmdSpec
{ csAlias = "alsa:default:Master" { csAlias = "alsa:default:Master"
, csRunnable = Run , csRunnable = Run
$ Alsa "default" "Master" $ Alsa "default" "Master"
[ "-t", "<status><volume>%" [ "-t", "<status><volume>%"
, "--" , "--"
, "-O", fontifyText IconSmall "\xf028" -- TODO just make this gray when muted
, "-o", fontifyText IconSmall "\xf026 " , "-O", fontify "\xf028" "+"
, "-o", fontify "\xf026" "-" ++ " "
, "-c", T.fgColor , "-c", T.fgColor
, "-C", T.fgColor , "-C", T.fgColor
] ]
} }
where
fontify i t = if icon then fontifyText IconSmall i else "VOL" ++ t
blCmd :: CmdSpec blCmd :: Bool -> CmdSpec
blCmd = CmdSpec blCmd icon = CmdSpec
{ csAlias = blAlias { csAlias = blAlias
, csRunnable = Run $ IntelBacklight $ fontifyText IconSmall "\xf185" , csRunnable = Run $ IntelBacklight text
} }
where
text = if icon then fontifyText IconSmall "\xf185" else "BL: "
ckCmd :: CmdSpec ckCmd :: Bool -> CmdSpec
ckCmd = CmdSpec ckCmd icon = CmdSpec
{ csAlias = ckAlias { csAlias = ckAlias
, csRunnable = Run $ ClevoKeyboard $ fontifyText IconSmall "\xf40b" , csRunnable = Run $ ClevoKeyboard text
} }
where
text = if icon then fontifyText IconSmall "\xf40b" else "KB: "
ssCmd :: CmdSpec ssCmd :: Bool -> CmdSpec
ssCmd = CmdSpec ssCmd icon = CmdSpec
{ csAlias = ssAlias { csAlias = ssAlias
, csRunnable = Run , csRunnable = Run
$ Screensaver (fontifyText IconSmall "\xf254", colors) $ Screensaver (text, colors)
} }
where
text = if icon then fontifyText IconSmall "\xf254" else "SS"
lockCmd :: CmdSpec lockCmd :: Bool -> CmdSpec
lockCmd = CmdSpec lockCmd icon = CmdSpec
{ csAlias = "locks" { csAlias = "locks"
, csRunnable = Run , csRunnable = Run
$ Locks $ Locks
@ -215,9 +392,9 @@ lockCmd = CmdSpec
] ]
} }
where where
numIcon = fontify "\xf8a5" numIcon = fontify "\xf8a5" "N"
capIcon = fontify "\xf657" capIcon = fontify "\xf657" "C"
fontify = fontifyText IconXLarge fontify i t = if icon then fontifyText IconXLarge i else t
disabledColor = xmobarFGColor T.backdropFgColor disabledColor = xmobarFGColor T.backdropFgColor
dateCmd :: CmdSpec dateCmd :: CmdSpec
@ -227,17 +404,12 @@ dateCmd = CmdSpec
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | command runtime checks and setup -- | low-level testing functions
--
-- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here
-- --
-- in the case of network interfaces, assume that the system uses systemd in -- in the case of network interfaces, assume that the system uses systemd in
-- which case ethernet interfaces always start with "en" and wireless -- which case ethernet interfaces always start with "en" and wireless
-- interfaces always start with "wl" -- interfaces always start with "wl"
type BarFeature = Sometimes CmdSpec
isWireless :: String -> Bool isWireless :: String -> Bool
isWireless ('w':'l':_) = True isWireless ('w':'l':_) = True
isWireless _ = False isWireless _ = False
@ -273,137 +445,45 @@ vpnPresent =
++ show c ++ ": " ++ err ++ show c ++ ": " ++ err
go (Left e) = Just $ show e go (Left e) = Just $ show e
xmobarDBus :: String -> DBusDependency_ -> CmdSpec -> Maybe Client -> BarFeature --------------------------------------------------------------------------------
xmobarDBus n dep cmd cl = sometimesDBus cl n "xmobar dbus interface" -- | text font
(Only_ dep) $ const cmd --
-- ASSUME there is only one text font for this entire configuration. This
-- will correspond to the first font/offset parameters in the config record.
rightPlugins :: Maybe Client -> Maybe Client -> IO [Maybe CmdSpec] getTextFont :: IO String
rightPlugins sysClient sesClient = mapM evalFeature getTextFont = do
[ Left getWireless fb <- evalAlways textFont
, Left $ getEthernet sysClient return $ fb textFontData
, Left $ getVPN sysClient
, Left $ getBt sysClient
, Left getAlsa
, Left getBattery
, Left $ getBl sesClient
, Left $ getCk sesClient
, Left $ getSs sesClient
, always' "lock indicator" lockCmd
, always' "date indicator" dateCmd
]
where
always' n = Right . Always n . Always_ . FallbackAlone
getWireless :: BarFeature
getWireless = sometimes1 "wireless status indicator" "sysfs path"
$ IORoot wirelessCmd
$ Only $ readInterface "get wifi interface" isWireless
getEthernet :: Maybe Client -> BarFeature
getEthernet client = sometimes1 "ethernet status indicator" "sysfs path"
$ DBusRoot (const . ethernetCmd) tree client
where
tree = And1 (Only readEth) (Only_ devDep)
readEth = readInterface "read ethernet interface" isEthernet
getBattery :: BarFeature
getBattery = sometimesIO_ "battery level indicator" "sysfs path"
(Only_ $ sysTest "Test if battery is present" hasBattery)
batteryCmd
getVPN :: Maybe Client -> BarFeature
getVPN client = sometimesDBus client "VPN status indicator"
"xmobar dbus interface" (toAnd vpnDep test) (const vpnCmd)
where
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
getBt :: Maybe Client -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
getAlsa :: BarFeature
getAlsa = sometimesIO_ "volume level indicator" "alsactl"
(Only_ $ sysExe "alsactl") alsaCmd
getBl :: Maybe Client -> BarFeature
getBl = xmobarDBus "Intel backlight indicator" intelBacklightSignalDep blCmd
getCk :: Maybe Client -> BarFeature
getCk = xmobarDBus "Clevo keyboard indicator" clevoKeyboardSignalDep ckCmd
getSs :: Maybe Client -> BarFeature
getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
getAllCommands right = do
let left =
[ CmdSpec
{ csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader
}
]
return $ BarRegions
{ brLeft = left
, brCenter = []
, brRight = catMaybes right
}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | fonts -- | icon fonts
data BarFont = Text getIconFonts :: IO ([String], [Int])
| IconSmall getIconFonts = do
fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb
where
apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
<$> iconFonts
data BarFont = IconSmall
| IconMedium | IconMedium
| IconLarge | IconLarge
| IconXLarge | IconXLarge
deriving (Eq, Enum, Bounded, Show) deriving (Eq, Enum, Bounded, Show)
data BarMetaFont = BarMetaFont iconFonts :: [BarFont]
{ bfOffset :: Int iconFonts = enumFrom minBound
, bfBuilder :: T.FontBuilder
, bfFontData :: T.FontData
}
fontString :: (BarFont -> BarMetaFont) -> BarFont -> String iconString :: T.FontBuilder -> BarFont -> String
fontString f bf = b d iconString fb i = fb $ iconFontData $ iconSize i
where
b = bfBuilder $ f bf
d = bfFontData $ f bf
fontOffset :: (BarFont -> BarMetaFont) -> BarFont -> Int iconDependency :: IODependency_
fontOffset f = bfOffset . f iconDependency = IOSometimes_ iconFont
firstFont :: BarFont
firstFont = minBound
restFonts :: [BarFont]
restFonts = enumFrom $ succ minBound
barFont :: Always T.FontBuilder
barFont = T.fontFeature "XMobar Text Font" "DejaVu Sans Mono"
nerdFont :: Always T.FontBuilder
nerdFont = T.fontFeature "XMobar Icon Font" "Symbols Nerd Font"
evalFonts :: IO (BarFont -> BarMetaFont)
evalFonts = do
bf <- evalAlways barFont
nf <- evalAlways nerdFont
return $ fontData bf nf
fontData :: T.FontBuilder -> T.FontBuilder -> BarFont -> BarMetaFont
fontData barBuilder nerdBuilder bf = case bf of
Text -> BarMetaFont 16 barBuilder
$ T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
IconSmall -> nerd 16 13
IconMedium -> nerd 17 15
IconLarge -> nerd 17 18
IconXLarge -> nerd 18 20
where
nerd o s = BarMetaFont o nerdBuilder
$ T.defFontData { T.pixelsize = Just s, T.size = Nothing }
fontifyText :: BarFont -> String -> String fontifyText :: BarFont -> String -> String
fontifyText fnt txt = concat ["<fn=", show $ fromEnum fnt, ">", txt, "</fn>"] fontifyText fnt txt = concat ["<fn=", show $ 1 + fromEnum fnt, ">", txt, "</fn>"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | various formatting things -- | various formatting things

View File

@ -82,6 +82,8 @@ module XMonad.Internal.Dependency
, pathRW , pathRW
, pathW , pathW
, sysTest , sysTest
, voidResult
, voidRead
-- misc -- misc
, shellTest , shellTest
@ -621,6 +623,15 @@ listToAnds i = foldr (And_ . Only_) (Only_ i)
toAnd :: d -> d -> Tree_ d toAnd :: d -> d -> Tree_ d
toAnd a b = And_ (Only_ a) (Only_ b) toAnd a b = And_ (Only_ a) (Only_ b)
voidResult :: Result p -> Result_
voidResult (Left es) = Left es
voidResult (Right (PostPass _ ws)) = Right ws
voidRead :: Result p -> Maybe String
voidRead (Left []) = Just "unspecified error"
voidRead (Left (e:_)) = Just e
voidRead (Right _) = Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | IO Dependency Constructors -- | IO Dependency Constructors

View File

@ -21,11 +21,13 @@ module XMonad.Internal.Theme
, FontData(..) , FontData(..)
, FontBuilder , FontBuilder
, buildFont , buildFont
, fontTree
, fontDependency
, fontDependency_
, defFontData , defFontData
, defFontDep , defFontDep
, defFontTree , defFontTree
, fontFeature , fontFeature
, fontDependency
, tabbedTheme , tabbedTheme
, tabbedFeature , tabbedFeature
, promptTheme , promptTheme
@ -155,6 +157,11 @@ fontDependency :: String -> IODependency FontBuilder
fontDependency fam = fontDependency fam =
IORead (unwords ["test if font", singleQuote fam, "exists"]) $ testFont fam IORead (unwords ["test if font", singleQuote fam, "exists"]) $ testFont fam
fontDependency_ :: String -> IODependency_
fontDependency_ fam = sysTest n $ voidRead <$> testFont fam
where
n = unwords ["test if font", singleQuote fam, "exists"]
fontTree :: String -> IOTree FontBuilder fontTree :: String -> IOTree FontBuilder
fontTree fam = Or (Only $ fontDependency fam) (Only $ IOConst fallbackFont) fontTree fam = Or (Only $ fontDependency fam) (Only $ IOConst fallbackFont)