ENH use better vbox search function; cache fonts
This commit is contained in:
parent
c292c2b9a8
commit
2704021150
122
bin/xmobar.hs
122
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", "<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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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}'"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
$ And12 (,) (fontTreeAlt defFontFamily) $ Only
|
||||
$ IOSometimes runScreenLock id
|
||||
fallback = Always_ $ FallbackAlone $ const skip
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,11 +33,6 @@ 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
|
||||
|
||||
|
|
@ -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 }
|
||||
|
|
|
|||
Loading…
Reference in New Issue