xmonad-config/lib/XMonad/Internal/Command/Power.hs

201 lines
6.1 KiB
Haskell
Raw Normal View History

2020-04-01 20:17:47 -04:00
--------------------------------------------------------------------------------
-- | Commands for controlling power
module XMonad.Internal.Command.Power
2022-07-03 01:11:32 -04:00
-- commands
2020-03-28 18:38:38 -04:00
( runHibernate
, runOptimusPrompt
, runPowerOff
, runPowerPrompt
, runReboot
, runScreenLock
, runSuspend
, runSuspendPrompt
, runQuitPrompt
2022-07-03 01:11:32 -04:00
-- daemons
, runAutolock
-- functions
, hasBattery
2022-07-02 17:09:21 -04:00
, suspendPrompt
, quitPrompt
, powerPrompt
2020-04-01 20:17:47 -04:00
) where
2020-03-28 18:38:38 -04:00
import Control.Arrow (first)
import Data.Either
2020-03-28 18:38:38 -04:00
import qualified Data.Map as M
import Graphics.X11.Types
2020-04-01 20:17:47 -04:00
import System.Directory
import System.Exit
import System.FilePath.Posix
import System.IO.Error
2022-07-03 01:11:32 -04:00
import System.Process (ProcessHandle)
2020-04-01 20:17:47 -04:00
2020-03-28 18:38:38 -04:00
import XMonad.Core
import XMonad.Internal.Dependency
2022-07-03 01:11:32 -04:00
import XMonad.Internal.Process (spawnPipeArgs)
2021-11-20 01:15:04 -05:00
import XMonad.Internal.Shell
2020-04-01 20:17:47 -04:00
import qualified XMonad.Internal.Theme as T
2020-03-28 18:38:38 -04:00
import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt
--------------------------------------------------------------------------------
-- | Executables
myScreenlock :: String
myScreenlock = "screenlock"
myOptimusManager :: String
myOptimusManager = "optimus-manager"
2022-07-02 17:09:21 -04:00
myPrimeOffload :: String
myPrimeOffload = "prime-offload"
2020-03-28 18:38:38 -04:00
--------------------------------------------------------------------------------
-- | Core commands
runScreenLock :: SometimesX
2022-07-02 17:09:21 -04:00
runScreenLock = sometimesExe "screen locker" "i3lock script" False myScreenlock
2020-03-28 18:38:38 -04:00
runPowerOff :: X ()
runPowerOff = spawn "systemctl poweroff"
runSuspend :: X ()
runSuspend = spawn "systemctl suspend"
runHibernate :: X ()
runHibernate = spawn "systemctl hibernate"
runReboot :: X ()
runReboot = spawn "systemctl reboot"
--------------------------------------------------------------------------------
2022-07-03 01:11:32 -04:00
-- | Autolock
runAutolock :: Sometimes (IO ProcessHandle)
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
where
tree = And_ (Only_ $ sysExe "xss-lock") (Only_ $ IOSometimes_ runScreenLock)
cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"]
--------------------------------------------------------------------------------
2022-07-02 17:09:21 -04:00
-- | 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") $ fontTreeAlt T.defFontFamily
2020-03-28 18:38:38 -04:00
2021-11-20 01:15:04 -05:00
-- TODO doesn't this need to also lock the screen?
2022-07-02 17:09:21 -04:00
runSuspendPrompt :: SometimesX
runSuspendPrompt = sometimesPrompt "suspend prompt" suspendPrompt
2020-03-28 18:38:38 -04:00
2022-07-02 17:09:21 -04:00
runQuitPrompt :: SometimesX
runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
2020-03-28 18:38:38 -04:00
--------------------------------------------------------------------------------
-- | Nvidia Optimus
-- TODO for some reason the screen never wakes up after suspend when
-- the nvidia card is up, so block suspend if nvidia card is running
-- and warn user
isUsingNvidia :: IO Bool
isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
2021-11-19 00:35:54 -05:00
hasBattery :: IO (Maybe String)
hasBattery = do
ps <- fromRight [] <$> tryIOError (listDirectory syspath)
ts <- mapM readType ps
2021-11-19 00:35:54 -05:00
return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
where
readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
syspath = "/sys/class/power_supply"
2022-07-02 17:09:21 -04:00
runOptimusPrompt' :: T.FontBuilder -> X ()
runOptimusPrompt' fb = do
2020-03-28 18:38:38 -04:00
nvidiaOn <- io isUsingNvidia
switch $ if nvidiaOn then "integrated" else "nvidia"
2020-03-28 18:38:38 -04:00
where
2022-07-02 17:09:21 -04:00
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
2020-03-28 18:38:38 -04:00
prompt mode = "gpu switch to " ++ mode ++ "?"
cmd mode = spawn $
2022-07-02 17:09:21 -04:00
myPrimeOffload
#!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad"
2020-03-28 18:38:38 -04:00
runOptimusPrompt :: SometimesX
2022-07-02 17:09:21 -04:00
runOptimusPrompt = Sometimes "graphics switcher" [s]
where
s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error }
r = IORoot runOptimusPrompt' t
t = And1 (fontTreeAlt T.defFontFamily)
2022-07-02 17:09:21 -04:00
$ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload)
2020-03-28 18:38:38 -04:00
--------------------------------------------------------------------------------
-- | Universal power prompt
2021-11-21 10:26:28 -05:00
data PowerMaybeAction = Poweroff
2020-03-28 18:38:38 -04:00
| Shutdown
| Hibernate
| Reboot
deriving (Eq)
2021-11-21 10:26:28 -05:00
instance Enum PowerMaybeAction where
2020-03-28 18:38:38 -04:00
toEnum 0 = Poweroff
toEnum 1 = Shutdown
toEnum 2 = Hibernate
toEnum 3 = Reboot
2021-11-21 10:26:28 -05:00
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
2020-03-28 18:38:38 -04:00
fromEnum Poweroff = 0
fromEnum Shutdown = 1
fromEnum Hibernate = 2
fromEnum Reboot = 3
data PowerPrompt = PowerPrompt
instance XPrompt PowerPrompt where
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
2022-07-03 18:23:32 -04:00
runPowerPrompt :: SometimesX
runPowerPrompt = Sometimes "power prompt" [sf]
where
2022-07-03 18:23:32 -04:00
sf = Subfeature withLock "prompt with lock" Error
2022-07-02 17:09:21 -04:00
withLock = IORoot (uncurry powerPrompt) tree
tree = And12 (,) lockTree (fontTreeAlt T.defFontFamily)
2022-07-03 18:23:32 -04:00
lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
2022-07-02 17:09:21 -04:00
powerPrompt :: X () -> T.FontBuilder -> X ()
powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
2020-03-28 18:38:38 -04:00
where
2022-03-05 18:18:16 -05:00
comp = mkComplFunFromList theme []
2022-07-02 17:09:21 -04:00
theme = (T.promptTheme fb) { promptKeymap = keymap }
2020-03-28 18:38:38 -04:00
keymap = M.fromList
$ ((controlMask, xK_g), quit) :
map (first $ (,) 0)
2021-11-21 10:26:28 -05:00
[ (xK_p, sendMaybeAction Poweroff)
, (xK_s, sendMaybeAction Shutdown)
, (xK_h, sendMaybeAction Hibernate)
, (xK_r, sendMaybeAction Reboot)
2020-03-28 18:38:38 -04:00
, (xK_Return, quit)
, (xK_Escape, quit)
]
2021-11-21 10:26:28 -05:00
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeMaybeAction a = case toEnum $ read a of
2020-03-28 18:38:38 -04:00
Poweroff -> runPowerOff
2021-11-19 22:42:19 -05:00
Shutdown -> lock >> runSuspend
Hibernate -> lock >> runHibernate
2020-03-28 18:38:38 -04:00
Reboot -> runReboot