From 3644efe2056d20dce5c82eb60f22859cc70f1b88 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 4 Jul 2022 00:36:41 -0400 Subject: [PATCH] ENH make xmobar plugins crap out when icon font doesn't exist --- bin/xmobar.hs | 440 ++++++++++++++++++------------ lib/XMonad/Internal/Dependency.hs | 11 + lib/XMonad/Internal/Theme.hs | 9 +- 3 files changed, 279 insertions(+), 181 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 604b410..c02580d 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -16,15 +16,11 @@ import Data.List import Data.Maybe import DBus.Client -import DBus.Internal import System.Directory import System.Exit import System.IO import System.IO.Error --- import System.Process --- ( readProcessWithExitCode --- ) import Xmobar.Plugins.Bluetooth import Xmobar.Plugins.ClevoKeyboard @@ -42,6 +38,7 @@ import XMonad.Hooks.DynamicLog (wrap) import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.IntelBacklight +import XMonad.Internal.DBus.Control import XMonad.Internal.DBus.Screensaver (ssSignalDep) import XMonad.Internal.Dependency import XMonad.Internal.Process @@ -50,30 +47,82 @@ import XMonad.Internal.Process ) import XMonad.Internal.Shell import qualified XMonad.Internal.Theme as T -import Xmobar +import Xmobar hiding + ( iconOffset + ) import Xmobar.Plugins.Common main :: IO () main = do - sysClient <- getDBusClient True - sesClient <- getDBusClient False - ff <- evalFonts - cs <- getAllCommands =<< rightPlugins sysClient sesClient - d <- cfgDir <$> getDirectories + db <- connectDBus + c <- evalConfig db + disconnectDBus db -- this is needed to prevent waitForProcess error when forking in plugins (eg -- alsacmd) _ <- installHandler sigCHLD Default Nothing -- this is needed to see any printed messages hFlush stdout - mapM_ (maybe skip disconnect) [sysClient, sesClient] - xmobar $ config ff cs d + xmobar c -config :: (BarFont -> BarMetaFont) -> BarRegions -> String -> Config -config ff br confDir = defaultConfig - { font = fontString ff firstFont - , additionalFonts = fontString ff <$> restFonts - , textOffset = fontOffset ff firstFont - , textOffsets = fontOffset ff <$> restFonts +evalConfig :: DBusState -> IO Config +evalConfig db = do + cs <- getAllCommands =<< rightPlugins db + bf <- getTextFont + (ifs, ios) <- getIconFonts + 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 , fgColor = T.fgColor , position = BottomSize C 100 24 @@ -96,6 +145,121 @@ config ff br confDir = defaultConfig , 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 @@ -124,15 +288,17 @@ wirelessCmd iface = CmdSpec ] 5 } -ethernetCmd :: String -> CmdSpec -ethernetCmd iface = CmdSpec +ethernetCmd :: Bool -> String -> CmdSpec +ethernetCmd icon iface = CmdSpec { csAlias = iface , 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 = CmdSpec +batteryCmd :: Bool -> CmdSpec +batteryCmd icon = CmdSpec { csAlias = "battery" , csRunnable = Run $ Battery @@ -144,64 +310,75 @@ batteryCmd = CmdSpec , "--high", T.fgColor , "--" , "-P" - , "-o" , fontify "\xf0e7" - , "-O" , fontify "\xf1e6" - , "-i" , fontify "\xf1e6" + , "-o" , fontify "\xf0e7" "BAT" + , "-O" , fontify "\xf1e6" "AC" + , "-i" , fontify "\xf1e6" "AC" ] 50 } where - fontify = fontifyText IconSmall + fontify i t = if icon then fontifyText IconSmall i else t ++ ": " -vpnCmd :: CmdSpec -vpnCmd = CmdSpec +vpnCmd :: Bool -> CmdSpec +vpnCmd icon = CmdSpec { csAlias = vpnAlias - , csRunnable = Run $ VPN (fontifyText IconMedium "\xf023", colors) - } - -btCmd :: CmdSpec -btCmd = CmdSpec - { csAlias = btAlias - , csRunnable = Run - $ Bluetooth (fontify "\xf5b0", fontify "\xf5ae") colors + , csRunnable = Run $ VPN (text, colors) } where - fontify = fontifyText IconLarge + text = if icon then fontifyText IconMedium "\xf023" else "VPN" -alsaCmd :: CmdSpec -alsaCmd = CmdSpec +btCmd :: Bool -> 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" , csRunnable = Run $ Alsa "default" "Master" [ "-t", "%" , "--" - , "-O", fontifyText IconSmall "\xf028" - , "-o", fontifyText IconSmall "\xf026 " + -- TODO just make this gray when muted + , "-O", fontify "\xf028" "+" + , "-o", fontify "\xf026" "-" ++ " " , "-c", T.fgColor , "-C", T.fgColor ] } + where + fontify i t = if icon then fontifyText IconSmall i else "VOL" ++ t -blCmd :: CmdSpec -blCmd = CmdSpec +blCmd :: Bool -> CmdSpec +blCmd icon = CmdSpec { 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 = CmdSpec +ckCmd :: Bool -> CmdSpec +ckCmd icon = CmdSpec { 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 = CmdSpec +ssCmd :: Bool -> CmdSpec +ssCmd icon = CmdSpec { csAlias = ssAlias , csRunnable = Run - $ Screensaver (fontifyText IconSmall "\xf254", colors) + $ Screensaver (text, colors) } + where + text = if icon then fontifyText IconSmall "\xf254" else "SS" -lockCmd :: CmdSpec -lockCmd = CmdSpec +lockCmd :: Bool -> CmdSpec +lockCmd icon = CmdSpec { csAlias = "locks" , csRunnable = Run $ Locks @@ -215,9 +392,9 @@ lockCmd = CmdSpec ] } where - numIcon = fontify "\xf8a5" - capIcon = fontify "\xf657" - fontify = fontifyText IconXLarge + numIcon = fontify "\xf8a5" "N" + capIcon = fontify "\xf657" "C" + fontify i t = if icon then fontifyText IconXLarge i else t disabledColor = xmobarFGColor T.backdropFgColor dateCmd :: CmdSpec @@ -227,17 +404,12 @@ dateCmd = CmdSpec } -------------------------------------------------------------------------------- --- | command runtime checks and setup --- --- some commands depend on the presence of interfaces that can only be --- determined at runtime; define these checks here +-- | low-level testing functions -- -- in the case of network interfaces, assume that the system uses systemd in -- which case ethernet interfaces always start with "en" and wireless -- interfaces always start with "wl" -type BarFeature = Sometimes CmdSpec - isWireless :: String -> Bool isWireless ('w':'l':_) = True isWireless _ = False @@ -273,137 +445,45 @@ vpnPresent = ++ show c ++ ": " ++ err go (Left e) = Just $ show e -xmobarDBus :: String -> DBusDependency_ -> CmdSpec -> Maybe Client -> BarFeature -xmobarDBus n dep cmd cl = sometimesDBus cl n "xmobar dbus interface" - (Only_ dep) $ const cmd +-------------------------------------------------------------------------------- +-- | text font +-- +-- 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] -rightPlugins sysClient sesClient = mapM evalFeature - [ Left getWireless - , Left $ getEthernet sysClient - , 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 - } +getTextFont :: IO String +getTextFont = do + fb <- evalAlways textFont + return $ fb textFontData -------------------------------------------------------------------------------- --- | fonts +-- | icon fonts -data BarFont = Text - | IconSmall +getIconFonts :: IO ([String], [Int]) +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 | IconLarge | IconXLarge deriving (Eq, Enum, Bounded, Show) -data BarMetaFont = BarMetaFont - { bfOffset :: Int - , bfBuilder :: T.FontBuilder - , bfFontData :: T.FontData - } +iconFonts :: [BarFont] +iconFonts = enumFrom minBound -fontString :: (BarFont -> BarMetaFont) -> BarFont -> String -fontString f bf = b d - where - b = bfBuilder $ f bf - d = bfFontData $ f bf +iconString :: T.FontBuilder -> BarFont -> String +iconString fb i = fb $ iconFontData $ iconSize i -fontOffset :: (BarFont -> BarMetaFont) -> BarFont -> Int -fontOffset f = bfOffset . f - -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 } +iconDependency :: IODependency_ +iconDependency = IOSometimes_ iconFont fontifyText :: BarFont -> String -> String -fontifyText fnt txt = concat ["", txt, ""] +fontifyText fnt txt = concat ["", txt, ""] -------------------------------------------------------------------------------- -- | various formatting things diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index b37e741..f9fa017 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -82,6 +82,8 @@ module XMonad.Internal.Dependency , pathRW , pathW , sysTest + , voidResult + , voidRead -- misc , shellTest @@ -621,6 +623,15 @@ listToAnds i = foldr (And_ . Only_) (Only_ i) toAnd :: d -> d -> Tree_ d 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 diff --git a/lib/XMonad/Internal/Theme.hs b/lib/XMonad/Internal/Theme.hs index b74bff9..8a315e4 100644 --- a/lib/XMonad/Internal/Theme.hs +++ b/lib/XMonad/Internal/Theme.hs @@ -21,11 +21,13 @@ module XMonad.Internal.Theme , FontData(..) , FontBuilder , buildFont + , fontTree + , fontDependency + , fontDependency_ , defFontData , defFontDep , defFontTree , fontFeature - , fontDependency , tabbedTheme , tabbedFeature , promptTheme @@ -155,6 +157,11 @@ fontDependency :: String -> IODependency FontBuilder fontDependency 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 fam = Or (Only $ fontDependency fam) (Only $ IOConst fallbackFont)