ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
bin/xmobar.hs
View File

@ -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", "<status><volume>%"
, "--"
-- 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 ["<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

9
bin/xmonad.hs
View File

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

2
lib/XMonad/Internal/Command/DMenu.hs
View File

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

2
lib/XMonad/Internal/Command/Desktop.hs
View File

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

6
lib/XMonad/Internal/Command/Power.hs
View File

@ -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 ()

8
lib/XMonad/Internal/Concurrent/ACPIEvent.hs
View File

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

42
lib/XMonad/Internal/Concurrent/VirtualBox.hs Normal file
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"

2
lib/XMonad/Internal/DBus/Removable.hs
View File

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

2
lib/XMonad/Internal/DBus/Screensaver.hs
View File

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

88
lib/XMonad/Internal/Dependency.hs
View File

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

66
lib/XMonad/Internal/Theme.hs
View File

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