ENH use font features

bin/xmobar.hs

@@ -52,20 +52,20 @@ main :: IO ()
 main = do
   sysClient <- getDBusClient True
   sesClient <- getDBusClient False
+  ff <- evalFonts
   cs <- getAllCommands =<< rightPlugins sysClient sesClient
   d <- cfgDir <$> getDirectories
   -- this is needed to see any printed messages
   hFlush stdout
   mapM_ (maybe skip disconnect) [sysClient, sesClient]
-  xmobar $ config cs d
+  xmobar $ config ff cs d
 
-config :: BarRegions -> String -> Config
+config :: (BarFont -> BarMetaFont) -> BarRegions -> String -> Config
-config br confDir = defaultConfig
+config ff br confDir = defaultConfig
-  -- TODO head makes me feel icky
+  { font = fontString ff firstFont
-  { font = head allFontStrings
+  , additionalFonts = fontString ff <$> restFonts
-  , additionalFonts = drop 1 allFontStrings
+  , textOffset = fontOffset ff firstFont
-  , textOffset = head allFontOffsets
+  , textOffsets = fontOffset ff <$> restFonts
-  , textOffsets = drop 1 allFontOffsets
   , bgColor = T.bgColor
   , fgColor = T.fgColor
   , position = BottomSize C 100 24
@@ -255,14 +255,14 @@ readInterface n f = IORead n go
           return $ Right $ PostPass x $ fmap ("ignoring extra interface: "++) xs
 
 vpnPresent :: IO (Maybe String)
-vpnPresent = do
+vpnPresent = go <$> tryIOError (readProcessWithExitCode "nmcli" args "")
-  res <- tryIOError $ readProcessWithExitCode "nmcli" args ""
-  -- TODO provide some error messages
-  return $ case res of
-    (Right (ExitSuccess, out, _)) -> if "vpn" `elem` lines out then Nothing else Just "vpn not found"
-    _                             -> Just "puke"
   where
     args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
+    go (Right (ExitSuccess, out, _))   = if "vpn" `elem` lines out then Nothing
+                                         else Just "vpn not found"
+    go (Right (ExitFailure c, _, err)) = Just $ "vpn search exited with code "
+                                         ++ 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"
@@ -298,7 +298,7 @@ getEthernet client = sometimes1 "ethernet status indicator" "sysfs path"
     readEth = readInterface "read ethernet interface" isEthernet
 
 getBattery :: BarFeature
-getBattery = sometimesIO "battery level indicator" "sysfs path"
+getBattery = sometimesIO_ "battery level indicator" "sysfs path"
   (Only_ $ sysTest "Test if battery is present" hasBattery)
   batteryCmd
 
@@ -312,7 +312,7 @@ getBt :: Maybe Client -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
 
 getAlsa :: BarFeature
-getAlsa = sometimesIO "volume level indicator" "alsactl"
+getAlsa = sometimesIO_ "volume level indicator" "alsactl"
   (Only_ $ sysExe "alsactl") alsaCmd
 
 getBl :: Maybe Client -> BarFeature
@@ -341,51 +341,83 @@ getAllCommands right = do
 --------------------------------------------------------------------------------
 -- | fonts
 
-data Font = Text
+data BarFont = Text
   | IconSmall
   | IconMedium
   | IconLarge
   | IconXLarge
   deriving (Eq, Enum, Bounded, Show)
 
+data BarMetaFont = BarMetaFont
+  { bfOffset   :: Int
+  , bfBuilder  :: T.FontBuilder
+  , bfFontData :: T.FontData
+  }
+
 -- font data ~ (offset, fontification string)
-fontData :: Font -> (Int, String)
+fontString :: (BarFont -> BarMetaFont) -> BarFont -> String
-fontData Text       = (16, barFont)
+fontString f bf = b d
-fontData IconSmall  = (16, nerdFont 13)
+  where
-fontData IconMedium = (17, nerdFont 15)
+    b = bfBuilder $ f bf
-fontData IconLarge  = (17, nerdFont 18)
+    d = bfFontData $ f bf
-fontData IconXLarge = (18, nerdFont 20)
 
-fontString :: Font -> String
+fontOffset :: (BarFont -> BarMetaFont) -> BarFont -> Int
-fontString = snd . fontData
+fontOffset f = bfOffset . f
 
-fontOffset :: Font -> Int
+firstFont :: BarFont
-fontOffset = fst . fontData
+firstFont = minBound
 
-allFonts :: [Font]
+restFonts :: [BarFont]
-allFonts = enumFrom minBound
+restFonts = enumFrom $ succ minBound
 
-allFontOffsets :: [Int]
+-- allFonts :: [BarFont]
-allFontOffsets = fontOffset <$> allFonts
+-- allFonts = enumFrom minBound
 
-allFontStrings :: [String]
+-- allFontOffsets :: [Int]
-allFontStrings = fontString <$> allFonts
+-- allFontOffsets = fontOffset <$> allFonts
 
-barFont :: String
+-- allFontStrings :: [String]
-barFont = T.fmtFontXFT T.font
+-- allFontStrings = fontString <$> allFonts
-  { T.family = "DejaVu Sans Mono"
-  , T.size = Just 11
-  , T.weight = Just T.Bold
-  }
 
-nerdFont :: Int -> String
+barFont :: Always T.FontBuilder
-nerdFont size = T.fmtFontXFT T.font
+barFont = T.fontFeature "XMobar Text Font" "DejaVu Sans Mono"
-  { T.family = "Symbols Nerd Font"
-  , T.size = Nothing
-  , T.pixelsize = Just size
-  }
 
-fontifyText :: Font -> String -> String
+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 }
+
+-- barFont :: Always T.FontBuilder
+-- barFont = T.fmtFontXFT T.font
+--   { T.family = "DejaVu Sans Mono"
+--   , T.size = Just 11
+--   , T.weight = Just T.Bold
+--   }
+
+-- nerdFont :: Int -> String
+-- nerdFont size = T.fmtFontXFT T.font
+--   { T.family = "Symbols Nerd Font"
+--   , T.size = Nothing
+--   , T.pixelsize = Just size
+--   }
+
+fontifyText :: BarFont -> String -> String
 fontifyText fnt txt = concat ["<fn=", show $ fromEnum fnt, ">", txt, "</fn>"]
 
 --------------------------------------------------------------------------------

bin/xmonad.hs

@@ -92,6 +92,7 @@ run = do
            { tsChildPIDs = [p]
            , tsChildHandles = [h]
            }
+  fb <- evalAlways T.defFont
   ext <- evalExternal $ externalBindings ts db
   sk <- evalAlways runShowKeys
   ha <- evalAlways runHandleACPI
@@ -103,7 +104,7 @@ run = do
              $ docks
              $ def { terminal = myTerm
                    , modMask = myModMask
-                   , layoutHook = myLayouts
+                   , layoutHook = myLayouts fb
                    , manageHook = myManageHook
                    , handleEventHook = myEventHook ha
                    , startupHook = myStartupHook
@@ -262,12 +263,12 @@ allDWs = [ xsaneDynamicWorkspace
 --------------------------------------------------------------------------------
 -- | Layout configuration
 
-myLayouts = onWorkspace (dwTag wmDynamicWorkspace) vmLayout
+myLayouts fb = onWorkspace (dwTag wmDynamicWorkspace) vmLayout
   $ onWorkspace (dwTag gimpDynamicWorkspace) gimpLayout
   $ mkToggle (single HIDE)
   $ tall ||| fulltab ||| full
   where
-    addTopBar = noFrillsDeco shrinkText T.tabbedTheme
+    addTopBar = noFrillsDeco shrinkText $ T.tabbedTheme fb
     tall = renamed [Replace "Tall"]
       $ avoidStruts
       $ addTopBar
@@ -276,7 +277,7 @@ myLayouts = onWorkspace (dwTag wmDynamicWorkspace) vmLayout
     fulltab = renamed [Replace "Tabbed"]
       $ avoidStruts
       $ noBorders
-      $ tabbedAlways shrinkText T.tabbedTheme
+      $ tabbedAlways shrinkText $ T.tabbedTheme fb
     full = renamed [Replace "Full"]
       $ noBorders Full
     vmLayout = noBorders Full
@@ -610,7 +611,7 @@ externalBindings ts db =
     , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
     , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
     , KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt
-    , KeyBinding "M-<Home>" "quit xmonad" quitf
+    , KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
     , KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
     -- M-<F1> reserved for showing the keymap
     , KeyBinding "M-<F2>" "restart xmonad" restartf
@@ -630,7 +631,6 @@ externalBindings ts db =
     ib = Left . brightessControls intelBacklightControls
     ck = Left . brightessControls clevoKeyboardControls
     ftrAlways n = Right . Always n . Always_ . FallbackAlone
-    quitf = ftrAlways "quit function" runQuitPrompt
     restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
     recompilef = ftrAlways "recompile function" runRecompile
 

install_deps

@@ -3,8 +3,8 @@
 ## Install all pkgs required for xmonad to run at full capacity
 
 xmonad_pkgs=(autorandr feh xorg-server xorg-xset libpulse flameshot
-             playerctl wireless_tools acpid ttf-symbola-free ttf-symbola-free
+             playerctl acpid ttf-symbola-free ttf-symbola-free
-             ttf-dejavu awesome-terminal-fonts numlockx picom i3lock-color
+             ttf-dejavu numlockx picom i3lock-color
              xorg-xrandr xss-lock)
 
 yay --needed --noconfirm --norebuild --removemake -S "${xmonad_pkgs[@]}"

lib/XMonad/Internal/Command/DMenu.hs

@@ -72,7 +72,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
 -- | Exported Commands
 
 runDevMenu :: SometimesX
-runDevMenu = sometimesIO "device manager" "rofi devices" t x
+runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
   where
     t = Only_ $ localExe myDmenuDevices
     x = do
@@ -87,12 +87,12 @@ runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
   myDmenuBluetooth $ "-c":themeArgs "#0044bb"
 
 runBwMenu :: SometimesX
-runBwMenu = sometimesIO "password manager" "rofi bitwarden"
+runBwMenu = sometimesIO_ "password manager" "rofi bitwarden"
   (Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords
   $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
 
 runVPNMenu :: SometimesX
-runVPNMenu = sometimesIO "VPN selector" "rofi VPN"
+runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN"
   (Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN
   $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
 
@@ -103,7 +103,7 @@ runAppMenu :: SometimesX
 runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 
 runClipMenu :: SometimesX
-runClipMenu = sometimesIO "clipboard manager" "rofi greenclip" deps act
+runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" deps act
   where
     act = spawnCmd myDmenuCmd args
     deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip")

lib/XMonad/Internal/Command/Desktop.hs

@@ -95,7 +95,7 @@ runTerm :: SometimesX
 runTerm = sometimesExe "terminal" "urxvt" True myTerm
 
 runTMux :: SometimesX
-runTMux = sometimesIO "terminal multiplexer" "tmux" deps act
+runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
   where
     deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"]
     act = spawn
@@ -106,7 +106,7 @@ runTMux = sometimesIO "terminal multiplexer" "tmux" deps act
     msg = "could not connect to tmux session"
 
 runCalc :: SometimesX
-runCalc = sometimesIO "calculator" "R" deps act
+runCalc = sometimesIO_ "calculator" "R" deps act
   where
     deps = toAnd (sysExe myTerm) (sysExe "R")
     act = spawnCmd myTerm ["-e", "R"]
@@ -155,7 +155,7 @@ playSound file = do
 
 featureSound :: String -> FilePath -> X () -> X () -> SometimesX
 featureSound n file pre post =
-  sometimesIO ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay")
+  sometimesIO_ ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay")
   $ pre >> playSound file >> post
 
 runVolumeDown :: SometimesX
@@ -194,7 +194,7 @@ runNotificationContext =
 
 runToggleBluetooth :: SometimesX
 runToggleBluetooth =
-  sometimesIO "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
+  sometimesIO_ "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
   $ spawn
   $ myBluetooth ++ " show | grep -q \"Powered: no\""
   #!&& "a=on"
@@ -203,7 +203,7 @@ runToggleBluetooth =
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a"  }
 
 runToggleEthernet :: SometimesX
-runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli")
+runToggleEthernet = sometimesIO_ "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli")
   $ spawn
   $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
   #!&& "a=connect"
@@ -212,7 +212,7 @@ runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed"  }
 
 runStartISyncTimer :: SometimesX
-runStartISyncTimer = sometimesIO "isync timer" "mbsync timer"
+runStartISyncTimer = sometimesIO_ "isync timer" "mbsync timer"
   (Only_ $ sysdUser "mbsync.timer")
   $ spawn
   $ "systemctl --user start mbsync.timer"
@@ -220,7 +220,7 @@ runStartISyncTimer = sometimesIO "isync timer" "mbsync timer"
   #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
 
 runStartISyncService :: SometimesX
-runStartISyncService = sometimesIO "isync" "mbsync service"
+runStartISyncService = sometimesIO_ "isync" "mbsync service"
   (Only_ $ sysdUser "mbsync.service")
   $ spawn
   $ "systemctl --user start mbsync.service"
@@ -266,7 +266,7 @@ getCaptureDir = do
     fallback = (</> ".local/share") <$> getHomeDirectory
 
 runFlameshot :: String -> String -> SometimesX
-runFlameshot n mode = sometimesIO n "flameshot" (Only_ $ sysExe myCapture)
+runFlameshot n mode = sometimesIO_ n "flameshot" (Only_ $ sysExe myCapture)
   $ spawnCmd myCapture [mode]
 
 -- TODO this will steal focus from the current window (and puts it
@@ -283,7 +283,7 @@ runScreenCapture :: SometimesX
 runScreenCapture = runFlameshot "screen capture" "screen"
 
 runCaptureBrowser :: SometimesX
-runCaptureBrowser = sometimesIO "screen capture browser" "feh"
+runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
   (Only_ $ sysExe myImageBrowser) $ do
   dir <- io getCaptureDir
   spawnCmd myImageBrowser [dir]

lib/XMonad/Internal/Command/Power.hs

@@ -12,8 +12,8 @@ module XMonad.Internal.Command.Power
   , runSuspendPrompt
   , runQuitPrompt
   , hasBattery
-
+  , suspendPrompt
-
+  , quitPrompt
   , powerPrompt
   ) where
 
@@ -45,11 +45,14 @@ myScreenlock = "screenlock"
 myOptimusManager :: String
 myOptimusManager = "optimus-manager"
 
+myPrimeOffload :: String
+myPrimeOffload = "prime-offload"
+
 --------------------------------------------------------------------------------
 -- | Core commands
 
 runScreenLock :: SometimesX
-runScreenLock = sometimesExe "screen locker" "i3lock script" True myScreenlock
+runScreenLock = sometimesExe "screen locker" "i3lock script" False myScreenlock
 
 runPowerOff :: X ()
 runPowerOff = spawn "systemctl poweroff"
@@ -64,14 +67,27 @@ runReboot :: X ()
 runReboot = spawn "systemctl reboot"
 
 --------------------------------------------------------------------------------
--- | Confirm prompt wrappers
+-- | Confirmation prompts
+
+confirmPrompt' :: String -> X () -> T.FontBuilder -> X ()
+confirmPrompt' s x fb = confirmPrompt (T.promptTheme fb) s x
+
+suspendPrompt :: T.FontBuilder -> X ()
+suspendPrompt = confirmPrompt' "suspend?" runSuspend
+
+quitPrompt :: T.FontBuilder -> X ()
+quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
+
+sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
+sometimesPrompt n = sometimesIO n (n ++ " command")
+  $ Only $ IOAlways T.defFont id
 
 -- TODO doesn't this need to also lock the screen?
-runSuspendPrompt :: X ()
+runSuspendPrompt :: SometimesX
-runSuspendPrompt = confirmPrompt T.promptTheme "suspend?" runSuspend
+runSuspendPrompt = sometimesPrompt "suspend prompt" suspendPrompt
 
-runQuitPrompt :: X ()
+runQuitPrompt :: SometimesX
-runQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess
+runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
 
 --------------------------------------------------------------------------------
 -- | Nvidia Optimus
@@ -91,21 +107,25 @@ hasBattery = do
     readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
     syspath = "/sys/class/power_supply"
 
-runOptimusPrompt' :: X ()
+runOptimusPrompt' :: T.FontBuilder -> X ()
-runOptimusPrompt' = do
+runOptimusPrompt' fb = do
   nvidiaOn <- io isUsingNvidia
   switch $ if nvidiaOn then "integrated" else "nvidia"
   where
-    switch mode = confirmPrompt T.promptTheme (prompt mode) (cmd mode)
+    switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
     prompt mode = "gpu switch to " ++ mode ++ "?"
     cmd mode = spawn $
-      "prime-offload"
+      myPrimeOffload
       #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
       #!&& "killall xmonad"
 
 runOptimusPrompt :: SometimesX
-runOptimusPrompt = sometimesIO "graphics switcher" "optimus manager"
+runOptimusPrompt = Sometimes "graphics switcher" [s]
-  (Only_ $ localExe myOptimusManager) runOptimusPrompt'
+  where
+    s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error }
+    r = IORoot runOptimusPrompt' t
+    t = And1 (Only $ IOAlways T.defFont id)
+      $ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload)
 
 --------------------------------------------------------------------------------
 -- | Universal power prompt
@@ -134,18 +154,21 @@ instance XPrompt PowerPrompt where
     showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
 
 runPowerPrompt :: AlwaysX
-runPowerPrompt = always1 "power prompt" "lock-enabled prompt" withLock powerPromptNoLock
+runPowerPrompt = Always "power prompt" $ Option sf fallback
   where
-    withLock =  IORoot powerPrompt (Only $ IOSometimes runScreenLock id)
+    sf = Subfeature withLock "lock-enabled prompt" Error
+    withLock = IORoot (uncurry powerPrompt) tree
+    tree = And12 (,) (Only $ IOSometimes runScreenLock id) (Only $ IOAlways T.defFont id)
+    fallback = Always_ $ FallbackTree powerPromptNoLock $ FallbackBottom T.defFont
 
-powerPromptNoLock :: X ()
+powerPromptNoLock :: T.FontBuilder -> X ()
 powerPromptNoLock = powerPrompt skip
 
-powerPrompt :: X () -> X ()
+powerPrompt :: X () -> T.FontBuilder -> X ()
-powerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction
+powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
   where
     comp = mkComplFunFromList theme []
-    theme = T.promptTheme { promptKeymap = keymap }
+    theme = (T.promptTheme fb) { promptKeymap = keymap }
     keymap = M.fromList
       $ ((controlMask, xK_g), quit) :
       map (first $ (,) 0)

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -27,6 +27,7 @@ import           XMonad.Internal.Command.Power
 import           XMonad.Internal.Concurrent.ClientMessage
 import           XMonad.Internal.Dependency
 import           XMonad.Internal.Shell
+import           XMonad.Internal.Theme                    (FontBuilder, defFont)
 
 --------------------------------------------------------------------------------
 -- | Data structure to hold the ACPI events I care about
@@ -90,17 +91,17 @@ listenACPI = do
 acpiPath :: FilePath
 acpiPath = "/var/run/acpid.socket"
 
-socketDep :: Tree_ IODependency_
+socketDep :: IOTree_
 socketDep = Only_ $ pathR acpiPath
 
 -- | Handle ClientMessage event containing and ACPI event (to be used in
 -- Xmonad's event hook)
-handleACPI :: X () -> String -> X ()
+handleACPI :: FontBuilder -> X () -> String -> X ()
-handleACPI lock tag = do
+handleACPI fb lock tag = do
   let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
   forM_ acpiTag $ \case
-    Power -> powerPrompt lock
+    Power -> powerPrompt lock fb
-    Sleep -> runSuspendPrompt
+    Sleep -> suspendPrompt fb
     LidClose -> do
       status <- io isDischarging
       -- only run suspend if battery exists and is discharging
@@ -113,9 +114,12 @@ handleACPI lock tag = do
 -- | Spawn a new thread that will listen for ACPI events on the acpid socket
 -- and send ClientMessage events when it receives them
 runPowermon :: SometimesIO
-runPowermon = sometimesIO "ACPI event monitor" "acpid" socketDep listenACPI
+runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep listenACPI
 
 runHandleACPI :: Always (String -> X ())
-runHandleACPI = always1 "ACPI event handler" "acpid" withLock $ handleACPI skip
+runHandleACPI = Always "ACPI event handler" $ Option sf fallback
   where
-    withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id)
+    sf = Subfeature withLock "acpid prompt" Error
+    withLock = IORoot (uncurry handleACPI)
+      $ And12 (,) (Only $ IOAlways defFont id) (Only $ IOSometimes runScreenLock id)
+    fallback = Always_ $ FallbackTree (`handleACPI` skip) $ FallbackBottom defFont

lib/XMonad/Internal/Dependency.hs

@@ -29,6 +29,10 @@ module XMonad.Internal.Dependency
   , Root(..)
   , Tree(..)
   , Tree_(..)
+  , IOTree
+  , IOTree_
+  , DBusTree
+  , DBusTree_
   , IODependency(..)
   , IODependency_(..)
   , SystemDependency(..)
@@ -61,6 +65,7 @@ module XMonad.Internal.Dependency
   , always1
   , sometimes1
   , sometimesIO
+  , sometimesIO_
   , sometimesDBus
   , sometimesExe
   , sometimesExeArgs
@@ -69,6 +74,7 @@ module XMonad.Internal.Dependency
   -- dependency construction
   , sysExe
   , localExe
+  , fontFam
   , sysdSystem
   , sysdUser
   , listToAnds
@@ -187,12 +193,14 @@ type Feature a = Either (Sometimes a) (Always a)
 data Always a = Always String (Always_ a)
 
 -- | Feature that is guaranteed to work (inner data)
-data Always_ a = Option (SubfeatureRoot a) (Always_ a) | Always_ (FallbackRoot a)
+data Always_ a = Option (SubfeatureRoot a) (Always_ a)
+  | Always_ (FallbackRoot a)
 
 -- | Root of a fallback action for an always
 -- This may either be a lone action or a function that depends on the results
 -- from other Always features.
-data FallbackRoot a = FallbackAlone a | forall p. FallbackTree (p -> a) (FallbackStack p)
+data FallbackRoot a = FallbackAlone a
+  | forall p. FallbackTree (p -> a) (FallbackStack p)
 
 -- | Always features that are used as a payload for a fallback action
 data FallbackStack p = FallbackBottom (Always p)
@@ -225,13 +233,12 @@ data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
 -- | An action and its dependencies
 -- May be a plain old monad or be DBus-dependent, in which case a client is
 -- needed
-data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p)
+data Root a = forall p. IORoot (p -> a) (IOTree p)
-  | IORoot_ a (Tree_ IODependency_)
+  | IORoot_ a IOTree_
-  | forall p. DBusRoot (p -> Client -> a)
+  | forall p. DBusRoot (p -> Client -> a) (DBusTree p) (Maybe Client)
-    (Tree IODependency DBusDependency_ p) (Maybe Client)
+  | DBusRoot_ (Client -> a) DBusTree_ (Maybe Client)
-  | DBusRoot_ (Client -> a) (Tree_ DBusDependency_) (Maybe Client)
 
--- | The dependency tree with rules to merge results
+-- | The dependency tree with rule to merge results when needed
 data Tree d d_ p =
   forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
   | And1 (Tree d d_ p) (Tree_ d_)
@@ -240,10 +247,13 @@ data Tree d d_ p =
   | Only (d p)
 
 -- | A dependency tree without functions to merge results
-data Tree_ d =
+data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d
-  And_ (Tree_ d) (Tree_ d)
+
-  | Or_ (Tree_ d) (Tree_ d)
+-- | Shorthand tree types for lazy typers
-  | Only_ d
+type IOTree p = Tree IODependency IODependency_ p
+type DBusTree p = Tree IODependency DBusDependency_ p
+type IOTree_ = Tree_ IODependency_
+type DBusTree_ = Tree_ DBusDependency_
 
 -- | A dependency that only requires IO to evaluate
 data IODependency p = IORead String (IO (Result p))
@@ -260,6 +270,7 @@ data IODependency_ = IOSystem_ SystemDependency
   | forall a. IOSometimes_ (Sometimes a)
 
 data SystemDependency = Executable Bool FilePath
+  | FontFamily String
   | AccessiblePath FilePath Bool Bool
   | IOTest String (IO (Maybe String))
   | Systemd UnitType String
@@ -434,12 +445,13 @@ testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
   where
     msg = unwords [e, "executable", singleQuote bin, "not found"]
     e = if sys then "system" else "local"
-testSysDependency (Systemd t n) = do
+testSysDependency (FontFamily fam) = shellTest cmd msg
-  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
-  return $ case rc of
-    ExitSuccess -> Nothing
-    _           -> Just $ "systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"
   where
+    msg = unwords ["font family", singleQuote fam, "not found"]
+    cmd = fmtCmd "fc-list" ["-q", singleQuote fam]
+testSysDependency (Systemd t n) = shellTest cmd msg
+  where
+    msg = unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
     cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
 testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
   where
@@ -455,6 +467,13 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
         _                        -> Nothing
 
 
+shellTest :: String -> String -> IO (Maybe String)
+shellTest cmd msg = do
+  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
+  return $ case rc of
+    ExitSuccess -> Nothing
+    _           -> Just msg
+
 unitType :: UnitType -> String
 unitType SystemUnit = "system"
 unitType UserUnit   = "user"
@@ -560,8 +579,11 @@ sometimes1 = sometimes1_ Error
 always1 :: String -> String -> Root a -> a -> Always a
 always1 = always1_ Error
 
-sometimesIO :: String -> String -> Tree_ IODependency_ -> a -> Sometimes a
+sometimesIO_ :: String -> String -> IOTree_ -> a -> Sometimes a
-sometimesIO fn n t x = sometimes1 fn n $ IORoot_ x t
+sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
+
+sometimesIO :: String -> String -> IOTree p -> (p -> a) -> Sometimes a
+sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
 
 sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ())
 sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
