{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE LambdaCase #-} module Main (main) where import ACPI import SendXMsg import qualified Theme as T import Control.Monad (foldM, mapM_, forM_, void, when) import Data.List (find, sortBy, sortOn) import qualified Data.Map.Lazy as M import Data.Maybe (isJust) import Data.Monoid (All(..)) import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Extras import Graphics.X11.Types import Graphics.X11.Xrandr import Control.Arrow (first) import Control.Exception import System.Directory import System.Exit import System.IO import System.Process (waitForProcess) import System.Process.Internals ( ProcessHandle__(ClosedHandle, OpenHandle) , withProcessHandle , mkProcessHandle) import System.Posix.IO import System.Posix.Process import System.Posix.Signals import System.Posix.Types import Text.Read (readMaybe) import XMonad import XMonad.Actions.CopyWindow import XMonad.Actions.CycleWS import XMonad.Actions.DynamicWorkspaces import XMonad.Actions.PhysicalScreens import XMonad.Actions.Volume -- import XMonad.Config.Desktop import XMonad.Hooks.DynamicLog import XMonad.Hooks.EwmhDesktops import XMonad.Hooks.ManageDocks -- import XMonad.Layout.IndependentScreens import XMonad.Hooks.ManageHelpers -- import XMonad.Layout.BinarySpacePartition (emptyBSP) -- import XMonad.Layout.DragPane -- import XMonad.Layout.IM -- import XMonad.Layout.LayoutCombinators hiding ((|||)) import XMonad.Layout.Named import XMonad.Layout.NoBorders import XMonad.Layout.NoFrillsDecoration import XMonad.Layout.PerWorkspace -- import XMonad.Layout.ResizableTile import XMonad.Layout.Tabbed -- import XMonad.Layout.ToggleLayouts (ToggleLayout(..), toggleLayouts) import XMonad.Prompt import XMonad.Prompt.ConfirmPrompt -- import XMonad.Prompt.XMonad -- import XMonad.Prompt.Shell import XMonad.Util.EZConfig import XMonad.Util.NamedActions import XMonad.Util.Run -- import XMonad.Util.WindowProperties import qualified XMonad.StackSet as W main = do (barPID, h) <- spawnPipe' "xmobar" pwrPID <- spawnPID "powermon" launch $ ewmh $ addDescrKeys' ((myModMask, xK_F1), showKeybindings) (myKeys [pwrPID, barPID]) $ def { terminal = myTerm , modMask = myModMask , layoutHook = myLayouts , manageHook = myManageHook <+> manageDocks <+> manageHook def , handleEventHook = myEventHook <+> docksEventHook <+> handleEventHook def , startupHook = docksStartupHook <+> startupHook def , workspaces = myWorkspaces , logHook = myLoghook h , clickJustFocuses = False , focusFollowsMouse = False } spawnPipe' :: MonadIO m => String -> m (ProcessID, Handle) spawnPipe' x = io $ do (rd, wr) <- createPipe setFdOption wr CloseOnExec True h <- fdToHandle wr hSetBuffering h LineBuffering p <- xfork $ do _ <- dupTo rd stdInput executeFile "/bin/sh" False ["-c", x] Nothing closeFd rd return (p, h) myWorkspaces = map show [1..10 :: Int] myVMWorkspace = "VM" myGimpWorkspace = "GIMP" myLayouts = onWorkspace myVMWorkspace (noBorders Full) -- $ onWorkspace myGimpWorkspace gimpLayout $ tall ||| single ||| full where addTopBar = noFrillsDeco shrinkText T.tabbedTheme tall = named "Tall" $ avoidStruts $ addTopBar $ noBorders $ Tall 1 0.03 0.5 single = named "Tabbed" -- $ addTopBar $ avoidStruts $ noBorders $ tabbedAlways shrinkText T.tabbedTheme full = named "Full" $ noBorders Full -- gimpLayout = named "Gimp Layout" -- $ avoidStruts -- $ (tabbedAlways shrinkText defaultTheme) ****||* Full -- -- $ withIM (11/64) (Or (Title "Toolbox") (Title "Tool Options")) -- -- $ (tabbedAlways shrinkText defaultTheme) -- | Format workspace and layout in loghook -- The format will be like "[<1> 2 3] 4 5 | LAYOUT" where each digit -- is the workspace and LAYOUT is the current layout. Each workspace -- in the brackets is currently visible and the order reflects the -- physical location of each screen. The "<>" is the workspace -- that currently has focus myLoghook h = withWindowSet $ io . hPutStrLn h . myWindowSetXinerama myWindowSetXinerama ws = wsString ++ sep ++ layout where wsString = xmobarColor T.backdropFgColor "" $ onscreen ++ offscreen' offscreen' = if null offscreen then "" else " " ++ offscreen sep = xmobarColor T.backdropFgColor "" " : " onscreen = xmobarColor hilightFgColor hilightBgColor $ wrap " " " " $ unwords $ map (fmtTags . W.tag . W.workspace) . sortBy compareXCoord $ W.current ws : W.visible ws fmtTags t = if t == W.currentTag ws then xmobarColor T.fgColor hilightBgColor t else t offscreen = unwords $ map W.tag . filter (isJust . W.stack) . sortOn W.tag $ W.hidden ws hilightBgColor = "#8fc7ff" hilightFgColor = T.blend' 0.5 hilightBgColor T.fgColor layout = description . W.layout . W.workspace . W.current $ ws compareXCoord s0 s1 = compare x0 x1 where (_, Rectangle x0 _ _ _) = getScreenIdAndRectangle s0 (_, Rectangle x1 _ _ _) = getScreenIdAndRectangle s1 getFocusedScreen :: X Rectangle getFocusedScreen = withWindowSet $ return . screenRect . W.screenDetail . W.current myManageHook = composeOne -- assume virtualbox is not run with the toolbar in fullscreen mode -- as this makes a new window that confusingly must go over the -- actual VM window [ className =? "VirtualBoxVM" -?> doShift myVMWorkspace -- the seafile applet , className =? "Seafile Client" -?> doFloat -- gnucash , (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat -- xsane , className =? "Xsane" -?> doFloat -- all of GIMP , className =? "Gimp" -?> doFloat >> doShift myGimpWorkspace -- , title =? "GIMP Startup" -?> doIgnore -- plots and graphics created by R , className =? "R_x11" -?> doFloat , className =? "mpv" -?> doFloat -- the floating windows created by the brave browser , stringProperty "WM_NAME" =? "Brave" -?> doFloat , (stringProperty "WM_WINDOW_ROLE" =? "pop-up" <&&> className =? "Brave-browser") -?> doFloat -- the dialog windows created by the zotero addon in Google Docs , (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat , isDialog -?> doCenterFloat ] -- This is a giant hack to "listen" for applications that close. Some -- apps like Virtualbox go on their own workspace which is dynamically -- created. But I want said workspace to disappear when the app -- closes. This is actually hard. We can't just listen to -- DestroyWindow events as VBox will "destroy" windows when it -- switches to fullscreen and back. We also can't just monitor the -- process from the window since WindowDestroy events don't have PIDs -- attached to them. Therefore, the hack to make this all work is to -- make a script fire when VirtualBox (and other apps that I want to -- control in this manner) close. This script fires a bogus -- ClientMessage event to the root window. This event will have a -- BITMAP atom (which should do nothing) and a "magic string" in the -- data field that can be intercepted here. When this event is -- registered here, close the dynamic workspaces that are empty. myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d } | t == bITMAP = do let (magic, tag) = splitXMsg d if | magic == magicStringWS -> removeEmptyWorkspaceByTag' tag | magic == acpiMagic -> do let acpiTag = readMaybe tag :: Maybe ACPIEvent forM_ acpiTag $ \case Power -> myPowerPrompt Sleep -> confirmPrompt T.promptTheme "suspend?" runSuspend LidClose -> do status <- io isDischarging forM_ status $ \s -> runScreenLock >> when s runSuspend | otherwise -> return () return (All True) | otherwise = return (All True) myEventHook _ = return (All True) removeEmptyWorkspaceByTag' tag = do -- TODO this function works by first hiding the workspace to be -- removed and then removing it. This won't work if there are no -- other hidden workspaces to take it's place. So, need to scan -- through the list of workspaces and swap the first one that is -- empty with the workspace to be removed. If it actually is empty, -- this will be enough to make it disappear. removeEmptyWorkspaceByTag tag 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" myPowerPrompt :: X () myPowerPrompt = 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 "p") , (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 = 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 fmtCmd :: String -> [String] -> String fmtCmd cmd args = unwords $ cmd : args spawnCmd :: String -> [String] -> X () spawnCmd cmd args = spawn $ fmtCmd cmd args (#!&&) :: String -> String -> String cmdA #!&& cmdB = cmdA ++ " && " ++ cmdB infixr 0 #!&& (#!||) :: String -> String -> String cmdA #!|| cmdB = cmdA ++ " || " ++ cmdB infixr 0 #!|| (#!>>) :: String -> String -> String cmdA #!>> cmdB = cmdA ++ "; " ++ cmdB infixr 0 #!>> magicStringWS :: String magicStringWS = "%%%%%" spawnCmdOwnWS :: String -> [String] -> String -> X () spawnCmdOwnWS cmd args ws = spawn $ fmtCmd cmd args #!&& fmtCmd "xit-event" [magicStringWS, ws] -- spawnKill :: [String] -> X () -- spawnKill = mapM_ (spawn . ("killall " ++)) myTerm :: String myTerm = "urxvt" runTerm :: X () runTerm = spawn myTerm runCalc :: X () runCalc = spawnCmd myTerm ["-e", "R"] myDmenuCmd :: String myDmenuCmd = "rofi" -- TODO this almost works except when a workspace with no windows is -- focuses. In this case, rofi considers the root window to be focused -- and will showup wherever the mouse pointer is. Need a way to get -- the focused workspace and translate that to a monitor number for -- rofi to consume myDmenuArgs :: [String] myDmenuArgs = ["-m", "-4"] -- show rofi with the focused window -- TODO simplify the convoluted garbage heap...to be fair, this is -- going to be ugly simply because rofi uses xrandr and xmonad uses -- xinerama to get screen information...and apparently these index -- differently. However, I'm sure there's a way to condense this code -- to something more sane :( getMonitorName :: X (Maybe String) getMonitorName = do dpy <- asks display root <- asks theRoot res <- io $ xrrGetScreenResourcesCurrent dpy root outputs <- io $ case res of Just res' -> foldM (procOutput dpy res') [] $ xrr_sr_outputs res' Nothing -> return [] (Rectangle sx sy _ _) <- getFocusedScreen return $ case find (\(_, x, y) -> x == fromIntegral sx && y == fromIntegral sy) outputs of Just (name, _, _) -> Just name Nothing -> Nothing where procOutput dpy res acc output = do oi <- xrrGetOutputInfo dpy res output case oi of Just oi' -> procResources dpy res acc oi' Nothing -> return acc procResources dpy res acc oi = do let name = xrr_oi_name oi -- 0 = connected; 1 = disconnected if xrr_oi_connection oi == 0 then do ci <- xrrGetCrtcInfo dpy res $ xrr_oi_crtc oi return $ case ci of Just ci' -> (name, xrr_ci_x ci', xrr_ci_y ci') : acc Nothing -> acc else return acc spawnDmenuCmd :: [String] -> X () spawnDmenuCmd args = do name <- getMonitorName case name of Just n -> spawnCmd myDmenuCmd $ ["-m", n] ++ args Nothing -> io $ putStrLn "fail" runCmdMenu :: X () runCmdMenu = spawnDmenuCmd ["-show", "run"] runAppMenu :: X () runAppMenu = spawnDmenuCmd ["-show", "drun"] runClipMenu :: X () runClipMenu = spawnDmenuCmd [ "-modi", "\"clipboard:greenclip print\"" , "-show", "clipboard" , "-run-command", "'{cmd}'" , "-theme-str", "'#element.selected.normal { background-color: #00c44e; }'" ] runWinMenu :: X () runWinMenu = spawnDmenuCmd ["-show", "window"] runNetMenu :: X () runNetMenu = do name <- getMonitorName case name of Just n -> spawnCmd "networkmanager_dmenu" ["-m", n] Nothing -> io $ putStrLn "fail" -- TODO this command does not know how to take external args runDevMenu :: X () runDevMenu = spawn "rofi-devices" 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" runVBox :: X () runVBox = spawnCmdOwnWS "vbox-start win8raw" [] myVMWorkspace runGimp :: X () runGimp = spawnCmdOwnWS "gimp" [] myGimpWorkspace runCleanup :: [ProcessID] -> X () runCleanup ps = io $ mapM_ killPID ps killPID :: ProcessID -> IO () killPID pID = do h <- mkProcessHandle pID False -- this may fail of the PID does not exist _ <- try $ sendSIGTERM h :: IO (Either IOException ()) -- this may fail if the process exits instantly and the handle -- is destroyed by the time we get to this line (I think?) _ <- try $ waitForProcess h :: IO (Either IOException ExitCode) return () where sendSIGTERM h = withProcessHandle h $ \case OpenHandle _ -> signalProcess sigTERM pID ClosedHandle _ -> return () _ -> return () -- this should never happen 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"] #!&& fmtCmd "notify-send" ["\"compilation succeeded\""] #!|| fmtCmd "notify-send" ["\"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 -- TODO make a formatter for the notify command runToggleBluetooth :: X () runToggleBluetooth = spawn $ "bluetoothctl show | grep -q \"Powered: no\"" #!&& "a=on" #!|| "a=off" #!>> fmtCmd "bluetoothctl" ["power", "$a", ">", "/dev/null"] #!&& fmtCmd "notify-send" ["\"bluetooth powered $a\""] -- TODO write these in haskell runIncBacklight :: X () runIncBacklight = spawnCmd "adj_backlight" ["up"] runDecBacklight :: X () runDecBacklight = spawnCmd "adj_backlight" ["down"] runMinBacklight :: X () runMinBacklight = spawnCmd "adj_backlight" ["min"] runMaxBacklight :: X () runMaxBacklight = spawnCmd "adj_backlight" ["max"] showWorkspace tag = windows $ W.view tag enableDPMS :: X () enableDPMS = spawnCmd "xset" ["s", "on", "+dpms"] disableDPMS :: X () disableDPMS = spawnCmd "xset" ["s", "off", "-dpms"] -- keybindings showKeybindings :: [((KeyMask, KeySym), NamedAction)] -> NamedAction showKeybindings x = addName "Show Keybindings" $ io $ do h <- spawnPipe cmd hPutStr h (unlines $ showKm x) hClose h return () where cmd = fmtCmd myDmenuCmd $ myDmenuArgs ++ [ "-dmenu" , "-p" , "commands" , "-theme-str" , "'#element.selected.normal { background-color: #a200ff; }'" ] myModMask :: KeyMask myModMask = mod4Mask mkNamedSubmap :: XConfig l -> String -> [(String, NamedAction)] -> [((KeyMask, KeySym), NamedAction)] mkNamedSubmap c sectionName bindings = (subtitle sectionName:) $ mkNamedKeymap c bindings -- NOTE: the following bindings are used by dunst: -- "M-~", "M-", "M-S-", "M-S-." myKeys :: [ProcessID] -> XConfig Layout -> [((KeyMask, KeySym), NamedAction)] myKeys hs c = mkNamedSubmap c "Window Layouts" [ ("M-j", addName "focus down" $ windows W.focusDown) , ("M-k", addName "focus up" $ windows W.focusUp) , ("M-m", addName "focus master" $ windows W.focusMaster) , ("M-S-j", addName "swap down" $ windows W.swapDown) , ("M-S-k", addName "swap up" $ windows W.swapUp) , ("M-S-m", addName "swap master" $ windows W.swapMaster) -- TODO this will decrement past 0? , ("M-C-j", addName "remove master window" $ sendMessage (IncMasterN (-1))) , ("M-C-k", addName "add master window" $ sendMessage (IncMasterN 1)) , ("M-", addName "next layout" $ sendMessage NextLayout) , ("M-S-", addName "reset layout" $ setLayout $ XMonad.layoutHook c) , ("M-t", addName "sink tiling" $ withFocused $ windows . W.sink) , ("M--", addName "shrink" $ sendMessage Shrink) , ("M-=", addName "expand" $ sendMessage Expand) ] ++ mkNamedSubmap c "Workspaces" -- NOTE this assumes that there are workspaces bound to numbers ([ (mods ++ show i, addName (msg ++ " " ++ show i) $ windows $ f w) | (w, i) <- zip (XMonad.workspaces c) [1..] :: [(String, Int)] , (mods, msg, f) <- [ ("M-", "switch to workspace", W.view) , ("M-S-", "move client to workspace", W.shift)] ] ++ [ ("M-v", addName "switch to VM workspace" $ showWorkspace myVMWorkspace) , ("M-M1-g", addName "switch to Gimp workspace" $ showWorkspace myGimpWorkspace) ]) ++ mkNamedSubmap c "Screens" [ ("M-l", addName "move up screen" nextScreen) , ("M-h", addName "move down screen" prevScreen) , ("M-C-l", addName "move client up screen" $ shiftNextScreen >> nextScreen) , ("M-C-h", addName "move client down screen" $ shiftPrevScreen >> prevScreen) , ("M-S-l", addName "shift up screen" $ swapNextScreen >> nextScreen) , ("M-S-h", addName "shift down screen" $ swapPrevScreen >> prevScreen) ] ++ mkNamedSubmap c "Actions" [ ("M-q", addName "close window" kill1) , ("M-r", addName "run program" runCmdMenu) , ("M-C-s", addName "capture area" runAreaCapture) , ("M-C-S-s", addName "capture screen" runScreenCapture) , ("M-C-d", addName "capture desktop" runDesktopCapture) -- , ("M-C-S-s", addName "capture focused window" $ spawn myWindowCap) , ("M-", addName "lock screen" runScreenLock) ] ++ mkNamedSubmap c "Launchers" [ ("", addName "select/launch app" runAppMenu) , ("M-g", addName "launch clipboard manager" runClipMenu) , ("M-a", addName "launch network selector" runNetMenu) , ("M-w", addName "launch window selector" runWinMenu) , ("M-u", addName "launch device selector" runDevMenu) , ("M-C-e", addName "launch editor" runEditor) , ("M-C-w", addName "launch browser" runBrowser) , ("M-C-t", addName "launch terminal" runTerm) , ("M-C-q", addName "launch calc" runCalc) , ("M-C-f", addName "launch file manager" runFileManager) , ("M-C-v", addName "launch windows VM" $ runVBox >> appendWorkspace myVMWorkspace) , ("M-C-g", addName "launch GIMP" $ runGimp >> appendWorkspace myGimpWorkspace) ] ++ mkNamedSubmap c "Multimedia" [ ("", addName "toggle play/pause" runTogglePlay) , ("", addName "previous track" runPrevTrack) , ("", addName "next track" runNextTrack) , ("", addName "stop" runStopPlay) , ("", addName "volume down" runVolumeDown) , ("", addName "volume up" runVolumeUp) , ("", addName "volume mute" runVolumeMute) , ("M-C-b", addName "toggle bluetooth" runToggleBluetooth) ] ++ mkNamedSubmap c "System" [ ("M-.", addName "backlight up" runIncBacklight) , ("M-,", addName "backlight down" runDecBacklight) , ("M-M1-,", addName "backlight min" runMinBacklight) , ("M-M1-.", addName "backlight max" runMaxBacklight) , ("M-M1-=", addName "enable screensaver" enableDPMS) , ("M-M1--", addName "disable screensaver" disableDPMS) , ("M-", addName "restart xmonad" $ runCleanup hs >> runRestart) , ("M-S-", addName "recompile xmonad" runRecompile) , ("M-", addName "power menu" myPowerPrompt) , ("M-", addName "quit xmonad" myQuitPrompt) , ("M-", addName "switch gpu" runOptimusPrompt) ]