ENH make power prompt better
This commit is contained in:
parent
7a7365de3d
commit
c7d7a12ca1
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue