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'
|
( 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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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}'"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 =
|
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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 }
|
||||||
|
|
Loading…
Reference in New Issue