ENH make power prompt better

This commit is contained in:
Nathan Dwarshuis 2020-03-16 19:34:13 -04:00
parent 7a7365de3d
commit c7d7a12ca1
2 changed files with 26 additions and 15 deletions

View File

@ -10,13 +10,15 @@ import qualified Theme as T
import Control.Monad (mapM_, forM_, void, when) import Control.Monad (mapM_, forM_, void, when)
import Data.List (sortBy, sortOn) import Data.List (sortBy, sortOn)
import Data.Maybe (fromMaybe, isJust) import qualified Data.Map.Lazy as M
import Data.Maybe (isJust)
import Data.Monoid (All(..)) import Data.Monoid (All(..))
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import Graphics.X11.Types import Graphics.X11.Types
import Control.Arrow (first)
import Control.Exception import Control.Exception
import System.Directory import System.Directory
@ -165,7 +167,7 @@ myManageHook = composeOne
-- assume virtualbox is not run with the toolbar in fullscreen mode -- assume virtualbox is not run with the toolbar in fullscreen mode
-- as this makes a new window that confusingly must go over the -- as this makes a new window that confusingly must go over the
-- actual VM window -- actual VM window
[ className =? "VirtualBoxVM" -?> doShift "VM" [ className =? "VirtualBoxVM" -?> doShift myVMWorkspace
-- the seafile applet -- the seafile applet
, className =? "Seafile Client" -?> doFloat , className =? "Seafile Client" -?> doFloat
-- gnucash -- gnucash
@ -173,7 +175,7 @@ myManageHook = composeOne
-- xsane -- xsane
, className =? "Xsane" -?> doFloat , className =? "Xsane" -?> doFloat
-- all of GIMP -- all of GIMP
, className =? "Gimp" -?> doFloat , className =? "Gimp" -?> doFloat >> doShift myGimpWorkspace
-- , title =? "GIMP Startup" -?> doIgnore -- , title =? "GIMP Startup" -?> doIgnore
-- plots and graphics created by R -- plots and graphics created by R
, className =? "R_x11" -?> doFloat , className =? "R_x11" -?> doFloat
@ -227,11 +229,10 @@ removeEmptyWorkspaceByTag' tag = do
-- this will be enough to make it disappear. -- this will be enough to make it disappear.
removeEmptyWorkspaceByTag tag removeEmptyWorkspaceByTag tag
-- TODO is there a better way to get the prompt to say what I want?
data PowerPrompt = PowerPrompt data PowerPrompt = PowerPrompt
instance XPrompt PowerPrompt where instance XPrompt PowerPrompt where
showXPrompt PowerPrompt = "Select Option: " showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
runScreenLock :: X () runScreenLock :: X ()
runScreenLock = spawn "screenlock" runScreenLock = spawn "screenlock"
@ -249,18 +250,27 @@ runReboot :: X ()
runReboot = spawn "systemctl reboot" runReboot = spawn "systemctl reboot"
myPowerPrompt :: X () myPowerPrompt :: X ()
myPowerPrompt = mkXPrompt PowerPrompt conf comps myPowerPrompt = mkXPrompt PowerPrompt theme comp executeAction
$ fromMaybe (return ())
. (`lookup` commands)
where where
comps = mkComplFunFromList' (map fst commands) comp = mkComplFunFromList []
conf = T.promptTheme theme = T.promptTheme { promptKeymap = keymap }
commands = keymap = M.fromList
[ ("poweroff", runPowerOff) $ ((0, xK_g), quit) :
, ("suspend", runScreenLock >> runSuspend) map (first $ (,) 0)
, ("hibernate", runScreenLock >> runHibernate) [ (xK_p, sendAction "p")
, ("reboot", runReboot) , (xK_s, sendAction "s")
, (xK_h, sendAction "h")
, (xK_r, sendAction "r")
, (xK_Return, quit)
, (xK_Escape, quit)
] ]
sendAction a = setInput a >> setSuccess True >> setDone True
executeAction a
| a == "p" = runPowerOff
| a == "s" = runScreenLock >> runSuspend
| a == "h" = runScreenLock >> runHibernate
| a == "r" = runReboot
| otherwise = return () -- should never happen
myQuitPrompt :: X () myQuitPrompt :: X ()
myQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess myQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess

View File

@ -27,6 +27,7 @@ executable xmonad
, unix >= 2.7.2.2 , unix >= 2.7.2.2
, process >= 1.6.5.0 , process >= 1.6.5.0
, directory >= 1.3.3.0 , directory >= 1.3.3.0
, containers >= 0.6.0.1
, my-xmonad , my-xmonad
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded