ENH use better vbox search function; cache fonts

This commit is contained in:
Nathan Dwarshuis 2022-07-06 18:54:10 -04:00
parent c292c2b9a8
commit 2704021150
11 changed files with 210 additions and 139 deletions

View File

@ -46,7 +46,6 @@ import XMonad.Internal.Process
( proc' ( proc'
, readCreateProcessWithExitCode' , readCreateProcessWithExitCode'
) )
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T import qualified XMonad.Internal.Theme as T
import Xmobar hiding import Xmobar hiding
( iconOffset ( iconOffset
@ -78,7 +77,7 @@ evalConfig db = do
-- | The text font family -- | The text font family
textFont :: Always T.FontBuilder 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 -- | Offset of the text in the bar
textFontOffset :: Int textFontOffset :: Int
@ -90,11 +89,7 @@ textFontData = T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
-- | The icon font family -- | The icon font family
iconFont :: Sometimes T.FontBuilder 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) -- | Offsets for the icons in the bar (relative to the text offset)
iconOffset :: BarFont -> Int iconOffset :: BarFont -> Int
@ -202,7 +197,7 @@ getBattery = iconIO_ "battery level indicator" root tree
tree = Only_ $ IOTest_ "Test if battery is present" hasBattery tree = Only_ $ IOTest_ "Test if battery is present" hasBattery
getVPN :: Maybe Client -> BarFeature 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 where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" vpnPresent 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 getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
getLock :: Always CmdSpec getLock :: Always CmdSpec
getLock = always1 "lock indicator" "icon indicator" root $ lockCmd False getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
where where
root = IORoot_ (lockCmd True) $ Only_ iconDependency root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | bar feature constructors -- | 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) xmobarDBus n dep cmd cl = iconDBus_ n root (Only_ dep)
where where
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl 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_ iconIO_ = iconSometimes' And_ Only_
iconDBus :: String -> (Bool -> DBusTree p -> Root CmdSpec) iconDBus :: String -> (Fontifier -> DBusTree p -> Root CmdSpec)
-> DBusTree p -> BarFeature -> DBusTree p -> BarFeature
iconDBus = iconSometimes' And1 $ Only_ . DBusIO iconDBus = iconSometimes' And1 $ Only_ . DBusIO
iconDBus_ :: String -> (Bool -> DBusTree_ -> Root CmdSpec) -> DBusTree_ iconDBus_ :: String -> (Fontifier -> DBusTree_ -> Root CmdSpec) -> DBusTree_
-> BarFeature -> BarFeature
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String 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 iconSometimes' c d n r t = Sometimes n
[ Subfeature icon "icon indicator" Error [ Subfeature icon "icon indicator" Error
, Subfeature text "text indicator" Error , Subfeature text "text indicator" Error
] ]
where 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 -- | command specifications
@ -286,17 +283,15 @@ wirelessCmd iface = CmdSpec
] 5 ] 5
} }
ethernetCmd :: Bool -> String -> CmdSpec ethernetCmd :: Fontifier -> String -> CmdSpec
ethernetCmd icon iface = CmdSpec ethernetCmd fontify iface = CmdSpec
{ csAlias = iface { csAlias = iface
, csRunnable = Run , 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" { csAlias = "battery"
, csRunnable = Run , csRunnable = Run
$ Battery $ Battery
@ -308,75 +303,66 @@ batteryCmd icon = CmdSpec
, "--high", T.fgColor , "--high", T.fgColor
, "--" , "--"
, "-P" , "-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 ] 50
} }
where 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 { 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 { csAlias = btAlias
, csRunnable = Run , csRunnable = Run
$ Bluetooth (fontify "\xf5b0" "+", fontify "\xf5ae" "-") colors $ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
} }
where 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" { csAlias = "alsa:default:Master"
, csRunnable = Run , csRunnable = Run
$ Alsa "default" "Master" $ Alsa "default" "Master"
[ "-t", "<status><volume>%" [ "-t", "<status><volume>%"
, "--" , "--"
-- TODO just make this gray when muted -- 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
, "-C", T.fgColor , "-C", T.fgColor
] ]
} }
where 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 { 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 { 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 { 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" { csAlias = "locks"
, csRunnable = Run , csRunnable = Run
$ Locks $ Locks
@ -390,9 +376,9 @@ lockCmd icon = CmdSpec
] ]
} }
where 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 disabledColor = xmobarFGColor T.backdropFgColor
dateCmd :: CmdSpec dateCmd :: CmdSpec
@ -425,7 +411,7 @@ sysfsNet = "/sys/class/net"
readInterface :: String -> (String -> Bool) -> IODependency String readInterface :: String -> (String -> Bool) -> IODependency String
readInterface n f = IORead n go readInterface n f = IORead n go
where where
go = do go = io $ do
ns <- filter f <$> listInterfaces ns <- filter f <$> listInterfaces
case ns of case ns of
[] -> return $ Left ["no interfaces found"] [] -> return $ Left ["no interfaces found"]
@ -483,6 +469,14 @@ iconDependency = IOSometimes_ iconFont
fontifyText :: BarFont -> String -> String fontifyText :: BarFont -> String -> String
fontifyText fnt txt = concat ["<fn=", show $ 1 + fromEnum fnt, ">", txt, "</fn>"] 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 -- | various formatting things

View File

