REF move code to separate submodules

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
+-- | Multithread setup
--- outside the main Xmonad thread. Maybe I could use a ReaderT here but I'm lazy
+
 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
+xMsgEventHook :: Event -> X All
-monitorEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
+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
+      ACPI      -> handleACPI tag
-         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
     return (All True)
-monitorEventHook _ = return (All True)
+xMsgEventHook _ = 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
 
 -- | Keymap configuration
 

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

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"

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" }

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

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

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