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

ENH use font features

This commit is contained in:
Nathan Dwarshuis 2022-07-02 17:09:21 -04:00
parent 43d5c446bb
commit a796cedcf6
9 changed files with 258 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
bin/xmobar.hs
View File

@ -52,20 +52,20 @@ main :: IO ()
main = do main = do
sysClient <- getDBusClient True sysClient <- getDBusClient True
sesClient <- getDBusClient False sesClient <- getDBusClient False
ff <- evalFonts
cs <- getAllCommands =<< rightPlugins sysClient sesClient cs <- getAllCommands =<< rightPlugins sysClient sesClient
d <- cfgDir <$> getDirectories d <- cfgDir <$> getDirectories
-- this is needed to see any printed messages -- this is needed to see any printed messages
hFlush stdout hFlush stdout
mapM_ (maybe skip disconnect) [sysClient, sesClient] mapM_ (maybe skip disconnect) [sysClient, sesClient]
xmobar $ config cs d xmobar $ config ff cs d
config :: BarRegions -> String -> Config config :: (BarFont -> BarMetaFont) -> BarRegions -> String -> Config
config br confDir = defaultConfig config ff br confDir = defaultConfig
-- TODO head makes me feel icky { font = fontString ff firstFont
{ font = head allFontStrings , additionalFonts = fontString ff <$> restFonts
, additionalFonts = drop 1 allFontStrings , textOffset = fontOffset ff firstFont
, textOffset = head allFontOffsets , textOffsets = fontOffset ff <$> restFonts
, textOffsets = drop 1 allFontOffsets
, bgColor = T.bgColor , bgColor = T.bgColor
, fgColor = T.fgColor , fgColor = T.fgColor
, position = BottomSize C 100 24 , position = BottomSize C 100 24
@ -255,14 +255,14 @@ readInterface n f = IORead n go
return $ Right $ PostPass x $ fmap ("ignoring extra interface: "++) xs return $ Right $ PostPass x $ fmap ("ignoring extra interface: "++) xs
vpnPresent :: IO (Maybe String) vpnPresent :: IO (Maybe String)
vpnPresent = do vpnPresent = go <$> tryIOError (readProcessWithExitCode "nmcli" args "")
res <- tryIOError $ readProcessWithExitCode "nmcli" args ""
-- TODO provide some error messages
return $ case res of
(Right (ExitSuccess, out, _)) -> if "vpn" `elem` lines out then Nothing else Just "vpn not found"
_ -> Just "puke"
where where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
go (Right (ExitSuccess, out, _)) = if "vpn" `elem` lines out then Nothing
else Just "vpn not found"
go (Right (ExitFailure c, _, err)) = Just $ "vpn search exited with code "
++ show c ++ ": " ++ err
go (Left e) = Just $ show e
xmobarDBus :: String -> DBusDependency_ -> CmdSpec -> Maybe Client -> BarFeature xmobarDBus :: String -> DBusDependency_ -> CmdSpec -> Maybe Client -> BarFeature
xmobarDBus n dep cmd cl = sometimesDBus cl n "xmobar dbus interface" xmobarDBus n dep cmd cl = sometimesDBus cl n "xmobar dbus interface"
@ -298,7 +298,7 @@ getEthernet client = sometimes1 "ethernet status indicator" "sysfs path"
readEth = readInterface "read ethernet interface" isEthernet readEth = readInterface "read ethernet interface" isEthernet
getBattery :: BarFeature getBattery :: BarFeature
getBattery = sometimesIO "battery level indicator" "sysfs path" getBattery = sometimesIO_ "battery level indicator" "sysfs path"
(Only_ $ sysTest "Test if battery is present" hasBattery) (Only_ $ sysTest "Test if battery is present" hasBattery)
batteryCmd batteryCmd
@ -312,7 +312,7 @@ getBt :: Maybe Client -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" btDep btCmd getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
getAlsa :: BarFeature getAlsa :: BarFeature
getAlsa = sometimesIO "volume level indicator" "alsactl" getAlsa = sometimesIO_ "volume level indicator" "alsactl"
(Only_ $ sysExe "alsactl") alsaCmd (Only_ $ sysExe "alsactl") alsaCmd
getBl :: Maybe Client -> BarFeature getBl :: Maybe Client -> BarFeature
@ -341,51 +341,83 @@ getAllCommands right = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | fonts -- | fonts
data Font = Text data BarFont = Text
| IconSmall | IconSmall
| IconMedium | IconMedium
| IconLarge | IconLarge
| IconXLarge | IconXLarge
deriving (Eq, Enum, Bounded, Show) deriving (Eq, Enum, Bounded, Show)
data BarMetaFont = BarMetaFont
{ bfOffset :: Int
, bfBuilder :: T.FontBuilder
, bfFontData :: T.FontData
}
-- font data ~ (offset, fontification string) -- font data ~ (offset, fontification string)
fontData :: Font -> (Int, String) fontString :: (BarFont -> BarMetaFont) -> BarFont -> String
fontData Text = (16, barFont) fontString f bf = b d
fontData IconSmall = (16, nerdFont 13) where
fontData IconMedium = (17, nerdFont 15) b = bfBuilder $ f bf
fontData IconLarge = (17, nerdFont 18) d = bfFontData $ f bf
fontData IconXLarge = (18, nerdFont 20)
fontString :: Font -> String fontOffset :: (BarFont -> BarMetaFont) -> BarFont -> Int
fontString = snd . fontData fontOffset f = bfOffset . f
fontOffset :: Font -> Int firstFont :: BarFont
fontOffset = fst . fontData firstFont = minBound
allFonts :: [Font] restFonts :: [BarFont]
allFonts = enumFrom minBound restFonts = enumFrom $ succ minBound
allFontOffsets :: [Int] -- allFonts :: [BarFont]
allFontOffsets = fontOffset <$> allFonts -- allFonts = enumFrom minBound
allFontStrings :: [String] -- allFontOffsets :: [Int]
allFontStrings = fontString <$> allFonts -- allFontOffsets = fontOffset <$> allFonts
barFont :: String -- allFontStrings :: [String]
barFont = T.fmtFontXFT T.font -- allFontStrings = fontString <$> allFonts
{ T.family = "DejaVu Sans Mono"
, T.size = Just 11
, T.weight = Just T.Bold
}
nerdFont :: Int -> String barFont :: Always T.FontBuilder
nerdFont size = T.fmtFontXFT T.font barFont = T.fontFeature "XMobar Text Font" "DejaVu Sans Mono"
{ T.family = "Symbols Nerd Font"
, T.size = Nothing
, T.pixelsize = Just size
}
fontifyText :: Font -> String -> String nerdFont :: Always T.FontBuilder
nerdFont = T.fontFeature "XMobar Icon Font" "Symbols Nerd Font"
evalFonts :: IO (BarFont -> BarMetaFont)
evalFonts = do
bf <- evalAlways barFont
nf <- evalAlways nerdFont
return $ fontData bf nf
fontData :: T.FontBuilder -> T.FontBuilder -> BarFont -> BarMetaFont
fontData barBuilder nerdBuilder bf = case bf of
Text -> BarMetaFont 16 barBuilder
$ T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
IconSmall -> nerd 16 13
IconMedium -> nerd 17 15
IconLarge -> nerd 17 18
IconXLarge -> nerd 18 20
where
nerd o s = BarMetaFont o nerdBuilder
$ T.defFontData { T.pixelsize = Just s, T.size = Nothing }
-- barFont :: Always T.FontBuilder
-- barFont = T.fmtFontXFT T.font
-- { T.family = "DejaVu Sans Mono"
-- , T.size = Just 11
-- , T.weight = Just T.Bold
-- }
-- nerdFont :: Int -> String
-- nerdFont size = T.fmtFontXFT T.font
-- { T.family = "Symbols Nerd Font"
-- , T.size = Nothing
-- , T.pixelsize = Just size
-- }
fontifyText :: BarFont -> String -> String
fontifyText fnt txt = concat ["<fn=", show $ fromEnum fnt, ">", txt, "</fn>"] fontifyText fnt txt = concat ["<fn=", show $ fromEnum fnt, ">", txt, "</fn>"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

12
bin/xmonad.hs
View File

@ -92,6 +92,7 @@ run = do
{ tsChildPIDs = [p] { tsChildPIDs = [p]
, tsChildHandles = [h] , tsChildHandles = [h]
} }
fb <- evalAlways T.defFont
ext <- evalExternal $ externalBindings ts db ext <- evalExternal $ externalBindings ts db
sk <- evalAlways runShowKeys sk <- evalAlways runShowKeys
ha <- evalAlways runHandleACPI ha <- evalAlways runHandleACPI
@ -103,7 +104,7 @@ run = do
$ docks $ docks
$ def { terminal = myTerm $ def { terminal = myTerm
, modMask = myModMask , modMask = myModMask
, layoutHook = myLayouts , layoutHook = myLayouts fb
, manageHook = myManageHook , manageHook = myManageHook
, handleEventHook = myEventHook ha , handleEventHook = myEventHook ha
, startupHook = myStartupHook , startupHook = myStartupHook
@ -262,12 +263,12 @@ allDWs = [ xsaneDynamicWorkspace
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Layout configuration -- | Layout configuration
myLayouts = onWorkspace (dwTag wmDynamicWorkspace) vmLayout myLayouts fb = onWorkspace (dwTag wmDynamicWorkspace) vmLayout
$ onWorkspace (dwTag gimpDynamicWorkspace) gimpLayout $ onWorkspace (dwTag gimpDynamicWorkspace) gimpLayout
$ mkToggle (single HIDE) $ mkToggle (single HIDE)
$ tall ||| fulltab ||| full $ tall ||| fulltab ||| full
where where
addTopBar = noFrillsDeco shrinkText T.tabbedTheme addTopBar = noFrillsDeco shrinkText $ T.tabbedTheme fb
tall = renamed [Replace "Tall"] tall = renamed [Replace "Tall"]
$ avoidStruts $ avoidStruts
$ addTopBar $ addTopBar
@ -276,7 +277,7 @@ myLayouts = onWorkspace (dwTag wmDynamicWorkspace) vmLayout
fulltab = renamed [Replace "Tabbed"] fulltab = renamed [Replace "Tabbed"]
$ avoidStruts $ avoidStruts
$ noBorders $ noBorders
$ tabbedAlways shrinkText T.tabbedTheme $ tabbedAlways shrinkText $ T.tabbedTheme fb
full = renamed [Replace "Full"] full = renamed [Replace "Full"]
$ noBorders Full $ noBorders Full
vmLayout = noBorders Full vmLayout = noBorders Full
@ -610,7 +611,7 @@ externalBindings ts db =
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
, KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt , KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt
, KeyBinding "M-<Home>" "quit xmonad" quitf , KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock , KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
-- M-<F1> reserved for showing the keymap -- M-<F1> reserved for showing the keymap
, KeyBinding "M-<F2>" "restart xmonad" restartf , KeyBinding "M-<F2>" "restart xmonad" restartf
@ -630,7 +631,6 @@ externalBindings ts db =
ib = Left . brightessControls intelBacklightControls ib = Left . brightessControls intelBacklightControls
ck = Left . brightessControls clevoKeyboardControls ck = Left . brightessControls clevoKeyboardControls
ftrAlways n = Right . Always n . Always_ . FallbackAlone ftrAlways n = Right . Always n . Always_ . FallbackAlone
quitf = ftrAlways "quit function" runQuitPrompt
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart) restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
recompilef = ftrAlways "recompile function" runRecompile recompilef = ftrAlways "recompile function" runRecompile

4
install_deps
View File

@ -3,8 +3,8 @@
## Install all pkgs required for xmonad to run at full capacity ## Install all pkgs required for xmonad to run at full capacity
xmonad_pkgs=(autorandr feh xorg-server xorg-xset libpulse flameshot xmonad_pkgs=(autorandr feh xorg-server xorg-xset libpulse flameshot
playerctl wireless_tools acpid ttf-symbola-free ttf-symbola-free playerctl acpid ttf-symbola-free ttf-symbola-free
ttf-dejavu awesome-terminal-fonts numlockx picom i3lock-color ttf-dejavu numlockx picom i3lock-color
xorg-xrandr xss-lock) xorg-xrandr xss-lock)
yay --needed --noconfirm --norebuild --removemake -S "${xmonad_pkgs[@]}" yay --needed --noconfirm --norebuild --removemake -S "${xmonad_pkgs[@]}"

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

@ -72,7 +72,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-- | Exported Commands -- | Exported Commands
runDevMenu :: SometimesX runDevMenu :: SometimesX
runDevMenu = sometimesIO "device manager" "rofi devices" t x runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
where where
t = Only_ $ localExe myDmenuDevices t = Only_ $ localExe myDmenuDevices
x = do x = do
@ -87,12 +87,12 @@ runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
myDmenuBluetooth $ "-c":themeArgs "#0044bb" myDmenuBluetooth $ "-c":themeArgs "#0044bb"
runBwMenu :: SometimesX runBwMenu :: SometimesX
runBwMenu = sometimesIO "password manager" "rofi bitwarden" runBwMenu = sometimesIO_ "password manager" "rofi bitwarden"
(Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords (Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
runVPNMenu :: SometimesX runVPNMenu :: SometimesX
runVPNMenu = sometimesIO "VPN selector" "rofi VPN" runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN"
(Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN (Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
@ -103,7 +103,7 @@ runAppMenu :: SometimesX
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"] runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runClipMenu :: SometimesX runClipMenu :: SometimesX
runClipMenu = sometimesIO "clipboard manager" "rofi greenclip" deps act runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" deps act
where where
act = spawnCmd myDmenuCmd args act = spawnCmd myDmenuCmd args
deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip") deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip")

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

@ -95,7 +95,7 @@ runTerm :: SometimesX
runTerm = sometimesExe "terminal" "urxvt" True myTerm runTerm = sometimesExe "terminal" "urxvt" True myTerm
runTMux :: SometimesX runTMux :: SometimesX
runTMux = sometimesIO "terminal multiplexer" "tmux" deps act runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
where where
deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"] deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"]
act = spawn act = spawn
@ -106,7 +106,7 @@ runTMux = sometimesIO "terminal multiplexer" "tmux" deps act
msg = "could not connect to tmux session" msg = "could not connect to tmux session"
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"]
@ -155,7 +155,7 @@ playSound file = do
featureSound :: String -> FilePath -> X () -> X () -> SometimesX featureSound :: String -> FilePath -> X () -> X () -> SometimesX
featureSound n file pre post = featureSound n file pre post =
sometimesIO ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay") sometimesIO_ ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay")
$ pre >> playSound file >> post $ pre >> playSound file >> post
runVolumeDown :: SometimesX runVolumeDown :: SometimesX
@ -194,7 +194,7 @@ runNotificationContext =
runToggleBluetooth :: SometimesX runToggleBluetooth :: SometimesX
runToggleBluetooth = runToggleBluetooth =
sometimesIO "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth) sometimesIO_ "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
$ spawn $ spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\"" $ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on" #!&& "a=on"
@ -203,7 +203,7 @@ runToggleBluetooth =
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
runToggleEthernet :: SometimesX runToggleEthernet :: SometimesX
runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli") runToggleEthernet = sometimesIO_ "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli")
$ spawn $ spawn
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected" $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
#!&& "a=connect" #!&& "a=connect"
@ -212,7 +212,7 @@ runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
runStartISyncTimer :: SometimesX runStartISyncTimer :: SometimesX
runStartISyncTimer = sometimesIO "isync timer" "mbsync timer" runStartISyncTimer = sometimesIO_ "isync timer" "mbsync timer"
(Only_ $ sysdUser "mbsync.timer") (Only_ $ sysdUser "mbsync.timer")
$ spawn $ spawn
$ "systemctl --user start mbsync.timer" $ "systemctl --user start mbsync.timer"
@ -220,7 +220,7 @@ runStartISyncTimer = sometimesIO "isync timer" "mbsync timer"
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" } #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
runStartISyncService :: SometimesX runStartISyncService :: SometimesX
runStartISyncService = sometimesIO "isync" "mbsync service" runStartISyncService = sometimesIO_ "isync" "mbsync service"
(Only_ $ sysdUser "mbsync.service") (Only_ $ sysdUser "mbsync.service")
$ spawn $ spawn
$ "systemctl --user start mbsync.service" $ "systemctl --user start mbsync.service"
@ -266,7 +266,7 @@ getCaptureDir = do
fallback = (</> ".local/share") <$> getHomeDirectory fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> String -> SometimesX runFlameshot :: String -> String -> SometimesX
runFlameshot n mode = sometimesIO n "flameshot" (Only_ $ sysExe myCapture) runFlameshot n mode = sometimesIO_ n "flameshot" (Only_ $ sysExe myCapture)
$ spawnCmd myCapture [mode] $ spawnCmd myCapture [mode]
-- TODO this will steal focus from the current window (and puts it -- TODO this will steal focus from the current window (and puts it
@ -283,7 +283,7 @@ runScreenCapture :: SometimesX
runScreenCapture = runFlameshot "screen capture" "screen" runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX runCaptureBrowser :: SometimesX
runCaptureBrowser = sometimesIO "screen capture browser" "feh" runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
(Only_ $ sysExe myImageBrowser) $ do (Only_ $ sysExe myImageBrowser) $ do
dir <- io getCaptureDir dir <- io getCaptureDir
spawnCmd myImageBrowser [dir] spawnCmd myImageBrowser [dir]

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

@ -12,8 +12,8 @@ module XMonad.Internal.Command.Power
, runSuspendPrompt , runSuspendPrompt
, runQuitPrompt , runQuitPrompt
, hasBattery , hasBattery
, suspendPrompt
, quitPrompt
, powerPrompt , powerPrompt
) where ) where
@ -45,11 +45,14 @@ myScreenlock = "screenlock"
myOptimusManager :: String myOptimusManager :: String
myOptimusManager = "optimus-manager" myOptimusManager = "optimus-manager"
myPrimeOffload :: String
myPrimeOffload = "prime-offload"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Core commands -- | Core commands
runScreenLock :: SometimesX runScreenLock :: SometimesX
runScreenLock = sometimesExe "screen locker" "i3lock script" True myScreenlock runScreenLock = sometimesExe "screen locker" "i3lock script" False myScreenlock
runPowerOff :: X () runPowerOff :: X ()
runPowerOff = spawn "systemctl poweroff" runPowerOff = spawn "systemctl poweroff"
@ -64,14 +67,27 @@ runReboot :: X ()
runReboot = spawn "systemctl reboot" runReboot = spawn "systemctl reboot"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Confirm prompt wrappers -- | Confirmation prompts
confirmPrompt' :: String -> X () -> T.FontBuilder -> X ()
confirmPrompt' s x fb = confirmPrompt (T.promptTheme fb) s x
suspendPrompt :: T.FontBuilder -> X ()
suspendPrompt = confirmPrompt' "suspend?" runSuspend
quitPrompt :: T.FontBuilder -> X ()
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
sometimesPrompt n = sometimesIO n (n ++ " command")
$ Only $ IOAlways T.defFont id
-- TODO doesn't this need to also lock the screen? -- TODO doesn't this need to also lock the screen?
runSuspendPrompt :: X () runSuspendPrompt :: SometimesX
runSuspendPrompt = confirmPrompt T.promptTheme "suspend?" runSuspend runSuspendPrompt = sometimesPrompt "suspend prompt" suspendPrompt
runQuitPrompt :: X () runQuitPrompt :: SometimesX
runQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Nvidia Optimus -- | Nvidia Optimus
@ -91,21 +107,25 @@ hasBattery = do
readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type") readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
syspath = "/sys/class/power_supply" syspath = "/sys/class/power_supply"
runOptimusPrompt' :: X () runOptimusPrompt' :: T.FontBuilder -> X ()
runOptimusPrompt' = do runOptimusPrompt' fb = do
nvidiaOn <- io isUsingNvidia nvidiaOn <- io isUsingNvidia
switch $ if nvidiaOn then "integrated" else "nvidia" switch $ if nvidiaOn then "integrated" else "nvidia"
where where
switch mode = confirmPrompt T.promptTheme (prompt mode) (cmd mode) switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
prompt mode = "gpu switch to " ++ mode ++ "?" prompt mode = "gpu switch to " ++ mode ++ "?"
cmd mode = spawn $ cmd mode = spawn $
"prime-offload" myPrimeOffload
#!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"] #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad" #!&& "killall xmonad"
runOptimusPrompt :: SometimesX runOptimusPrompt :: SometimesX
runOptimusPrompt = sometimesIO "graphics switcher" "optimus manager" runOptimusPrompt = Sometimes "graphics switcher" [s]
(Only_ $ localExe myOptimusManager) runOptimusPrompt' where
s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error }
r = IORoot runOptimusPrompt' t
t = And1 (Only $ IOAlways T.defFont id)
$ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Universal power prompt -- | Universal power prompt
@ -134,18 +154,21 @@ instance XPrompt PowerPrompt where
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
runPowerPrompt :: AlwaysX runPowerPrompt :: AlwaysX
runPowerPrompt = always1 "power prompt" "lock-enabled prompt" withLock powerPromptNoLock runPowerPrompt = Always "power prompt" $ Option sf fallback
where where
withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id) sf = Subfeature withLock "lock-enabled prompt" Error
withLock = IORoot (uncurry powerPrompt) tree
tree = And12 (,) (Only $ IOSometimes runScreenLock id) (Only $ IOAlways T.defFont id)
fallback = Always_ $ FallbackTree powerPromptNoLock $ FallbackBottom T.defFont
powerPromptNoLock :: X () powerPromptNoLock :: T.FontBuilder -> X ()
powerPromptNoLock = powerPrompt skip powerPromptNoLock = powerPrompt skip
powerPrompt :: X () -> X () powerPrompt :: X () -> T.FontBuilder -> X ()
powerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
where where
comp = mkComplFunFromList theme [] comp = mkComplFunFromList theme []
theme = T.promptTheme { promptKeymap = keymap } theme = (T.promptTheme fb) { promptKeymap = keymap }
keymap = M.fromList keymap = M.fromList
$ ((controlMask, xK_g), quit) : $ ((controlMask, xK_g), quit) :
map (first $ (,) 0) map (first $ (,) 0)

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

@ -27,6 +27,7 @@ import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import XMonad.Internal.Shell import XMonad.Internal.Shell
import XMonad.Internal.Theme (FontBuilder, defFont)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Data structure to hold the ACPI events I care about -- | Data structure to hold the ACPI events I care about
@ -90,17 +91,17 @@ listenACPI = do
acpiPath :: FilePath acpiPath :: FilePath
acpiPath = "/var/run/acpid.socket" acpiPath = "/var/run/acpid.socket"
socketDep :: Tree_ IODependency_ socketDep :: IOTree_
socketDep = Only_ $ pathR acpiPath socketDep = Only_ $ pathR acpiPath
-- | Handle ClientMessage event containing and ACPI event (to be used in -- | Handle ClientMessage event containing and ACPI event (to be used in
-- Xmonad's event hook) -- Xmonad's event hook)
handleACPI :: X () -> String -> X () handleACPI :: FontBuilder -> X () -> String -> X ()
handleACPI lock tag = do handleACPI fb lock tag = do
let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
forM_ acpiTag $ \case forM_ acpiTag $ \case
Power -> powerPrompt lock Power -> powerPrompt lock fb
Sleep -> runSuspendPrompt Sleep -> suspendPrompt fb
LidClose -> do LidClose -> do
status <- io isDischarging status <- io isDischarging
-- only run suspend if battery exists and is discharging -- only run suspend if battery exists and is discharging
@ -113,9 +114,12 @@ handleACPI lock tag = do
-- | Spawn a new thread that will listen for ACPI events on the acpid socket -- | Spawn a new thread that will listen for ACPI events on the acpid socket
-- and send ClientMessage events when it receives them -- and send ClientMessage events when it receives them
runPowermon :: SometimesIO runPowermon :: SometimesIO
runPowermon = sometimesIO "ACPI event monitor" "acpid" socketDep listenACPI runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep listenACPI
runHandleACPI :: Always (String -> X ()) runHandleACPI :: Always (String -> X ())
runHandleACPI = always1 "ACPI event handler" "acpid" withLock $ handleACPI skip runHandleACPI = Always "ACPI event handler" $ Option sf fallback
where where
withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id) sf = Subfeature withLock "acpid prompt" Error
withLock = IORoot (uncurry handleACPI)
$ And12 (,) (Only $ IOAlways defFont id) (Only $ IOSometimes runScreenLock id)
fallback = Always_ $ FallbackTree (`handleACPI` skip) $ FallbackBottom defFont

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

@ -29,6 +29,10 @@ module XMonad.Internal.Dependency
, Root(..) , Root(..)
, Tree(..) , Tree(..)
, Tree_(..) , Tree_(..)
, IOTree
, IOTree_
, DBusTree
, DBusTree_
, IODependency(..) , IODependency(..)
, IODependency_(..) , IODependency_(..)
, SystemDependency(..) , SystemDependency(..)
@ -61,6 +65,7 @@ module XMonad.Internal.Dependency
, always1 , always1
, sometimes1 , sometimes1
, sometimesIO , sometimesIO
, sometimesIO_
, sometimesDBus , sometimesDBus
, sometimesExe , sometimesExe
, sometimesExeArgs , sometimesExeArgs
@ -69,6 +74,7 @@ module XMonad.Internal.Dependency
-- dependency construction -- dependency construction
, sysExe , sysExe
, localExe , localExe
, fontFam
, sysdSystem , sysdSystem
, sysdUser , sysdUser
, listToAnds , listToAnds
@ -187,12 +193,14 @@ type Feature a = Either (Sometimes a) (Always a)
data Always a = Always String (Always_ a) data Always a = Always String (Always_ a)
-- | Feature that is guaranteed to work (inner data) -- | Feature that is guaranteed to work (inner data)
data Always_ a = Option (SubfeatureRoot a) (Always_ a) | Always_ (FallbackRoot a) data Always_ a = Option (SubfeatureRoot a) (Always_ a)
| Always_ (FallbackRoot a)
-- | Root of a fallback action for an always -- | Root of a fallback action for an always
-- This may either be a lone action or a function that depends on the results -- This may either be a lone action or a function that depends on the results
-- from other Always features. -- from other Always features.
data FallbackRoot a = FallbackAlone a | forall p. FallbackTree (p -> a) (FallbackStack p) data FallbackRoot a = FallbackAlone a
| forall p. FallbackTree (p -> a) (FallbackStack p)
-- | Always features that are used as a payload for a fallback action -- | Always features that are used as a payload for a fallback action
data FallbackStack p = FallbackBottom (Always p) data FallbackStack p = FallbackBottom (Always p)
@ -225,13 +233,12 @@ data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
-- | An action and its dependencies -- | An action and its dependencies
-- May be a plain old monad or be DBus-dependent, in which case a client is -- May be a plain old monad or be DBus-dependent, in which case a client is
-- needed -- needed
data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p) data Root a = forall p. IORoot (p -> a) (IOTree p)
| IORoot_ a (Tree_ IODependency_) | IORoot_ a IOTree_
| forall p. DBusRoot (p -> Client -> a) | forall p. DBusRoot (p -> Client -> a) (DBusTree p) (Maybe Client)
(Tree IODependency DBusDependency_ p) (Maybe Client) | DBusRoot_ (Client -> a) DBusTree_ (Maybe Client)
| DBusRoot_ (Client -> a) (Tree_ DBusDependency_) (Maybe Client)
-- | The dependency tree with rules to merge results -- | The dependency tree with rule to merge results when needed
data Tree d d_ p = data Tree d d_ p =
forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y) forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
| And1 (Tree d d_ p) (Tree_ d_) | And1 (Tree d d_ p) (Tree_ d_)
@ -240,10 +247,13 @@ data Tree d d_ p =
| Only (d p) | Only (d p)
-- | A dependency tree without functions to merge results -- | A dependency tree without functions to merge results
data Tree_ d = data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d
And_ (Tree_ d) (Tree_ d)
| Or_ (Tree_ d) (Tree_ d) -- | Shorthand tree types for lazy typers
| Only_ d type IOTree p = Tree IODependency IODependency_ p
type DBusTree p = Tree IODependency DBusDependency_ p
type IOTree_ = Tree_ IODependency_
type DBusTree_ = Tree_ DBusDependency_
-- | A dependency that only requires IO to evaluate -- | A dependency that only requires IO to evaluate
data IODependency p = IORead String (IO (Result p)) data IODependency p = IORead String (IO (Result p))
@ -260,6 +270,7 @@ data IODependency_ = IOSystem_ SystemDependency
| forall a. IOSometimes_ (Sometimes a) | forall a. IOSometimes_ (Sometimes a)
data SystemDependency = Executable Bool FilePath data SystemDependency = Executable Bool FilePath
| FontFamily String
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| IOTest String (IO (Maybe String)) | IOTest String (IO (Maybe String))
| Systemd UnitType String | Systemd UnitType String
@ -434,12 +445,13 @@ testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
where where
msg = unwords [e, "executable", singleQuote bin, "not found"] msg = unwords [e, "executable", singleQuote bin, "not found"]
e = if sys then "system" else "local" e = if sys then "system" else "local"
testSysDependency (Systemd t n) = do testSysDependency (FontFamily fam) = shellTest cmd msg
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Nothing
_ -> Just $ "systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"
where where
msg = unwords ["font family", singleQuote fam, "not found"]
cmd = fmtCmd "fc-list" ["-q", singleQuote fam]
testSysDependency (Systemd t n) = shellTest cmd msg
where
msg = unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n] cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
where where
@ -455,6 +467,13 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
_ -> Nothing _ -> Nothing
shellTest :: String -> String -> IO (Maybe String)
shellTest cmd msg = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Nothing
_ -> Just msg
unitType :: UnitType -> String unitType :: UnitType -> String
unitType SystemUnit = "system" unitType SystemUnit = "system"
unitType UserUnit = "user" unitType UserUnit = "user"
@ -560,8 +579,11 @@ sometimes1 = sometimes1_ Error
always1 :: String -> String -> Root a -> a -> Always a always1 :: String -> String -> Root a -> a -> Always a
always1 = always1_ Error always1 = always1_ Error
sometimesIO :: String -> String -> Tree_ IODependency_ -> a -> Sometimes a sometimesIO_ :: String -> String -> IOTree_ -> a -> Sometimes a
sometimesIO fn n t x = sometimes1 fn n $ IORoot_ x t sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
sometimesIO :: String -> String -> IOTree p -> (p -> a) -> Sometimes a
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ()) sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ())
sometimesExe fn n sys path = sometimesExeArgs fn n sys path [] sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
@ -569,7 +591,7 @@ sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath
-> [String] -> Sometimes (m ()) -> [String] -> Sometimes (m ())
sometimesExeArgs fn n sys path args = sometimesExeArgs fn n sys path args =
sometimesIO fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args sometimesIO_ fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_ sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_
-> (Client -> a) -> Sometimes a -> (Client -> a) -> Sometimes a
@ -598,6 +620,9 @@ toAnd a b = And_ (Only_ a) (Only_ b)
exe :: Bool -> String -> IODependency_ exe :: Bool -> String -> IODependency_
exe b = IOSystem_ . Executable b exe b = IOSystem_ . Executable b
fontFam :: String -> IODependency_
fontFam = IOSystem_ . FontFamily
sysExe :: String -> IODependency_ sysExe :: String -> IODependency_
sysExe = exe True sysExe = exe True
@ -723,11 +748,11 @@ dataTree_ f_ = go
go (Only_ d) = uncurry jsonLeafUntested $ f_ d go (Only_ d) = uncurry jsonLeafUntested $ f_ d
dataIODependency :: IODependency p -> DependencyData dataIODependency :: IODependency p -> DependencyData
dataIODependency d = case d of dataIODependency d = first Q $ case d of
(IORead n _) -> (Q "ioread", [("desc", JSON_Q $ Q n)]) (IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)])
-- TODO make this actually useful (I actually need to name my features) -- TODO make this actually useful (I actually need to name my features)
(IOSometimes _ _) -> (Q "sometimes", []) (IOSometimes _ _) -> ("sometimes", [])
(IOAlways _ _) -> (Q "always", []) (IOAlways _ _) -> ("always", [])
dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ :: IODependency_ -> DependencyData
dataIODependency_ d = case d of dataIODependency_ d = case d of
@ -735,17 +760,18 @@ dataIODependency_ d = case d of
(IOSometimes_ _) -> (Q "sometimes", []) (IOSometimes_ _) -> (Q "sometimes", [])
dataSysDependency :: SystemDependency -> DependencyData dataSysDependency :: SystemDependency -> DependencyData
dataSysDependency d = do dataSysDependency d = first Q $
case d of case d of
(Executable sys path) -> (Q "executable", [ ("system", JSON_UQ $ jsonBool sys) (Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys)
, ("path", JSON_Q $ Q path) , ("path", JSON_Q $ Q path)
]) ])
(IOTest desc _) -> (Q "iotest", [("desc", JSON_Q $ Q desc)]) (IOTest desc _) -> ("iotest", [("desc", JSON_Q $ Q desc)])
(AccessiblePath p r w) -> (Q "path", [ ("path", JSON_Q $ Q p) (FontFamily fam) -> ("font", [("family", JSON_Q $ Q fam)])
(AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
, ("readable", JSON_UQ $ jsonBool r) , ("readable", JSON_UQ $ jsonBool r)
, ("writable", JSON_UQ $ jsonBool w) , ("writable", JSON_UQ $ jsonBool w)
]) ])
(Systemd t n) -> (Q "systemd", [ ("unittype", JSON_Q $ Q $ unitType t) (Systemd t n) -> ("systemd", [ ("unittype", JSON_Q $ Q $ unitType t)
, ("unit", JSON_Q $ Q n)]) , ("unit", JSON_Q $ Q n)])
dataDBusDependency :: DBusDependency_ -> DependencyData dataDBusDependency :: DBusDependency_ -> DependencyData

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