@ -100,6 +100,13 @@ data FeatureSet = FeatureSet
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) , 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
features = FeatureSet features = FeatureSet
{ fsKeys = externalBindings { fsKeys = externalBindings
@ -108,7 +115,7 @@ features = FeatureSet
, fsRemovableMon = runRemovableMon , fsRemovableMon = runRemovableMon
, fsACPIHandler = runHandleACPI , fsACPIHandler = runHandleACPI
, fsDynWorkspaces = allDWs' , fsDynWorkspaces = allDWs'
, fsTabbedTheme = T.tabbedFeature , fsTabbedTheme = tabbedFeature
, fsShowKeys = runShowKeys , fsShowKeys = runShowKeys
, fsDaemons = [ runNetAppDaemon , fsDaemons = [ runNetAppDaemon
, runFlameshotDaemon , runFlameshotDaemon

View File

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

View File

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

View File

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

View File

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

View File

@ -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"

View File

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

View File

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

View File

@ -59,6 +59,11 @@ module XMonad.Internal.Dependency
, executeAlways , executeAlways
, evalAlways , evalAlways
, evalSometimes , evalSometimes
, fontTreeAlt
, fontTree
, fontTree_
, fontAlways
, fontSometimes
-- lifting -- lifting
, ioSometimes , ioSometimes
@ -80,7 +85,8 @@ module XMonad.Internal.Dependency
, sysdSystem , sysdSystem
, sysdUser , sysdUser
, listToAnds , listToAnds
, toAnd , toAnd_
, toFallback
, pathR , pathR
, pathRW , pathRW
, pathW , pathW
@ -117,6 +123,7 @@ import XMonad.Core (X, io)
import XMonad.Internal.IO import XMonad.Internal.IO
import XMonad.Internal.Process import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
import XMonad.Internal.Theme
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature Evaluation -- | Feature Evaluation
@ -274,8 +281,8 @@ type DBusTree_ = Tree_ DBusDependency_
-- | A dependency that only requires IO to evaluate (with payload) -- | A dependency that only requires IO to evaluate (with payload)
data IODependency p = 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 -- always yields a payload
| IOConst p | IOConst p
-- an always that yields a payload -- 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 :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p)
cIO_ :: H.HashMap IODependency_ Result_ cIO_ :: H.HashMap IODependency_ Result_
, cDBus_ :: H.HashMap DBusDependency_ Result_ , cDBus_ :: H.HashMap DBusDependency_ Result_
, cFont :: H.HashMap String (Result FontBuilder)
} }
-- class Memoizable a -- class Memoizable a
-- cache :: a -> -- cache :: a ->
emptyCache :: Cache emptyCache :: Cache
emptyCache = Cache H.empty H.empty emptyCache = Cache H.empty H.empty H.empty
memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_ memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_
memoizeIO_ f d = do memoizeIO_ f d = do
@ -416,6 +424,17 @@ memoizeDBus_ f d = do
modify (\s -> s { cDBus_ = H.insert d r (cDBus_ s) }) modify (\s -> s { cDBus_ = H.insert d r (cDBus_ s) })
return r 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 -- | Testing pipeline
@ -511,7 +530,7 @@ testTree test_ test = go
liftRight = either (return . Left) liftRight = either (return . Left)
testIODependency :: IODependency p -> FIO (Result p) testIODependency :: IODependency p -> FIO (Result p)
testIODependency (IORead _ t) = io t testIODependency (IORead _ t) = t
testIODependency (IOConst c) = return $ Right $ PostPass c [] testIODependency (IOConst c) = return $ Right $ PostPass c []
-- TODO this is a bit odd because this is a dependency that will always -- 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 -- 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" (_, Just False) -> Just "file not writable"
_ -> Nothing _ -> Nothing
shellTest :: String -> String -> IO (Maybe String) shellTest :: String -> String -> IO (Maybe String)
shellTest cmd msg = do shellTest cmd msg = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) "" (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
@ -579,6 +597,57 @@ unitType :: UnitType -> String
unitType SystemUnit = "system" unitType SystemUnit = "system"
unitType UserUnit = "user" 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 -- | DBus Dependency Testing
@ -715,8 +784,11 @@ sometimesEndpoint fn name busname path iface mem client =
listToAnds :: d -> [d] -> Tree_ d listToAnds :: d -> [d] -> Tree_ d
listToAnds i = foldr (And_ . Only_) (Only_ i) 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 :: Result p -> Result_
voidResult (Left es) = Left es voidResult (Left es) = Left es

View File

@ -21,15 +21,10 @@ module XMonad.Internal.Theme
, FontData(..) , FontData(..)
, FontBuilder , FontBuilder
, buildFont , buildFont
, fontTree , fallbackFont
, fontDependency , defFontFamily
, fontDependency_
, defFontData , defFontData
, defFontDep
, defFontTree
, fontFeature
, tabbedTheme , tabbedTheme
, tabbedFeature
, promptTheme , promptTheme
) where ) where
@ -38,13 +33,8 @@ import Data.Colour
import Data.Colour.SRGB import Data.Colour.SRGB
import Data.List 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 -- | Colors - vocabulary roughly based on GTK themes
@ -142,36 +132,6 @@ buildFont (Just fam) FontData { weight = w
fallbackFont :: FontBuilder fallbackFont :: FontBuilder
fallbackFont = buildFont Nothing 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 -- | Default font and data
@ -184,11 +144,14 @@ defFontData = FontData
, pixelsize = Nothing , 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 -- | Complete themes
@ -219,13 +182,6 @@ tabbedTheme fb = D.def
, D.windowTitleIcons = [] , 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 :: FontBuilder -> P.XPConfig
promptTheme fb = P.def promptTheme fb = P.def
{ P.font = fb $ defFontData { size = Just 12 } { P.font = fb $ defFontData { size = Just 12 }