ENH use better vbox search function; cache fonts

bin/xmobar.hs

@@ -46,7 +46,6 @@ import           XMonad.Internal.Process
     ( proc'
     , readCreateProcessWithExitCode'
     )
-import           XMonad.Internal.Shell
 import qualified XMonad.Internal.Theme                          as T
 import           Xmobar                                         hiding
     ( iconOffset
@@ -78,7 +77,7 @@ evalConfig db = do
 
 -- | The text font family
 textFont :: Always T.FontBuilder
-textFont = T.fontFeature "XMobar Text Font" "DejaVu Sans Mono"
+textFont = fontAlways "XMobar Text Font" "DejaVu Sans Mono"
 
 -- | Offset of the text in the bar
 textFontOffset :: Int
@@ -90,11 +89,7 @@ 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
+iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
-  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
@@ -202,7 +197,7 @@ getBattery = iconIO_ "battery level indicator" root tree
     tree = Only_ $ IOTest_ "Test if battery is present" hasBattery
 
 getVPN :: Maybe Client -> BarFeature
-getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd vpnDep test
+getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd_ vpnDep test
   where
     root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
     test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" vpnPresent
@@ -225,38 +220,40 @@ getSs :: Maybe Client -> BarFeature
 getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
 
 getLock :: Always CmdSpec
-getLock = always1 "lock indicator" "icon indicator" root $ lockCmd False
+getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
   where
-    root = IORoot_ (lockCmd True) $ Only_ iconDependency
+    root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
 
 --------------------------------------------------------------------------------
 -- | bar feature constructors
 
-xmobarDBus :: String -> DBusDependency_ -> (Bool -> CmdSpec) -> Maybe Client -> BarFeature
+xmobarDBus :: String -> DBusDependency_ -> (Fontifier -> 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_ :: String -> (Fontifier -> IOTree_ -> Root CmdSpec) -> IOTree_
+  -> BarFeature
 iconIO_ = iconSometimes' And_ Only_
 
-iconDBus :: String -> (Bool -> DBusTree p -> Root CmdSpec)
+iconDBus :: String -> (Fontifier -> DBusTree p -> Root CmdSpec)
   -> DBusTree p -> BarFeature
 iconDBus = iconSometimes' And1 $ Only_ . DBusIO
 
-iconDBus_ :: String -> (Bool -> DBusTree_ -> Root CmdSpec) -> DBusTree_
+iconDBus_ :: String -> (Fontifier -> DBusTree_ -> Root CmdSpec) -> DBusTree_
   -> BarFeature
 iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
 
 iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String
-  -> (Bool -> t -> Root CmdSpec) -> t -> BarFeature
+  -> (Fontifier -> 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
+    icon = r fontifyIcon $ c t $ d iconDependency
-    text = r False t
+    text = r fontifyAlt t
 
 --------------------------------------------------------------------------------
 -- | command specifications
@@ -286,17 +283,15 @@ wirelessCmd iface = CmdSpec
     ] 5
   }
 
-ethernetCmd :: Bool -> String -> CmdSpec
+ethernetCmd :: Fontifier -> String -> CmdSpec
-ethernetCmd icon iface = CmdSpec
+ethernetCmd fontify iface = CmdSpec
   { csAlias = iface
   , csRunnable = Run
-    $ Device (iface, text, colors)
+    $ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
   }
-  where
-    text = if icon then fontifyText IconMedium "\xf0e8" else "ETH"
 
-batteryCmd :: Bool -> CmdSpec
+batteryCmd :: Fontifier -> CmdSpec
-batteryCmd icon = CmdSpec
+batteryCmd fontify = CmdSpec
   { csAlias = "battery"
   , csRunnable = Run
     $ Battery
@@ -308,75 +303,66 @@ batteryCmd icon = CmdSpec
     , "--high", T.fgColor
     , "--"
     , "-P"
-    , "-o" , fontify "\xf0e7" "BAT"
+    , "-o" , fontify' "\xf0e7" "BAT"
-    , "-O" , fontify "\xf1e6" "AC"
+    , "-O" , fontify' "\xf1e6" "AC"
-    , "-i" , fontify "\xf1e6" "AC"
+    , "-i" , fontify' "\xf1e6" "AC"
     ] 50
   }
   where
