From 2704021150e69ca7818c4853ce6cc46a3ca83ec2 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Wed, 6 Jul 2022 18:54:10 -0400 Subject: [PATCH] ENH use better vbox search function; cache fonts --- bin/xmobar.hs | 122 +++++++++---------- bin/xmonad.hs | 9 +- lib/XMonad/Internal/Command/DMenu.hs | 2 +- lib/XMonad/Internal/Command/Desktop.hs | 2 +- lib/XMonad/Internal/Command/Power.hs | 6 +- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 8 +- lib/XMonad/Internal/Concurrent/VirtualBox.hs | 42 +++++++ lib/XMonad/Internal/DBus/Removable.hs | 2 +- lib/XMonad/Internal/DBus/Screensaver.hs | 2 +- lib/XMonad/Internal/Dependency.hs | 88 +++++++++++-- lib/XMonad/Internal/Theme.hs | 66 ++-------- 11 files changed, 210 insertions(+), 139 deletions(-) create mode 100644 lib/XMonad/Internal/Concurrent/VirtualBox.hs diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 117f294..1370621 100644 --- a/bin/xmobar.hs +++ b/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 - where - fam = "Symbols Nerd Font" - sfn = "Font family for " ++ singleQuote fam - root = IORoot id $ T.fontTree fam +iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font" -- | 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 - text = r False t + icon = r fontifyIcon $ c t $ d iconDependency + text = r fontifyAlt t -------------------------------------------------------------------------------- -- | command specifications @@ -286,17 +283,15 @@ wirelessCmd iface = CmdSpec ] 5 } -ethernetCmd :: Bool -> String -> CmdSpec -ethernetCmd icon iface = CmdSpec +ethernetCmd :: Fontifier -> String -> 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 icon = CmdSpec +batteryCmd :: Fontifier -> 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 "\xf1e6" "AC" - , "-i" , fontify "\xf1e6" "AC" + , "-o" , fontify' "\xf0e7" "BAT" + , "-O" , 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 icon = CmdSpec +vpnCmd :: Fontifier -> 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 icon = CmdSpec +btCmd :: Fontifier -> 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 icon = CmdSpec +alsaCmd :: Fontifier -> CmdSpec +alsaCmd fontify = CmdSpec { csAlias = "alsa:default:Master" , csRunnable = Run $ Alsa "default" "Master" [ "-t", "%" , "--" -- TODO just make this gray when muted - , "-O", fontify "\xf028" "+" - , "-o", fontify "\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 + fontify' i a = fontify IconSmall i $ "VOL" ++ a -blCmd :: Bool -> CmdSpec -blCmd icon = CmdSpec +blCmd :: Fontifier -> 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 icon = CmdSpec +ckCmd :: Fontifier -> 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 icon = CmdSpec +ssCmd :: Fontifier -> CmdSpec +ssCmd fontify = CmdSpec { csAlias = ssAlias - , csRunnable = Run - $ Screensaver (text, colors) + , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors) } - where - text = if icon then fontifyText IconSmall "\xf254" else "SS" -lockCmd :: Bool -> CmdSpec -lockCmd icon = CmdSpec +lockCmd :: Fontifier -> CmdSpec +lockCmd fontify = CmdSpec { csAlias = "locks" , csRunnable = Run $ Locks @@ -390,9 +376,9 @@ lockCmd icon = CmdSpec ] } where - numIcon = fontify "\xf8a5" "N" - capIcon = fontify "\xf657" "C" - fontify i t = if icon then fontifyText IconXLarge i else t + numIcon = fontify' "\xf8a5" "N" + capIcon = fontify' "\xf657" "C" + 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 ["", txt, ""] +type Fontifier = BarFont -> String -> String -> String + +fontifyAlt :: Fontifier +fontifyAlt _ _ alt = alt + +fontifyIcon :: Fontifier +fontifyIcon f i _ = fontifyText f i + -------------------------------------------------------------------------------- -- | various formatting things diff --git a/bin/xmonad.hs b/bin/xmonad.hs index bb081a3..d3b2a93 100644 --- a/bin/xmonad.hs +++ b/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 diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index cf95c45..cde4264 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/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}'" diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 1163403..05c8818 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/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 diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 86c8b15..02ab124 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/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 () diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index ff52cf9..1bccb3e 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/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 - $ IOSometimes runScreenLock id + withLock = IORoot (uncurry handleACPI) + $ And12 (,) (fontTreeAlt defFontFamily) $ Only + $ IOSometimes runScreenLock id fallback = Always_ $ FallbackAlone $ const skip diff --git a/lib/XMonad/Internal/Concurrent/VirtualBox.hs b/lib/XMonad/Internal/Concurrent/VirtualBox.hs new file mode 100644 index 0000000..2229325 --- /dev/null +++ b/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" diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index 85b3a0b..302d142 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/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 diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index c353891..00b37fb 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/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 diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 4303555..d1128e7 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/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 - IORead String (IO (Result p)) + -- a cachable IO action that yields a payload + 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 a b = And_ (Only_ a) (Only_ b) +toAnd_ :: d -> d -> Tree_ d +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 diff --git a/lib/XMonad/Internal/Theme.hs b/lib/XMonad/Internal/Theme.hs index b487f3c..24ca508 100644 --- a/lib/XMonad/Internal/Theme.hs +++ b/lib/XMonad/Internal/Theme.hs @@ -21,15 +21,10 @@ module XMonad.Internal.Theme , FontData(..) , FontBuilder , buildFont - , fontTree - , fontDependency - , fontDependency_ + , fallbackFont + , defFontFamily , 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 XMonad.Internal.Dependency -import XMonad.Internal.Process -import XMonad.Internal.Shell -import qualified XMonad.Layout.Decoration as D -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 @@ -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 -defFontDep = fontDependency "DejaVu Sans" +defFontFamily :: String +defFontFamily = "DejaVu Sans" -defFontTree :: IOTree FontBuilder -defFontTree = fontTree "DejaVu Sans" +-- defFontDep :: IODependency FontBuilder +-- 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 }