ENH use dependency framework for power prompt

This commit is contained in:
Nathan Dwarshuis 2022-06-26 20:07:25 -04:00
parent 53a537960e
commit 9961f2909d
5 changed files with 64 additions and 41 deletions

View File

@ -92,10 +92,9 @@ run = do
{ tsChildPIDs = [p] { tsChildPIDs = [p]
, tsChildHandles = [h] , tsChildHandles = [h]
} }
lockRes <- evalSometimes runScreenLock ext <- evalExternal $ externalBindings ts db
let lock = fromMaybe skip lockRes
ext <- evalExternal $ externalBindings ts db lock
sk <- evalAlways runShowKeys sk <- evalAlways runShowKeys
ha <- evalAlways runHandleACPI
-- IDK why this is necessary; nothing prior to this line will print if missing -- IDK why this is necessary; nothing prior to this line will print if missing
hFlush stdout hFlush stdout
ds <- getDirectories ds <- getDirectories
@ -106,7 +105,7 @@ run = do
, modMask = myModMask , modMask = myModMask
, layoutHook = myLayouts , layoutHook = myLayouts
, manageHook = myManageHook , manageHook = myManageHook
, handleEventHook = myEventHook lock , handleEventHook = myEventHook ha
, startupHook = myStartupHook , startupHook = myStartupHook
, workspaces = myWorkspaces , workspaces = myWorkspaces
, logHook = myLoghook h , logHook = myLoghook h
@ -442,17 +441,17 @@ manageApps = composeOne $ concatMap dwHook allDWs ++
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Eventhook configuration -- | Eventhook configuration
myEventHook :: X () -> Event -> X All myEventHook :: (String -> X ()) -> Event -> X All
myEventHook lock = xMsgEventHook lock <+> handleEventHook def myEventHook handler = xMsgEventHook handler <+> handleEventHook def
-- | React to ClientMessage events from concurrent threads -- | React to ClientMessage events from concurrent threads
xMsgEventHook :: X () -> Event -> X All xMsgEventHook :: (String -> X ()) -> Event -> X All
xMsgEventHook lock ClientMessageEvent { ev_message_type = t, ev_data = d } xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
| t == bITMAP = do | t == bITMAP = do
let (xtype, tag) = splitXMsg d let (xtype, tag) = splitXMsg d
case xtype of case xtype of
Workspace -> removeDynamicWorkspace tag Workspace -> removeDynamicWorkspace tag
ACPI -> handleACPI lock tag ACPI -> handler tag
Unknown -> io $ print "WARNING: unknown concurrent message" Unknown -> io $ print "WARNING: unknown concurrent message"
return (All True) return (All True)
xMsgEventHook _ _ = return (All True) xMsgEventHook _ _ = return (All True)
@ -559,8 +558,8 @@ flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of
(Just x) -> Just $ k{ kbMaybeAction = x } (Just x) -> Just $ k{ kbMaybeAction = x }
Nothing -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip } Nothing -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip }
externalBindings :: ThreadState -> DBusState -> X () -> [KeyGroup (FeatureX)] externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
externalBindings ts db lock = externalBindings ts db =
[ KeyGroup "Launchers" [ KeyGroup "Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu [ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
@ -615,7 +614,7 @@ externalBindings ts db lock =
, KeyBinding "M-S-," "keyboard down" $ ck bctlDec , KeyBinding "M-S-," "keyboard down" $ ck bctlDec
, 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" $ ftrAlways $ runPowerPrompt lock , KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt
, KeyBinding "M-<Home>" "quit xmonad" $ ftrAlways runQuitPrompt , KeyBinding "M-<Home>" "quit xmonad" $ ftrAlways 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

View File

@ -91,28 +91,6 @@ runVPNMenu :: SometimesX
runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $ runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
runShowKeys = Option showKeysDMenu (Always fallback)
where
-- TODO this should technically depend on dunst
fallback = const $ spawnNotify
$ defNoteError { body = Just $ Text "could not display keymap" }
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
showKeysDMenu = Subfeature
{ sfName = "keyboard shortcut menu"
, sfData = IORoot_ showKeys $ Only_ $ sysExe myDmenuCmd
, sfLevel = Warn
}
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
showKeys kbs = io $ do
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
where
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
runCmdMenu :: SometimesX runCmdMenu :: SometimesX
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
@ -139,3 +117,28 @@ runNetMenu =
runAutorandrMenu :: SometimesX runAutorandrMenu :: SometimesX
runAutorandrMenu = runAutorandrMenu =
sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066" sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066"
--------------------------------------------------------------------------------
-- | Shortcut menu
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
runShowKeys = Option showKeysDMenu (Always fallback)
where
-- TODO this should technically depend on dunst
fallback = const $ spawnNotify
$ defNoteError { body = Just $ Text "could not display keymap" }
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
showKeysDMenu = Subfeature
{ sfName = "keyboard shortcut menu"
, sfData = IORoot_ showKeys $ Only_ $ sysExe myDmenuCmd
, sfLevel = Warn
}
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
showKeys kbs = io $ do
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
where
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs

View File

@ -12,6 +12,9 @@ module XMonad.Internal.Command.Power
, runSuspendPrompt , runSuspendPrompt
, runQuitPrompt , runQuitPrompt
, hasBattery , hasBattery
, powerPrompt
) where ) where
import Control.Arrow (first) import Control.Arrow (first)
@ -130,8 +133,16 @@ data PowerPrompt = PowerPrompt
instance XPrompt PowerPrompt where 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 :: X () -> X () runPowerPrompt :: AlwaysX
runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction runPowerPrompt = always1 "power prompt" withLock powerPromptNoLock
where
withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id)
powerPromptNoLock :: X ()
powerPromptNoLock = powerPrompt skip
powerPrompt :: X () -> X ()
powerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction
where where
comp = mkComplFunFromList theme [] comp = mkComplFunFromList theme []
theme = T.promptTheme { promptKeymap = keymap } theme = T.promptTheme { promptKeymap = keymap }