-    fontify i t = if icon then fontifyText IconSmall i else t ++ ": "
+    fontify' = fontify IconSmall
 
-vpnCmd :: Bool -> CmdSpec
+vpnCmd :: Fontifier -> CmdSpec
-vpnCmd icon = CmdSpec
+vpnCmd fontify = CmdSpec
   { csAlias = vpnAlias
-  , csRunnable = Run $ VPN (text, colors)
+  , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
   }
-  where
-    text = if icon then fontifyText IconMedium "\xf023" else "VPN"
 
-btCmd :: Bool -> CmdSpec
+btCmd :: Fontifier -> CmdSpec
-btCmd icon = CmdSpec
+btCmd fontify = CmdSpec
   { csAlias = btAlias
   , csRunnable = Run
-    $ Bluetooth (fontify "\xf5b0" "+", fontify "\xf5ae" "-") colors
+    $ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
   }
   where
-    fontify i t = if icon then fontifyText IconLarge i else "BT" ++ t
+    fontify' i a = fontify IconLarge i $ "BT" ++ a
 
-alsaCmd :: Bool -> CmdSpec
+alsaCmd :: Fontifier -> CmdSpec
-alsaCmd icon = CmdSpec
+alsaCmd fontify = CmdSpec
   { csAlias = "alsa:default:Master"
   , csRunnable = Run
     $ Alsa "default" "Master"
     [ "-t", "<status><volume>%"
     , "--"
     -- TODO just make this gray when muted
-    , "-O", fontify "\xf028" "+"
+    , "-O", fontify' "\xf028" "+"
-    , "-o", fontify "\xf026" "-" ++ " "
+    , "-o", fontify' "\xf026" "-" ++ " "
     , "-c", T.fgColor
     , "-C", T.fgColor
     ]
   }
   where
-    fontify i t = if icon then fontifyText IconSmall i else "VOL" ++ t
+    fontify' i a = fontify IconSmall i $ "VOL" ++ a
 
-blCmd :: Bool -> CmdSpec
+blCmd :: Fontifier -> CmdSpec
-blCmd icon = CmdSpec
+blCmd fontify = CmdSpec
   { csAlias = blAlias
-  , csRunnable = Run $ IntelBacklight text
+  , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
   }
-  where
-    text = if icon then fontifyText IconSmall "\xf185" else "BL: "
 
-ckCmd :: Bool -> CmdSpec
+ckCmd :: Fontifier -> CmdSpec
-ckCmd icon = CmdSpec
+ckCmd fontify = CmdSpec
   { csAlias = ckAlias
-  , csRunnable = Run $ ClevoKeyboard text
+  , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
   }
-  where
-    text = if icon then fontifyText IconSmall "\xf40b" else "KB: "
 
-ssCmd :: Bool -> CmdSpec
+ssCmd :: Fontifier -> CmdSpec
-ssCmd icon = CmdSpec
+ssCmd fontify = CmdSpec
   { csAlias = ssAlias
-  , csRunnable = Run
+  , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
-    $ Screensaver (text, colors)
   }
-  where
-    text = if icon then fontifyText IconSmall "\xf254" else "SS"
 
-lockCmd :: Bool -> CmdSpec
+lockCmd :: Fontifier -> CmdSpec
-lockCmd icon = CmdSpec
+lockCmd fontify = CmdSpec
   { csAlias = "locks"
   , csRunnable = Run
     $ Locks
@@ -390,9 +376,9 @@ lockCmd icon = CmdSpec
     ]
   }
   where
-    numIcon = fontify "\xf8a5" "N"
+    numIcon = fontify' "\xf8a5" "N"
-    capIcon = fontify "\xf657" "C"
+    capIcon = fontify' "\xf657" "C"
-    fontify i t = if icon then fontifyText IconXLarge i else t
+    fontify' = fontify IconXLarge
     disabledColor = xmobarFGColor T.backdropFgColor
 
 dateCmd :: CmdSpec
@@ -425,7 +411,7 @@ sysfsNet = "/sys/class/net"
 readInterface :: String -> (String -> Bool) -> IODependency String
 readInterface n f = IORead n go
   where