@@ -569,7 +591,7 @@ sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
 sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath
   -> [String] -> Sometimes (m ())
 sometimesExeArgs fn n sys path args =
-  sometimesIO fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
+  sometimesIO_ fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
 
 sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_
   -> (Client -> a) -> Sometimes a
@@ -598,6 +620,9 @@ toAnd a b = And_ (Only_ a) (Only_ b)
 exe :: Bool -> String -> IODependency_
 exe b = IOSystem_ . Executable b
 
+fontFam :: String -> IODependency_
+fontFam = IOSystem_ . FontFamily
+
 sysExe :: String -> IODependency_
 sysExe = exe True
 
@@ -723,11 +748,11 @@ dataTree_ f_ = go
     go (Only_ d)  = uncurry jsonLeafUntested $ f_ d
 
 dataIODependency :: IODependency p -> DependencyData
-dataIODependency d = case d of
+dataIODependency d = first Q $ case d of
-  (IORead n _)      -> (Q "ioread", [("desc", JSON_Q $ Q n)])
+  (IORead n _)      -> ("ioread", [("desc", JSON_Q $ Q n)])
   -- TODO make this actually useful (I actually need to name my features)
-  (IOSometimes _ _) -> (Q "sometimes", [])
+  (IOSometimes _ _) -> ("sometimes", [])
-  (IOAlways _ _)    -> (Q "always", [])
+  (IOAlways _ _)    -> ("always", [])
 
 dataIODependency_ :: IODependency_ -> DependencyData
 dataIODependency_ d = case d of