@ -18,9 +18,12 @@ module XMonad.Internal.Theme
, darken' , darken'
, Slant(..) , Slant(..)
, Weight(..) , Weight(..)
, ThemeFont(..) , FontData(..)
, fmtFontXFT , FontBuilder
, font , buildFont
, defFontData
, defFont
, fontFeature
, tabbedTheme , tabbedTheme
, promptTheme , promptTheme
) where ) where
@ -30,6 +33,7 @@ import Data.Colour
import Data.Colour.SRGB import Data.Colour.SRGB
import Data.List import Data.List
import XMonad.Internal.Dependency
import qualified XMonad.Layout.Decoration as D import qualified XMonad.Layout.Decoration as D
import qualified XMonad.Prompt as P import qualified XMonad.Prompt as P
@ -96,24 +100,25 @@ data Weight = Light
| Black | Black
deriving (Eq, Show) deriving (Eq, Show)
data ThemeFont = ThemeFont data FontData = FontData
{ family :: String { weight :: Maybe Weight
, weight :: Maybe Weight
, slant :: Maybe Slant , slant :: Maybe Slant
, size :: Maybe Int , size :: Maybe Int
, pixelsize :: Maybe Int , pixelsize :: Maybe Int
, antialias :: Maybe Bool , antialias :: Maybe Bool
} }
fmtFontXFT :: ThemeFont -> String type FontBuilder = FontData -> String
fmtFontXFT ThemeFont
{ family = f buildFont :: Maybe String -> FontData -> String
, weight = w buildFont Nothing _ = "fixed"
buildFont (Just fam) FontData { weight = w
, slant = l , slant = l
, size = s , size = s
, pixelsize = p , pixelsize = p
, antialias = a , antialias = a
} = intercalate ":" $ ["xft", f] ++ elems }
= intercalate ":" $ ["xft", fam] ++ elems
where where
elems = [ k ++ "=" ++ v | (k, Just v) <- [ ("weight", showLower w) elems = [ k ++ "=" ++ v | (k, Just v) <- [ ("weight", showLower w)
, ("slant", showLower l) , ("slant", showLower l)
@ -125,22 +130,34 @@ fmtFontXFT ThemeFont
showLower :: Show a => Maybe a -> Maybe String showLower :: Show a => Maybe a -> Maybe String
showLower = fmap (fmap toLower . show) showLower = fmap (fmap toLower . show)
font :: ThemeFont fontFeature :: String -> String -> Always FontBuilder
font = ThemeFont fontFeature n fam = always1 n sfn root def
{ family = "DejaVu Sans" where
, size = Just 10 sfn = "Font family for " ++ fam
root = IORoot_ (buildFont $ Just fam) $ Only_ $ fontFam fam
def = buildFont Nothing
--------------------------------------------------------------------------------
-- | Default font and data
defFontData :: FontData
defFontData = FontData
{ size = Just 10
, antialias = Just True , antialias = Just True
, weight = Nothing , weight = Nothing
, slant = Nothing , slant = Nothing
, pixelsize = Nothing , pixelsize = Nothing
} }
defFont :: Always FontBuilder
defFont = fontFeature "Default Font" "DejaVu Sans"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Complete themes -- | Complete themes
tabbedTheme :: D.Theme tabbedTheme :: FontBuilder -> D.Theme
tabbedTheme = D.def tabbedTheme fb = D.def
{ D.fontName = fmtFontXFT font { weight = Just Bold } { D.fontName = fb $ defFontData { weight = Just Bold }
, D.activeTextColor = fgColor , D.activeTextColor = fgColor
, D.activeColor = bgColor , D.activeColor = bgColor
@ -162,11 +179,11 @@ tabbedTheme = D.def
, D.decoHeight = 20 , D.decoHeight = 20
, D.windowTitleAddons = [] , D.windowTitleAddons = []
, D.windowTitleIcons = [] , D.windowTitleIcons = []
} }
promptTheme :: P.XPConfig promptTheme :: FontBuilder -> P.XPConfig
promptTheme = P.def promptTheme fb = P.def
{ P.font = fmtFontXFT font { size = Just 12 } { P.font = fb $ defFontData { size = Just 12 }
, P.bgColor = bgColor , P.bgColor = bgColor
, P.fgColor = fgColor , P.fgColor = fgColor
, P.fgHLight = selectedFgColor , P.fgHLight = selectedFgColor