-    go = do
+    go = io $ do
       ns <- filter f <$> listInterfaces
       case ns of
         [] -> return $ Left ["no interfaces found"]
@@ -483,6 +469,14 @@ iconDependency = IOSometimes_ iconFont
 fontifyText :: BarFont -> String -> String
 fontifyText fnt txt = concat ["<fn=", show $ 1 + fromEnum fnt, ">", txt, "</fn>"]
 
+type Fontifier = BarFont -> String -> String -> String
+
+fontifyAlt :: Fontifier
+fontifyAlt _ _ alt = alt
+
+fontifyIcon :: Fontifier
+fontifyIcon f i _ = fontifyText f i
+
 --------------------------------------------------------------------------------
 -- | various formatting things
 

bin/xmonad.hs

@@ -100,6 +100,13 @@ data FeatureSet = FeatureSet
   , fsShowKeys      :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
   }
 
+tabbedFeature :: Always Theme
+tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
+  where
+    sf = Subfeature niceTheme "theme with nice font" Error
+    niceTheme = IORoot T.tabbedTheme $ fontTree T.defFontFamily
+    fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
+
 features :: FeatureSet
 features = FeatureSet
   { fsKeys = externalBindings
@@ -108,7 +115,7 @@ features = FeatureSet
   , fsRemovableMon = runRemovableMon
   , fsACPIHandler = runHandleACPI
   , fsDynWorkspaces = allDWs'
-  , fsTabbedTheme = T.tabbedFeature
+  , fsTabbedTheme = tabbedFeature
   , fsShowKeys = runShowKeys
   , fsDaemons = [ runNetAppDaemon
                 , runFlameshotDaemon

lib/XMonad/Internal/Command/DMenu.hs

@@ -143,7 +143,7 @@ runClipMenu :: SometimesX
 runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
   where
     act = spawnCmd myDmenuCmd args
-    tree = toAnd (sysExe myDmenuCmd) $ IOSometimes_ runClipManager
+    tree = toAnd_ (sysExe myDmenuCmd) $ IOSometimes_ runClipManager
     args = [ "-modi", "\"clipboard:greenclip print\""
            , "-show", "clipboard"
            , "-run-command", "'{cmd}'"

lib/XMonad/Internal/Command/Desktop.hs

@@ -118,7 +118,7 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
 runCalc :: SometimesX
 runCalc = sometimesIO_ "calculator" "R" deps act
   where
-    deps = toAnd (sysExe myTerm) (sysExe "R")
+    deps = toAnd_ (sysExe myTerm) (sysExe "R")
     act = spawnCmd myTerm ["-e", "R"]
 
 runBrowser :: SometimesX

lib/XMonad/Internal/Command/Power.hs

@@ -96,7 +96,7 @@ quitPrompt :: T.FontBuilder -> X ()
 quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
 
 sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
-sometimesPrompt n = sometimesIO n (n ++ " command") T.defFontTree
+sometimesPrompt n = sometimesIO n (n ++ " command") $ fontTreeAlt T.defFontFamily
 
 -- TODO doesn't this need to also lock the screen?
 runSuspendPrompt :: SometimesX
@@ -140,7 +140,7 @@ runOptimusPrompt = Sometimes "graphics switcher" [s]
   where
     s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error }
     r = IORoot runOptimusPrompt' t
-    t = And1 T.defFontTree
+    t = And1 (fontTreeAlt T.defFontFamily)
       $ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload)
 
 --------------------------------------------------------------------------------
@@ -174,7 +174,7 @@ runPowerPrompt = Sometimes "power prompt" [sf]
   where
     sf = Subfeature withLock "prompt with lock" Error
     withLock = IORoot (uncurry powerPrompt) tree
-    tree = And12 (,) lockTree T.defFontTree
+    tree = And12 (,) lockTree (fontTreeAlt T.defFontFamily)
     lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
 
 powerPrompt :: X () -> T.FontBuilder -> X ()

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -18,7 +18,6 @@ import           Data.Connection
 
 import           Text.Read                                (readMaybe)
 
--- import           System.Directory                         (doesPathExist)
 import           System.IO.Streams                        as S (read)
 import           System.IO.Streams.UnixSocket
 
@@ -29,7 +28,7 @@ import           XMonad.Internal.Dependency
 import           XMonad.Internal.Shell
 import           XMonad.Internal.Theme
     ( FontBuilder
-    , defFontTree
+    , defFontFamily
     )
 
 --------------------------------------------------------------------------------
@@ -123,6 +122,7 @@ runHandleACPI :: Always (String -> X ())
 runHandleACPI = Always "ACPI event handler" $ Option sf fallback
   where
     sf = Subfeature withLock "acpid prompt" Error
-    withLock = IORoot (uncurry handleACPI) $ And12 (,) defFontTree $ Only
+    withLock = IORoot (uncurry handleACPI)
-               $ IOSometimes runScreenLock id
+      $ And12 (,) (fontTreeAlt defFontFamily) $ Only
+      $ IOSometimes runScreenLock id
     fallback = Always_ $ FallbackAlone $ const skip

lib/XMonad/Internal/Concurrent/VirtualBox.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- | VirtualBox-specific functions
+
+module XMonad.Internal.Concurrent.VirtualBox
+  ( vmExists
+  ) where
+
+import           Control.Exception
+
+import           Text.XML.Light
+
+import           System.Directory
+
+import           XMonad.Internal.Shell
+
+vmExists :: String -> IO (Maybe String)
+vmExists vm = do
+  d <- vmDirectory
+  either (return . Just) findVMDir d
+  where
+    findVMDir vd = do
+      vs <- listDirectory vd
+      return $ if vm `elem` vs then Nothing
+        else Just $ "could not find " ++ singleQuote vm
+
+vmDirectory :: IO (Either String String)
+vmDirectory = do
+  p <- vmConfig
+  (s :: Either IOException String) <- try $ readFile p
+  return $ case s of
+    (Left _) -> Left "could not read VirtualBox config file"
+    (Right x) -> maybe (Left "Could not parse VirtualBox config file") Right
+                 $ findDir =<< parseXMLDoc x
+  where
+    findDir e = findAttr (unqual "defaultMachineFolder")
+      =<< findChild (qual e "SystemProperties")
+      =<< findChild (qual e "Global") e
+    qual e n = (elName e) { qName = n }
+
+vmConfig :: IO FilePath
+vmConfig = getXdgDirectory XdgConfig "VirtualBox/VirtualBox.xml"

lib/XMonad/Internal/DBus/Removable.hs

@@ -85,4 +85,4 @@ runRemovableMon :: Maybe Client -> SometimesIO
 runRemovableMon cl =
   sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
   where
-    deps = toAnd addedDep removedDep
+    deps = toAnd_ addedDep removedDep

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -96,7 +96,7 @@ bodyGetCurrentState _   = Nothing
 
 exportScreensaver :: Maybe Client -> SometimesIO
 exportScreensaver client =
-  sometimesDBus client "screensaver toggle" "xset" (toAnd bus ssx) cmd
+  sometimesDBus client "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
   where
     cmd cl = export cl ssPath defaultInterface
       { interfaceName = interface

lib/XMonad/Internal/Dependency.hs

@@ -59,6 +59,11 @@ module XMonad.Internal.Dependency
   , executeAlways
   , evalAlways
   , evalSometimes
+  , fontTreeAlt
+  , fontTree
+  , fontTree_
+  , fontAlways
+  , fontSometimes
 
   -- lifting
   , ioSometimes
@@ -80,7 +85,8 @@ module XMonad.Internal.Dependency
   , sysdSystem
   , sysdUser
   , listToAnds
-  , toAnd
+  , toAnd_
+  , toFallback
   , pathR
   , pathRW
   , pathW
@@ -117,6 +123,7 @@ import           XMonad.Core             (X, io)
 import           XMonad.Internal.IO
 import           XMonad.Internal.Process
 import           XMonad.Internal.Shell
+import           XMonad.Internal.Theme
 
 --------------------------------------------------------------------------------
 -- | Feature Evaluation
@@ -274,8 +281,8 @@ type DBusTree_ = Tree_ DBusDependency_
 
 -- | A dependency that only requires IO to evaluate (with payload)
 data IODependency p =
-  -- an IO action that yields a payload
+  -- a cachable IO action that yields a payload
-  IORead String (IO (Result p))
+  IORead String (FIO (Result p))
   -- always yields a payload
   | IOConst p
   -- an always that yields a payload
@@ -386,13 +393,14 @@ data Cache = Cache
   { --cIO    :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p)
     cIO_   :: H.HashMap IODependency_ Result_
   , cDBus_ :: H.HashMap DBusDependency_ Result_
+  , cFont  :: H.HashMap String (Result FontBuilder)
   }
 
 -- class Memoizable a
   -- cache :: a ->
 
 emptyCache :: Cache
-emptyCache = Cache H.empty H.empty
+emptyCache = Cache H.empty H.empty H.empty
 
 memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_
 memoizeIO_ f d = do
@@ -416,6 +424,17 @@ memoizeDBus_ f d = do
       modify (\s -> s { cDBus_ = H.insert d r (cDBus_ s) })
       return r
 
+memoizeFont :: (String -> IO (Result FontBuilder)) -> String -> FIO (Result FontBuilder)
+memoizeFont f d = do
+  m <- gets cFont
+  case H.lookup d m of
+    (Just r) -> return r
+    Nothing  -> do
+      -- io $ putStrLn $ "not using cache for " ++ show d
+      r <- io $ f d
+      modify (\s -> s { cFont = H.insert d r (cFont s) })
+      return r
+
 --------------------------------------------------------------------------------
 -- | Testing pipeline
 
@@ -511,7 +530,7 @@ testTree test_ test = go
     liftRight = either (return . Left)
 
 testIODependency :: IODependency p -> FIO (Result p)
-testIODependency (IORead _ t)      = io t
+testIODependency (IORead _ t)      = t
 testIODependency (IOConst c)       = return $ Right $ PostPass c []
 -- TODO this is a bit odd because this is a dependency that will always
 -- succeed, which kinda makes this pointless. The only reason I would want this
@@ -567,7 +586,6 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
         (_, Just False)          -> Just "file not writable"
         _                        -> Nothing
 
-
 shellTest :: String -> String -> IO (Maybe String)
 shellTest cmd msg = do
   (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
@@ -579,6 +597,57 @@ unitType :: UnitType -> String
 unitType SystemUnit = "system"
 unitType UserUnit   = "user"
 
+--------------------------------------------------------------------------------
+-- | IO testers
+--
+-- Make a special case for these since we end up testing the font alot, and it
+-- would be nice if I can cache them.
+
+fontAlways :: String -> String -> Always FontBuilder
+fontAlways n fam = always1 n (fontFeatureName fam) root fallbackFont
+  where
+    root = IORoot id $ fontTree fam
+
+fontSometimes :: String -> String -> Sometimes FontBuilder
+fontSometimes n fam = sometimes1 n (fontFeatureName fam) root
+  where
+    root = IORoot id $ fontTree fam
+
+fontFeatureName :: String -> String
+fontFeatureName n = unwords ["Font family for", singleQuote n]
+
+fontTreeAlt :: String -> Tree IODependency d_ FontBuilder
+fontTreeAlt fam = Or (fontTree fam) $ Only $ IOConst fallbackFont
+
+fontTree :: String -> Tree IODependency d_ FontBuilder
+fontTree = Only . fontDependency
+
+fontTree_ :: String -> IOTree_
+fontTree_ = Only_ . fontDependency_
+
+fontDependency :: String -> IODependency FontBuilder
+fontDependency fam = IORead (fontTestName fam) $ testFont fam
+
+fontDependency_ :: String -> IODependency_
+fontDependency_ fam = IOTest_ (fontTestName fam) $ voidRead <$> testFont' fam
+
+fontTestName :: String -> String
+fontTestName fam = unwords ["test if font", singleQuote fam, "exists"]
+
+testFont :: String -> FIO (Result FontBuilder)
+testFont = memoizeFont testFont'
+
+testFont' :: String -> IO (Result FontBuilder)
+testFont' fam = do
+  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
+  return $ case rc of
+    ExitSuccess -> Right $ PostPass (buildFont $ Just fam) []
+    _           -> Left [msg]
+  where
+    msg = unwords ["font family", qFam, "not found"]
+    cmd = fmtCmd "fc-list" ["-q", qFam]
+    qFam = singleQuote fam
+
 --------------------------------------------------------------------------------
 -- | DBus Dependency Testing
 
@@ -715,8 +784,11 @@ sometimesEndpoint fn name busname path iface mem client =
 listToAnds :: d -> [d] -> Tree_ d
 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)
+
+toFallback :: IODependency p -> p -> Tree IODependency d_ p
+toFallback a = Or (Only a) . Only . IOConst
 
 voidResult :: Result p -> Result_
 voidResult (Left es)               = Left es

lib/XMonad/Internal/Theme.hs

@@ -21,15 +21,10 @@ module XMonad.Internal.Theme
   , FontData(..)
   , FontBuilder
   , buildFont
-  , fontTree
+  , fallbackFont
-  , fontDependency
+  , defFontFamily
-  , fontDependency_
   , defFontData
-  , defFontDep
-  , defFontTree
-  , fontFeature
   , tabbedTheme
-  , tabbedFeature
   , promptTheme
   ) where
 