@@ -735,18 +760,19 @@ dataIODependency_ d = case d of
   (IOSometimes_ _) -> (Q "sometimes", [])
 
 dataSysDependency :: SystemDependency -> DependencyData
-dataSysDependency d = do
+dataSysDependency d = first Q $
   case d of
-    (Executable sys path) -> (Q "executable", [ ("system", JSON_UQ $ jsonBool sys)
+    (Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys)
                                             , ("path", JSON_Q $ Q path)
                                             ])
-    (IOTest desc _) -> (Q "iotest", [("desc", JSON_Q $ Q desc)])
+    (IOTest desc _) -> ("iotest", [("desc", JSON_Q $ Q desc)])
-    (AccessiblePath p r w) -> (Q "path", [ ("path", JSON_Q $ Q p)
+    (FontFamily fam) -> ("font", [("family", JSON_Q $ Q fam)])
-                                         , ("readable", JSON_UQ $ jsonBool r)
+    (AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
-                                         , ("writable", JSON_UQ $ jsonBool w)
+                                       , ("readable", JSON_UQ $ jsonBool r)
-                                         ])
+                                       , ("writable", JSON_UQ $ jsonBool w)
-    (Systemd t n) -> (Q "systemd", [ ("unittype", JSON_Q $ Q $ unitType t)
+                                       ])
-                                   , ("unit", JSON_Q $ Q n)])
+    (Systemd t n) -> ("systemd", [ ("unittype", JSON_Q $ Q $ unitType t)
+                                 , ("unit", JSON_Q $ Q n)])
 
 dataDBusDependency :: DBusDependency_ -> DependencyData
 dataDBusDependency d =