View File

@ -6,7 +6,7 @@
module XMonad.Internal.Concurrent.ACPIEvent module XMonad.Internal.Concurrent.ACPIEvent
( runPowermon ( runPowermon
, handleACPI , runHandleACPI
) where ) where
import Control.Exception import Control.Exception
@ -26,6 +26,7 @@ import XMonad.Core
import XMonad.Internal.Command.Power 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
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Data structure to hold the ACPI events I care about -- | Data structure to hold the ACPI events I care about
@ -97,13 +98,18 @@ acpiPath = "/var/run/acpid.socket"
runPowermon :: SometimesIO runPowermon :: SometimesIO
runPowermon = sometimesIO "ACPI event monitor" (Only_ $ pathR acpiPath) listenACPI runPowermon = sometimesIO "ACPI event monitor" (Only_ $ pathR acpiPath) listenACPI
runHandleACPI :: Always (String -> X ())
runHandleACPI = always1 "ACPI event handler" withLock $ handleACPI skip
where
withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id)
-- | 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 :: X () -> String -> X ()
handleACPI lock tag = do handleACPI lock tag = do
let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
forM_ acpiTag $ \case forM_ acpiTag $ \case
Power -> runPowerPrompt lock Power -> powerPrompt lock
Sleep -> runSuspendPrompt Sleep -> runSuspendPrompt
LidClose -> do LidClose -> do
status <- io isDischarging status <- io isDischarging

View File

@ -42,6 +42,7 @@ module XMonad.Internal.Dependency
, ioAlways , ioAlways
-- feature construction -- feature construction
, always1
, sometimes1 , sometimes1
, sometimesIO , sometimesIO
, sometimesDBus , sometimesDBus
@ -460,13 +461,16 @@ testDBusDependency_ _ (DBusIO i) = testIODependency_ i
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }] sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
-- always1_ :: LogLevel -> String -> Root a Tree -> a -> Always a always1_ :: LogLevel -> String -> Root a -> a -> Always a
-- always1_ l n t x = always1_ l n t x =
-- Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x) Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x)
sometimes1 :: String -> Root a -> Sometimes a sometimes1 :: String -> Root a -> Sometimes a
sometimes1 = sometimes1_ Error sometimes1 = sometimes1_ Error
always1 :: String -> Root a -> a -> Always a
always1 = always1_ Error
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
sometimesIO n t x = sometimes1 n $ IORoot_ x t sometimesIO n t x = sometimes1 n $ IORoot_ x t