@@ -38,13 +33,8 @@ import           Data.Colour
 import           Data.Colour.SRGB
 import           Data.List
 
-import           System.Exit
+import qualified XMonad.Layout.Decoration as D
-
+import qualified XMonad.Prompt            as P
-import           XMonad.Internal.Dependency
-import           XMonad.Internal.Process
-import           XMonad.Internal.Shell
-import qualified XMonad.Layout.Decoration   as D
-import qualified XMonad.Prompt              as P
 
 --------------------------------------------------------------------------------
 -- | Colors - vocabulary roughly based on GTK themes
@@ -142,36 +132,6 @@ buildFont (Just fam) FontData { weight = w
 fallbackFont :: FontBuilder
 fallbackFont = buildFont Nothing
 
-testFont :: String -> IO (Result FontBuilder)
-testFont fam = do
-  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
-  return $ case rc of
-    ExitSuccess -> Right $ PostPass (buildFont $ Just fam) []
-    _           -> Left [msg]
-  where
-    msg = unwords ["font family", qFam, "not found"]
-    cmd = fmtCmd "fc-list" ["-q", qFam]
-    qFam = singleQuote fam
-
-fontDependency :: String -> IODependency FontBuilder
-fontDependency fam =
-  IORead (unwords ["test if font", singleQuote fam, "exists"]) $ testFont fam
-
-fontDependency_ :: String -> IODependency_
-fontDependency_ fam = IOTest_ 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)
-
-fontFeature :: String -> String -> Always FontBuilder
-fontFeature n fam = always1 n sfn root def
-  where
-    sfn = "Font family for " ++ fam
-    root = IORoot id $ fontTree fam
-    def = buildFont Nothing
-
 --------------------------------------------------------------------------------
 -- | Default font and data
 
@@ -184,11 +144,14 @@ defFontData = FontData
   , pixelsize = Nothing
   }
 
-defFontDep :: IODependency FontBuilder
+defFontFamily :: String
-defFontDep = fontDependency "DejaVu Sans"
+defFontFamily = "DejaVu Sans"
 
-defFontTree :: IOTree FontBuilder
+-- defFontDep :: IODependency FontBuilder
-defFontTree = fontTree "DejaVu Sans"
+-- defFontDep = fontDependency "DejaVu Sans"
+
+-- defFontTree :: IOTree FontBuilder
+-- defFontTree = fontTree "DejaVu Sans"
 
 --------------------------------------------------------------------------------
 -- | Complete themes
@@ -219,13 +182,6 @@ tabbedTheme fb = D.def
   , D.windowTitleIcons      = []
   }
 
-tabbedFeature :: Always D.Theme
-tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
-  where
-    sf = Subfeature niceTheme "theme with nice font" Error
-    niceTheme = IORoot tabbedTheme $ Only defFontDep
-    fallback = Always_ $ FallbackAlone $ tabbedTheme fallbackFont
-
 promptTheme :: FontBuilder -> P.XPConfig
 promptTheme fb = P.def
   { P.font              = fb $ defFontData { size = Just 12 }