lib/XMonad/Internal/Theme.hs

@@ -18,9 +18,12 @@ module XMonad.Internal.Theme
   , darken'
   , Slant(..)
   , Weight(..)
-  , ThemeFont(..)
+  , FontData(..)
-  , fmtFontXFT
+  , FontBuilder
-  , font
+  , buildFont
+  , defFontData
+  , defFont
+  , fontFeature
   , tabbedTheme
   , promptTheme
   ) where
@@ -30,8 +33,9 @@ import           Data.Colour
 import           Data.Colour.SRGB
 import           Data.List
 
-import qualified XMonad.Layout.Decoration as D
+import           XMonad.Internal.Dependency
-import qualified XMonad.Prompt            as P
+import qualified XMonad.Layout.Decoration   as D
+import qualified XMonad.Prompt              as P
 
 --------------------------------------------------------------------------------
 -- | Colors - vocabulary roughly based on GTK themes
@@ -96,24 +100,25 @@ data Weight = Light
     | Black
     deriving (Eq, Show)
 
-data ThemeFont = ThemeFont
+data FontData = FontData
-    { family    :: String
+    { weight    :: Maybe Weight
-    , weight    :: Maybe Weight
     , slant     :: Maybe Slant
     , size      :: Maybe Int
     , pixelsize :: Maybe Int
     , antialias :: Maybe Bool
     }
 
-fmtFontXFT :: ThemeFont -> String
+type FontBuilder = FontData -> String
-fmtFontXFT ThemeFont
+
-  { family = f
+buildFont :: Maybe String -> FontData -> String
-  , weight = w
+buildFont Nothing _ = "fixed"
-  , slant = l
+buildFont (Just fam) FontData { weight = w
-  , size = s
+                            , slant = l
-  , pixelsize = p
+                            , size = s
-  , antialias = a
+                            , pixelsize = p
-  } = intercalate ":" $ ["xft", f] ++ elems
+                            , antialias = a
+                            }
+  = intercalate ":" $ ["xft", fam] ++ elems
   where
     elems = [ k ++ "=" ++ v | (k, Just v) <- [ ("weight", showLower w)
                                              , ("slant", showLower l)
@@ -125,22 +130,34 @@ fmtFontXFT ThemeFont
     showLower :: Show a => Maybe a -> Maybe String
     showLower = fmap (fmap toLower . show)
 
-font :: ThemeFont
+fontFeature :: String -> String -> Always FontBuilder
-font = ThemeFont
+fontFeature n fam = always1 n sfn root def
-  { family = "DejaVu Sans"
+  where
-  , size = Just 10
+    sfn = "Font family for " ++ fam
+    root = IORoot_ (buildFont $ Just fam) $ Only_ $ fontFam fam
+    def = buildFont Nothing
+
+--------------------------------------------------------------------------------
+-- | Default font and data
+
+defFontData :: FontData
+defFontData = FontData
+  { size = Just 10
   , antialias = Just True
   , weight = Nothing
   , slant = Nothing
   , pixelsize = Nothing
   }
 
+defFont :: Always FontBuilder
+defFont = fontFeature "Default Font" "DejaVu Sans"
+
 --------------------------------------------------------------------------------
 -- | Complete themes
 
-tabbedTheme :: D.Theme
+tabbedTheme :: FontBuilder -> D.Theme
-tabbedTheme = D.def
+tabbedTheme fb = D.def
-  { D.fontName              = fmtFontXFT font { weight = Just Bold }
+  { D.fontName              = fb $ defFontData { weight = Just Bold }
 
   , D.activeTextColor       = fgColor
   , D.activeColor           = bgColor
@@ -162,11 +179,11 @@ tabbedTheme = D.def
   , D.decoHeight            = 20
   , D.windowTitleAddons     = []
   , D.windowTitleIcons      = []
-}
+  }
 
-promptTheme :: P.XPConfig
+promptTheme :: FontBuilder -> P.XPConfig
-promptTheme = P.def
+promptTheme fb = P.def
-  { P.font              = fmtFontXFT font { size = Just 12 }
+  { P.font              = fb $ defFontData { size = Just 12 }
   , P.bgColor           = bgColor
   , P.fgColor           = fgColor
   , P.fgHLight          = selectedFgColor