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

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
+  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
   -- alsacmd)
   _ <- installHandler sigCHLD Default Nothing
   -- this is needed to see any printed messages
   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
   , 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 :: Bool -> String -> CmdSpec
-ethernetCmd iface = 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 :: Bool -> CmdSpec
-batteryCmd =  CmdSpec
+batteryCmd icon = CmdSpec
   { csAlias = "battery"
   , csRunnable = Run
     $ Battery
@@ -144,64 +310,75 @@ batteryCmd =  CmdSpec
     , "--high", T.fgColor
     , "--"
     , "-P"
-    , "-o" , fontify "\xf0e7"
+    , "-o" , fontify "\xf0e7" "BAT"
-    , "-O" , fontify "\xf1e6"
+    , "-O" , fontify "\xf1e6" "AC"
-    , "-i" , fontify "\xf1e6"
+    , "-i" , fontify "\xf1e6" "AC"
     ] 50
   }
   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
-  , 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
-    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"
   , csRunnable = Run
     $ Alsa "default" "Master"
     [ "-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
     ]
   }
+  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
-  , 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
-  , 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
   , 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"
   , csRunnable = Run
     $ Locks
@@ -215,9 +392,9 @@ lockCmd = CmdSpec
     ]
   }
   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
 
 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
 -- 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"
+-- | 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
   | IconLarge
   | IconXLarge
   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 fnt txt = concat ["<fn=", show $ fromEnum fnt, ">", txt, "</fn>"]
+fontifyText fnt txt = concat ["<fn=", show $ 1 + fromEnum fnt, ">", txt, "</fn>"]
 
 --------------------------------------------------------------------------------
 -- | various formatting things

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
 

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)