From 96b7253c9baf7e89e5607a28e20511a8cbaa3b97 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 28 Mar 2020 18:38:38 -0400 Subject: [PATCH] REF move code to separate submodules --- bin/xmonad.hs | 235 ++++-------------------------------------------- lib/ACPI.hs | 17 ++++ lib/Capture.hs | 35 ++++++++ lib/General.hs | 106 ++++++++++++++++++++++ lib/Power.hs | 126 ++++++++++++++++++++++++++ lib/Shell.hs | 5 +- my-xmonad.cabal | 5 +- 7 files changed, 308 insertions(+), 221 deletions(-) create mode 100644 lib/Capture.hs create mode 100644 lib/General.hs create mode 100644 lib/Power.hs diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 41d29b8..c86ee56 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -1,27 +1,23 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} module Main (main) where +import Capture +import General import Internal.DMenu +import Power import ACPI import DBus.Common -import DBus.IntelBacklight -import DBus.Screensaver -import Notify import Process import SendXMsg import Shell import qualified Theme as T import WorkspaceMon -import Control.Arrow (first) import Control.Concurrent -import Control.Monad (forM_, mapM_, void, when) import Data.List (isPrefixOf, sortBy, sortOn) -import qualified Data.Map.Lazy as M import Data.Maybe (isJust) import Data.Monoid (All (..)) @@ -29,20 +25,15 @@ import Graphics.X11.Types import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Extras -import System.Directory -import System.Exit import System.IO import System.Process -import Text.Read (readMaybe) - import Xmobar.Common import XMonad import XMonad.Actions.CopyWindow import XMonad.Actions.CycleWS import XMonad.Actions.PhysicalScreens -import XMonad.Actions.Volume import XMonad.Actions.Warp import XMonad.Hooks.EwmhDesktops import XMonad.Hooks.ManageDocks @@ -52,8 +43,6 @@ import XMonad.Layout.NoFrillsDecoration import XMonad.Layout.PerWorkspace import XMonad.Layout.Renamed import XMonad.Layout.Tabbed -import XMonad.Prompt -import XMonad.Prompt.ConfirmPrompt import qualified XMonad.StackSet as W import XMonad.Util.EZConfig import XMonad.Util.NamedActions @@ -86,14 +75,20 @@ main = do , focusedBorderColor = T.selectedBordersColor } --- Data structure to hold the dbus client, threadIDs, and process IDs started --- outside the main Xmonad thread. Maybe I could use a ReaderT here but I'm lazy +-- | Multithread setup + data ThreadState = ThreadState { client :: Client , childPIDs :: [Pid] , childHandles :: [Handle] } +-- TODO shouldn't this be run by a signal handler? +runCleanup :: ThreadState -> X () +runCleanup ts = io $ do + mapM_ killPID $ childPIDs ts + stopXMonadService $ client ts + -- | Startuphook configuration myStartupHook :: X () @@ -242,215 +237,17 @@ manageApps = composeOne $ concatMap dwHook allDWs ++ -- | Eventhook configuration myEventHook :: Event -> X All -myEventHook = monitorEventHook <+> docksEventHook <+> handleEventHook def +myEventHook = xMsgEventHook <+> docksEventHook <+> handleEventHook def -monitorEventHook :: Event -> X All -monitorEventHook ClientMessageEvent { ev_message_type = t, ev_data = d } +xMsgEventHook :: Event -> X All +xMsgEventHook ClientMessageEvent { ev_message_type = t, ev_data = d } | t == bITMAP = do let (xtype, tag) = splitXMsg d case xtype of Workspace -> removeDynamicWorkspace tag - ACPI -> do - let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent - forM_ acpiTag $ \case - Power -> runPowerPrompt - Sleep -> confirmPrompt T.promptTheme "suspend?" runSuspend - LidClose -> do - status <- io isDischarging - forM_ status $ \s -> runScreenLock >> when s runSuspend + ACPI -> handleACPI tag return (All True) -monitorEventHook _ = return (All True) - -data PowerPrompt = PowerPrompt - -instance XPrompt PowerPrompt where - showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" - -runScreenLock :: X () -runScreenLock = spawn "screenlock" - -runPowerOff :: X () -runPowerOff = spawn "systemctl poweroff" - -runSuspend :: X () -runSuspend = spawn "systemctl suspend" - -runHibernate :: X () -runHibernate = spawn "systemctl hibernate" - -runReboot :: X () -runReboot = spawn "systemctl reboot" - -data PowerAction = Poweroff - | Shutdown - | Hibernate - | Reboot - deriving (Eq) - -instance Enum PowerAction where - toEnum 0 = Poweroff - toEnum 1 = Shutdown - toEnum 2 = Hibernate - toEnum 3 = Reboot - toEnum _ = errorWithoutStackTrace "Main.Enum.PowerAction.toEnum: bad argument" - - fromEnum Poweroff = 0 - fromEnum Shutdown = 1 - fromEnum Hibernate = 2 - fromEnum Reboot = 3 - -runPowerPrompt :: X () -runPowerPrompt = mkXPrompt PowerPrompt theme comp executeAction - where - comp = mkComplFunFromList [] - theme = T.promptTheme { promptKeymap = keymap } - keymap = M.fromList - $ ((controlMask, xK_g), quit) : - map (first $ (,) 0) - [ (xK_p, sendAction Poweroff) - , (xK_s, sendAction Shutdown) - , (xK_h, sendAction Hibernate) - , (xK_r, sendAction Reboot) - , (xK_Return, quit) - , (xK_Escape, quit) - ] - sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True - executeAction a = case toEnum $ read a of - Poweroff -> runPowerOff - Shutdown -> runScreenLock >> runSuspend - Hibernate -> runScreenLock >> runHibernate - Reboot -> runReboot - -runQuitPrompt :: X () -runQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess - --- 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" - -runOptimusPrompt :: X () -runOptimusPrompt = do - nvidiaOn <- io isUsingNvidia - switch $ if nvidiaOn then "intel" else "nvidia" - where - switch mode = confirmPrompt T.promptTheme (prompt mode) (cmd mode) - prompt mode = "gpu switch to " ++ mode ++ "?" - cmd mode = spawnCmd "optimus-manager" - ["--switch", mode, "--no-confirm"] - >> io exitSuccess - --- shell commands - -myTerm :: String -myTerm = "urxvt" - -runTerm :: X () -runTerm = spawn myTerm - -runCalc :: X () -runCalc = spawnCmd myTerm ["-e", "R"] - -runBrowser :: X () -runBrowser = spawn "brave" - -runEditor :: X () -runEditor = spawnCmd "emacsclient" - ["-c", "-e", "\"(select-frame-set-input-focus (selected-frame))\""] - -runFileManager :: X () -runFileManager = spawn "pcmanfm" - -getScreenshotDir :: IO FilePath -getScreenshotDir = do - h <- getHomeDirectory - return $ h ++ "/Pictures/screenshots" - -runFlameshot :: String -> X () -runFlameshot mode = do - ssDir <- io getScreenshotDir - spawnCmd "flameshot" $ mode : ["-p", ssDir] - --- TODO this will steal focus from the current window (and puts it --- in the root window?) ...need to fix -runAreaCapture :: X () -runAreaCapture = runFlameshot "gui" - --- myWindowCap = "screencap -w" --external script - -runScreenCapture :: X () -runScreenCapture = runFlameshot "screen" - -runDesktopCapture :: X () -runDesktopCapture = runFlameshot "full" - -runCleanup :: ThreadState -> X () -runCleanup ts = io $ do - mapM_ killPID $ childPIDs ts - stopXMonadService $ client ts - -runRestart :: X () -runRestart = restart "xmonad" True - -runRecompile :: X () -runRecompile = do - -- assume that the conf directory contains a valid stack project - -- TODO this is hacky AF - confDir <- getXMonadDir - spawn $ cmd confDir - where - cmd c = fmtCmd "cd" [c] - #!&& fmtCmd "stack" ["install", ":xmonad"] - #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" } - #!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" } - -myMultimediaCtl :: String -myMultimediaCtl = "playerctl" - -runTogglePlay :: X () -runTogglePlay = spawnCmd myMultimediaCtl ["play-pause"] - -runPrevTrack :: X () -runPrevTrack = spawnCmd myMultimediaCtl ["previous"] - -runNextTrack :: X () -runNextTrack = spawnCmd myMultimediaCtl ["next"] - -runStopPlay :: X () -runStopPlay = spawnCmd myMultimediaCtl ["stop"] - -runVolumeDown :: X () -runVolumeDown = void (lowerVolume 2) - -runVolumeUp :: X () -runVolumeUp = void (raiseVolume 2) - -runVolumeMute :: X () -runVolumeMute = void toggleMute - -runToggleBluetooth :: X () -runToggleBluetooth = spawn - $ "bluetoothctl show | grep -q \"Powered: no\"" - #!&& "a=on" - #!|| "a=off" - #!>> fmtCmd "bluetoothctl" ["power", "$a", ">", "/dev/null"] - #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } - -runIncBacklight :: X () -runIncBacklight = io $ void callIncBrightness - -runDecBacklight :: X () -runDecBacklight = io $ void callDecBrightness - -runMinBacklight :: X () -runMinBacklight = io $ void callMinBrightness - -runMaxBacklight :: X () -runMaxBacklight = io $ void callMaxBrightness - -runToggleDPMS :: X () -runToggleDPMS = io $ void callToggle +xMsgEventHook _ = return (All True) -- | Keymap configuration diff --git a/lib/ACPI.hs b/lib/ACPI.hs index ac49157..1e249f6 100644 --- a/lib/ACPI.hs +++ b/lib/ACPI.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module ACPI ( ACPIEvent(..) , isDischarging , runPowermon + , handleACPI ) where +import Power import SendXMsg import Control.Exception @@ -18,6 +21,10 @@ import Data.Connection import System.IO.Streams.Internal as S (read) import System.IO.Streams.UnixSocket +import Text.Read (readMaybe) + +import XMonad.Core + data ACPIEvent = Power | Sleep | LidClose @@ -65,3 +72,13 @@ runPowermon = do readStream s = do out <- S.read s mapM_ sendACPIEvent $ parseLine =<< out + +handleACPI :: String -> X () +handleACPI tag = do + let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent + forM_ acpiTag $ \case + Power -> runPowerPrompt + Sleep -> runSuspendPrompt + LidClose -> do + status <- io isDischarging + forM_ status $ \s -> runScreenLock >> when s runSuspend diff --git a/lib/Capture.hs b/lib/Capture.hs new file mode 100644 index 0000000..b461078 --- /dev/null +++ b/lib/Capture.hs @@ -0,0 +1,35 @@ +module Capture + ( runAreaCapture + , runDesktopCapture + , runScreenCapture + ) +where + +import Shell + +import System.Directory + +import XMonad.Core + +getScreenshotDir :: IO FilePath +getScreenshotDir = do + h <- getHomeDirectory + return $ h ++ "/Pictures/screenshots" + +runFlameshot :: String -> X () +runFlameshot mode = do + ssDir <- io getScreenshotDir + spawnCmd "flameshot" $ mode : ["-p", ssDir] + +-- TODO this will steal focus from the current window (and puts it +-- in the root window?) ...need to fix +runAreaCapture :: X () +runAreaCapture = runFlameshot "gui" + +-- myWindowCap = "screencap -w" --external script + +runScreenCapture :: X () +runScreenCapture = runFlameshot "screen" + +runDesktopCapture :: X () +runDesktopCapture = runFlameshot "full" diff --git a/lib/General.hs b/lib/General.hs new file mode 100644 index 0000000..06789af --- /dev/null +++ b/lib/General.hs @@ -0,0 +1,106 @@ +module General where + +-------------------------------------------------------------------------------- +-- | General commands + +import Notify +import Shell + +import DBus.IntelBacklight +import DBus.Screensaver + +import Control.Monad (void) + +import XMonad.Actions.Volume +import XMonad.Core +import XMonad.Operations + +-------------------------------------------------------------------------------- +-- | Some nice apps + +runTerm :: X () +runTerm = spawn myTerm + +runCalc :: X () +runCalc = spawnCmd myTerm ["-e", "R"] + +runBrowser :: X () +runBrowser = spawn "brave" + +runEditor :: X () +runEditor = spawnCmd "emacsclient" + ["-c", "-e", "\"(select-frame-set-input-focus (selected-frame))\""] + +runFileManager :: X () +runFileManager = spawn "pcmanfm" + +-------------------------------------------------------------------------------- +-- | Multimedia Commands + +myMultimediaCtl :: String +myMultimediaCtl = "playerctl" + +runTogglePlay :: X () +runTogglePlay = spawnCmd myMultimediaCtl ["play-pause"] + +runPrevTrack :: X () +runPrevTrack = spawnCmd myMultimediaCtl ["previous"] + +runNextTrack :: X () +runNextTrack = spawnCmd myMultimediaCtl ["next"] + +runStopPlay :: X () +runStopPlay = spawnCmd myMultimediaCtl ["stop"] + +runVolumeDown :: X () +runVolumeDown = void (lowerVolume 2) + +runVolumeUp :: X () +runVolumeUp = void (raiseVolume 2) + +runVolumeMute :: X () +runVolumeMute = void toggleMute + +-------------------------------------------------------------------------------- +-- | System commands + +runToggleBluetooth :: X () +runToggleBluetooth = spawn + $ "bluetoothctl show | grep -q \"Powered: no\"" + #!&& "a=on" + #!|| "a=off" + #!>> fmtCmd "bluetoothctl" ["power", "$a", ">", "/dev/null"] + #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } + +runIncBacklight :: X () +runIncBacklight = io $ void callIncBrightness + +runDecBacklight :: X () +runDecBacklight = io $ void callDecBrightness + +runMinBacklight :: X () +runMinBacklight = io $ void callMinBrightness + +runMaxBacklight :: X () +runMaxBacklight = io $ void callMaxBrightness + +runToggleDPMS :: X () +runToggleDPMS = io $ void callToggle + +-------------------------------------------------------------------------------- +-- | Configuration commands + +runRestart :: X () +runRestart = restart "xmonad" True + +runRecompile :: X () +runRecompile = do + -- assume that the conf directory contains a valid stack project + -- TODO this is hacky AF + confDir <- getXMonadDir + spawn $ cmd confDir + where + cmd c = fmtCmd "cd" [c] + #!&& fmtCmd "stack" ["install", ":xmonad"] + #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" } + #!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" } diff --git a/lib/Power.hs b/lib/Power.hs new file mode 100644 index 0000000..0d523f1 --- /dev/null +++ b/lib/Power.hs @@ -0,0 +1,126 @@ +module Power + ( runHibernate + , runOptimusPrompt + , runPowerOff + , runPowerPrompt + , runReboot + , runScreenLock + , runSuspend + , runSuspendPrompt + , runQuitPrompt + ) +where + +-------------------------------------------------------------------------------- +-- | Commands for controlling power + +import Shell +import qualified Theme as T + +import Control.Arrow (first) + +import qualified Data.Map as M + +import Graphics.X11.Types + +import XMonad.Core +import XMonad.Prompt +import XMonad.Prompt.ConfirmPrompt + +import System.Directory +import System.Exit + +-------------------------------------------------------------------------------- +-- | Core commands + +runScreenLock :: X () +runScreenLock = spawn "screenlock" + +runPowerOff :: X () +runPowerOff = spawn "systemctl poweroff" + +runSuspend :: X () +runSuspend = spawn "systemctl suspend" + +runHibernate :: X () +runHibernate = spawn "systemctl hibernate" + +runReboot :: X () +runReboot = spawn "systemctl reboot" + +-------------------------------------------------------------------------------- +-- | Confirm prompt wrappers + +runSuspendPrompt :: X () +runSuspendPrompt = confirmPrompt T.promptTheme "suspend?" runSuspend + +runQuitPrompt :: X () +runQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess + +-------------------------------------------------------------------------------- +-- | 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" + +runOptimusPrompt :: X () +runOptimusPrompt = do + nvidiaOn <- io isUsingNvidia + switch $ if nvidiaOn then "intel" else "nvidia" + where + switch mode = confirmPrompt T.promptTheme (prompt mode) (cmd mode) + prompt mode = "gpu switch to " ++ mode ++ "?" + cmd mode = spawnCmd "optimus-manager" + ["--switch", mode, "--no-confirm"] + >> io exitSuccess + +-------------------------------------------------------------------------------- +-- | Universal power prompt + +data PowerAction = Poweroff + | Shutdown + | Hibernate + | Reboot + deriving (Eq) + +instance Enum PowerAction where + toEnum 0 = Poweroff + toEnum 1 = Shutdown + toEnum 2 = Hibernate + toEnum 3 = Reboot + toEnum _ = errorWithoutStackTrace "Main.Enum.PowerAction.toEnum: bad argument" + + 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:" + +runPowerPrompt :: X () +runPowerPrompt = mkXPrompt PowerPrompt theme comp executeAction + where + comp = mkComplFunFromList [] + theme = T.promptTheme { promptKeymap = keymap } + keymap = M.fromList + $ ((controlMask, xK_g), quit) : + map (first $ (,) 0) + [ (xK_p, sendAction Poweroff) + , (xK_s, sendAction Shutdown) + , (xK_h, sendAction Hibernate) + , (xK_r, sendAction Reboot) + , (xK_Return, quit) + , (xK_Escape, quit) + ] + sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True + executeAction a = case toEnum $ read a of + Poweroff -> runPowerOff + Shutdown -> runScreenLock >> runSuspend + Hibernate -> runScreenLock >> runHibernate + Reboot -> runReboot diff --git a/lib/Shell.hs b/lib/Shell.hs index c150698..2f2bda5 100644 --- a/lib/Shell.hs +++ b/lib/Shell.hs @@ -1,6 +1,9 @@ module Shell where -import XMonad +import XMonad + +myTerm :: String +myTerm = "urxvt" fmtCmd :: String -> [String] -> String fmtCmd cmd args = unwords $ cmd : args diff --git a/my-xmonad.cabal b/my-xmonad.cabal index 89d9a79..bb721a3 100644 --- a/my-xmonad.cabal +++ b/my-xmonad.cabal @@ -10,7 +10,10 @@ library , Theme , Notify , Shell + , Power , WorkspaceMon + , Capture + , General , Internal.DMenu , DBus.Common , DBus.IntelBacklight @@ -37,6 +40,7 @@ library , directory >= 1.3.3.0 , process >= 1.6.5.0 , xmobar + , xmonad-extras >= 0.15.2 , xmonad >= 0.13 , xmonad-contrib >= 0.13 ghc-options: -Wall -Werror -fno-warn-missing-signatures @@ -53,7 +57,6 @@ executable xmonad , unix >= 2.7.2.2 , xmonad >= 0.13 , xmonad-contrib >= 0.13 - , xmonad-extras >= 0.15.2 default-language: Haskell2010 ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded