From 4c57dc73da6d8b0db8f84671619d11059da31775 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 20 Mar 2020 16:10:03 -0600 Subject: Added ability to cycle linearly through workspaces with win-N and win-P --- src/Internal/Keys.hs | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs index 4828f27..3e7e054 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE RankNTypes #-} module Internal.Keys where +import Data.Maybe (isJust) import Debug.Trace import Control.Applicative import Prelude hiding ((!!)) @@ -32,6 +34,8 @@ applyKeys config@(XConfig {modMask = modm}) = do withWindowNavigation (xK_k, xK_h, xK_j, xK_l) $ config { keys = ks } +newtype Selector = Selector (forall a. (Eq a) => a -> [a] -> a) + data WinPrompt = WinPrompt instance XPrompt WinPrompt where @@ -71,6 +75,25 @@ newKeys = swapSc f t (W.Screen ws a b) = W.Screen (swapWs f t ws) a b + relativeWorkspaceShift :: Selector -> X () + relativeWorkspaceShift (Selector selector) = do + windows $ \ss -> do + let tags = sort $ (W.tag <$> filter (isJust . W.stack) (W.workspaces ss)) + from = W.tag $ W.workspace $ W.current ss + to = selector from tags + + W.greedyView to ss + + nextWorkspace = Selector select + where select n (x:y:xs) | n == x = y + select n (x:xs) = select n xs + select n _ = n + + prevWorkspace = Selector select + where select n (x:y:xs) | n == y = x + select n (x:xs) = select n xs + select n _ = n + swapWorkspace :: Char -> X () swapWorkspace toChar = do windows $ \ss -> do @@ -154,6 +177,9 @@ newKeys = , ((modm, xK_space), sendMessage NextLayout) + , ((modm, xK_n), relativeWorkspaceShift nextWorkspace) + , ((modm, xK_p), relativeWorkspaceShift prevWorkspace) + , ((modm, xK_q), spawn "xmonad --recompile && xmonad --restart") , ((modm, xK_z), sendMessage ToggleZoom) -- cgit From e57b0a3a870d1f9688491b17afbd5a9d994ad343 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 26 Mar 2020 16:21:29 -0600 Subject: Move logic from Keys.hs to Lib.hs. Added an monad XPlus that holds extra state with the MarkContext, etc. This should make it easier to handle as more and more state accrues over time. --- src/Internal/Keys.hs | 150 ++++++++++---------------------------------------- src/Internal/Lib.hs | 137 +++++++++++++++++++++++++++++++++++++++++++++ src/Internal/XPlus.hs | 53 ++++++++++++++++++ 3 files changed, 219 insertions(+), 121 deletions(-) create mode 100644 src/Internal/Lib.hs create mode 100644 src/Internal/XPlus.hs diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs index 3e7e054..902e743 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes #-} module Internal.Keys where +import Internal.XPlus import Data.Maybe (isJust) import Debug.Trace import Control.Applicative @@ -26,6 +27,8 @@ import XMonad.Util.Scratchpad import qualified Data.Map as Map import qualified XMonad.StackSet as W +import Internal.Lib + type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) applyKeys :: XConfig l -> IO (XConfig l) @@ -34,119 +37,10 @@ applyKeys config@(XConfig {modMask = modm}) = do withWindowNavigation (xK_k, xK_h, xK_j, xK_l) $ config { keys = ks } -newtype Selector = Selector (forall a. (Eq a) => a -> [a] -> a) - -data WinPrompt = WinPrompt - -instance XPrompt WinPrompt where - showXPrompt _ = "[Window] " - commandToComplete _ = id - -getHorizontallyOrderedScreens :: - W.StackSet wid l a ScreenId ScreenDetail -> - [W.Screen wid l a ScreenId ScreenDetail] --- ^ Returns a list of screens ordered from leftmost to rightmost. -getHorizontallyOrderedScreens windowSet = - flip sortBy screens $ \sc1 sc2 -> - let (SD (Rectangle x1 _ _ _)) = W.screenDetail sc1 - (SD (Rectangle x2 _ _ _)) = W.screenDetail sc2 - in x1 `compare` x2 - where - screens = W.current windowSet : W.visible windowSet - newKeys :: IO (KeyMap l) newKeys = withNewMarkContext $ \markContext -> return $ \config@(XConfig {modMask = modm}) -> - let workspacesByInt = - Map.fromList $ - zip ['1'..] (XMonad.workspaces config) - - gotoWorkspace ch = do - saveLastMark markContext - windows $ W.greedyView $ return ch - - shiftToWorkspace ch = do - windows $ W.shift $ return ch - - swapWs f t (W.Workspace t' l s) | t' == f = W.Workspace t l s - swapWs f t (W.Workspace t' l s) | t' == t = W.Workspace f l s - swapWs _ _ ws = ws - - swapSc f t (W.Screen ws a b) = W.Screen (swapWs f t ws) a b - - relativeWorkspaceShift :: Selector -> X () - relativeWorkspaceShift (Selector selector) = do - windows $ \ss -> do - let tags = sort $ (W.tag <$> filter (isJust . W.stack) (W.workspaces ss)) - from = W.tag $ W.workspace $ W.current ss - to = selector from tags - - W.greedyView to ss - - nextWorkspace = Selector select - where select n (x:y:xs) | n == x = y - select n (x:xs) = select n xs - select n _ = n - - prevWorkspace = Selector select - where select n (x:y:xs) | n == y = x - select n (x:xs) = select n xs - select n _ = n - - swapWorkspace :: Char -> X () - swapWorkspace toChar = do - windows $ \ss -> do - let from = W.tag $ W.workspace $ W.current ss - to = [toChar] in - (W.StackSet (swapSc from to $ W.current ss) - (map (swapSc from to) $ W.visible ss) - (map (swapWs from to) $ W.hidden ss) - (W.floating ss)) - - fuzzyCompletion s1 s0 = - let ws = filter (not . all isSpace) $ words (map toLower s1) - l0 = map toLower s0 in - all (`isInfixOf`l0) ws - - getString = runQuery $ do - t <- title - a <- appName - return $ - if map toLower a `isInfixOf` map toLower t - then t - else printf "%s - %s" a t - - withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X () - withScreen fn n = do - saveLastMark markContext - windows $ \windowSet -> - case (getHorizontallyOrderedScreens windowSet !! n) of - Nothing -> windowSet - Just screen -> fn (W.tag $ W.workspace screen) windowSet - - windowJump = do - windowTitlesToWinId <- withWindowSet $ \ss -> - Map.fromList <$> - mapM (\wid -> (,) <$> getString wid <*> return wid) - (W.allWindows ss) - - mkXPrompt - WinPrompt - xpConfig - (\input -> do - return $ filter (fuzzyCompletion input) (Map.keys windowTitlesToWinId)) $ \str -> do - saveLastMark markContext - case Map.lookup str windowTitlesToWinId of - Just w -> focus w - Nothing -> - case filter (fuzzyCompletion str) (Map.keys windowTitlesToWinId) of - [s] -> - mapM_ focus (Map.lookup s windowTitlesToWinId) - _ -> return () - - in - Map.fromList [ ((modm, xK_F12), (void $ spawn "spotify-control next")) , ((modm, xK_F11), (void $ spawn "spotify-control prev")) @@ -160,15 +54,24 @@ newKeys = , ((modm .|. shiftMask, xK_t), withFocused $ windows . W.sink) , ((modm, xK_t), (void $ spawn (terminal config))) , ((modm, xK_m), (submap $ mapAlpha modm (markCurrentWindow markContext))) - , ((modm, xK_w), windowJump) + , ((modm, xK_w), runXPlus markContext config windowJump) , ((modm, xK_apostrophe), (submap $ Map.insert (modm, xK_apostrophe) (jumpToLast markContext) (mapAlpha modm (jumpToMark markContext)))) - , ((modm, xK_g), (submap $ mapNumbersAndAlpha 0 gotoWorkspace)) - , ((modm .|. shiftMask, xK_g), (submap $ mapNumbersAndAlpha 0 shiftToWorkspace)) - , ((modm .|. shiftMask .|. mod1Mask, xK_g), (submap $ mapNumbersAndAlpha 0 swapWorkspace)) + + , ((modm, xK_g), (submap $ + mapNumbersAndAlpha 0 ( + runXPlus markContext config . gotoWorkspace))) + + , ((modm .|. shiftMask, xK_g), (submap $ + mapNumbersAndAlpha 0 ( + runXPlus markContext config . shiftToWorkspace))) + + , ((modm .|. shiftMask .|. mod1Mask, xK_g), (submap $ + mapNumbersAndAlpha 0 ( + runXPlus markContext config . swapWorkspace))) , ((modm .|. shiftMask, xK_bracketleft), sendMessage (IncMasterN (-1))) , ((modm .|. shiftMask, xK_bracketright), sendMessage (IncMasterN 1)) @@ -177,8 +80,8 @@ newKeys = , ((modm, xK_space), sendMessage NextLayout) - , ((modm, xK_n), relativeWorkspaceShift nextWorkspace) - , ((modm, xK_p), relativeWorkspaceShift prevWorkspace) + , ((modm, xK_n), relativeWorkspaceShift next) + , ((modm, xK_p), relativeWorkspaceShift prev) , ((modm, xK_q), spawn "xmonad --recompile && xmonad --restart") , ((modm, xK_z), sendMessage ToggleZoom) @@ -186,13 +89,18 @@ newKeys = , ((modm, xK_Tab), windows W.focusDown) , ((modm .|. shiftMask, xK_Tab), windows W.focusUp) - , ((modm, xK_a), withScreen W.view 0) - , ((modm, xK_o), withScreen W.view 1) - , ((modm, xK_e), withScreen W.view 2) + , ((modm, xK_a), runXPlus markContext config (withScreen W.view 0)) + , ((modm, xK_o), runXPlus markContext config (withScreen W.view 1)) + , ((modm, xK_e), runXPlus markContext config (withScreen W.view 2)) + + , ((modm .|. shiftMask, xK_a), runXPlus markContext config (withScreen W.shift 0)) + , ((modm .|. shiftMask, xK_o), runXPlus markContext config (withScreen W.shift 1)) + , ((modm .|. shiftMask, xK_e), runXPlus markContext config (withScreen W.shift 2)) - , ((modm .|. shiftMask, xK_a), withScreen W.shift 0) - , ((modm .|. shiftMask, xK_o), withScreen W.shift 1) - , ((modm .|. shiftMask, xK_e), withScreen W.shift 2) + -- Buttons programmed on my mouse. + , ((shiftMask, xK_F1), withFocused $ windows . W.sink) + , ((shiftMask, xK_F2), kill) + , ((shiftMask, xK_F3), kill) ] mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> Map (KeyMask, KeySym) (X ()) diff --git a/src/Internal/Lib.hs b/src/Internal/Lib.hs new file mode 100644 index 0000000..e0b78c5 --- /dev/null +++ b/src/Internal/Lib.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE RankNTypes #-} +module Internal.Lib where + +import Prelude hiding ((!!)) + +import XMonad.Prompt +import XMonad.Prompt.Input +import XMonad.Prompt.Shell + +import Internal.PromptConfig + +import Data.Char +import Data.List hiding ((!!)) +import Data.List.Safe ((!!)) +import Data.Maybe +import Internal.Marking +import Internal.XPlus +import Text.Printf +import XMonad hiding (workspaces, Screen) +import XMonad.StackSet hiding (filter, focus) +import qualified Data.Map as Map + +type WorkspaceName = Char +newtype Selector = Selector (forall a. (Eq a) => a -> [a] -> a) + +data WinPrompt = WinPrompt + +instance XPrompt WinPrompt where + showXPrompt _ = "[Window] " + commandToComplete _ = id + +getHorizontallyOrderedScreens :: + StackSet wid l a ScreenId ScreenDetail -> + [Screen wid l a ScreenId ScreenDetail] +-- ^ Returns a list of screens ordered from leftmost to rightmost. +getHorizontallyOrderedScreens windowSet = + flip sortBy screens $ \sc1 sc2 -> + let (SD (Rectangle x1 _ _ _)) = screenDetail sc1 + (SD (Rectangle x2 _ _ _)) = screenDetail sc2 + in x1 `compare` x2 + where + screens = current windowSet : visible windowSet + + +gotoWorkspace :: WorkspaceName -> XPlus l () +gotoWorkspace ch = do + mc <- getMarkContext + liftXPlus $ do + saveLastMark mc + windows $ greedyView $ return ch + +shiftToWorkspace :: WorkspaceName -> XPlus l () +shiftToWorkspace = liftXPlus . windows . shift . return + +swapWorkspace :: WorkspaceName -> XPlus l () +swapWorkspace toWorkspaceName = liftXPlus $ do + windows $ \ss -> do + let fromWorkspace = tag $ workspace $ current ss + toWorkspace = [toWorkspaceName] in + (StackSet (swapSc fromWorkspace toWorkspace $ current ss) + (map (swapSc fromWorkspace toWorkspace) $ visible ss) + (map (swapWs fromWorkspace toWorkspace) $ hidden ss) + (floating ss)) + where + swapSc fromWorkspace toWorkspace (Screen ws a b) = + Screen (swapWs fromWorkspace toWorkspace ws) a b + + swapWs fromWorkspace toWorkspace ws@(Workspace t' l s) + | t' == fromWorkspace = Workspace toWorkspace l s + | t' == toWorkspace = Workspace fromWorkspace l s + | otherwise = ws + +fuzzyCompletion :: String -> String -> Bool +fuzzyCompletion str0 str1 = + all (`isInfixOf`l0) ws + where + ws = filter (not . all isSpace) $ words (map toLower str0) + l0 = map toLower str1 + +getString :: Window -> X String +getString = runQuery $ do + t <- title + a <- appName + return $ + if map toLower a `isInfixOf` map toLower t + then t + else printf "%s - %s" t a + +relativeWorkspaceShift :: Selector -> X () +relativeWorkspaceShift (Selector selector) = do + windows $ \ss -> + let tags = sort $ (tag <$> filter (isJust . stack) (workspaces ss)) + from = tag $ workspace $ current ss + to = selector from tags + in greedyView to ss + +next :: Selector +next = Selector $ \a l -> select a l l + where select n (x:y:xs) _ | n == x = y + select n [x] (y:_) | n == x = y + select n (x:xs) orig = select n xs orig + select n _ _ = n + +prev :: Selector +prev = Selector $ \a l -> + let (Selector fn) = next in fn a (reverse l) + +withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> XPlus l () +withScreen fn n = do + markContext <- getMarkContext + + liftXPlus $ + windows $ \windowSet -> + case (getHorizontallyOrderedScreens windowSet !! n) of + Nothing -> windowSet + Just screen -> fn (tag $ workspace screen) windowSet + +windowJump :: XPlus l () +windowJump = do + markContext <- getMarkContext + + liftXPlus $ do + windowTitlesToWinId <- withWindowSet $ \ss -> + Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) + + mkXPrompt + WinPrompt + xpConfig + (\input -> return $ filter (fuzzyCompletion input) (Map.keys windowTitlesToWinId)) $ + \str -> do + saveLastMark markContext + case Map.lookup str windowTitlesToWinId of + Just w -> focus w + Nothing -> + case filter (fuzzyCompletion str) (Map.keys windowTitlesToWinId) of + [s] -> mapM_ focus (Map.lookup s windowTitlesToWinId) + _ -> return () diff --git a/src/Internal/XPlus.hs b/src/Internal/XPlus.hs new file mode 100644 index 0000000..c546665 --- /dev/null +++ b/src/Internal/XPlus.hs @@ -0,0 +1,53 @@ +module Internal.XPlus where + +import Internal.Marking +import XMonad + +-- The X Monad with additional information. Used for configuring the system. + +data XPlusState l = + XPlusState { + markContext :: MarkContext + , xConfig :: XConfig l + } + +data XPlus l a = XPlus (XPlusState l -> X (a, XPlusState l)) + +instance Functor (XPlus l) where + fmap fn (XPlus xfn) = + XPlus $ \st -> do + (a, b) <- xfn st + return (fn a, b) + +instance Applicative (XPlus l) where + pure = return + (<*>) afn aarg = do + fn <- afn + arg <- aarg + return (fn arg) + +instance Monad (XPlus l) where + -- (>>=) :: XPlus l a -> (a -> XPlus l b) -> XPlus l b + (>>=) (XPlus afn) bfn = do + XPlus $ \s0 -> do + (a, s1) <- afn s0 + let (XPlus xBFn) = bfn a + xBFn s1 + + return x = XPlus $ \s -> return (x, s) + +getXPlusState :: XPlus l (XPlusState l) +getXPlusState = XPlus $ \s -> return (s, s) + +getXConfig :: XPlus l (XConfig l) +getXConfig = xConfig <$> getXPlusState + +getMarkContext :: XPlus l MarkContext +getMarkContext = markContext <$> getXPlusState + +runXPlus :: MarkContext -> XConfig l -> XPlus l a -> X a +runXPlus markCtx cfg (XPlus fn) = do + fst <$> fn (XPlusState markCtx cfg) + +liftXPlus :: X a -> XPlus l a +liftXPlus xa = XPlus $ \s -> (\a -> (a, s)) <$> xa -- cgit From 63e1d3b9b8685ea77cb488844dddb59a6858c39d Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 26 Mar 2020 16:48:01 -0600 Subject: Add some bindings for the other buttons on the mouse --- src/Internal/Keys.hs | 34 +++++++++++++++++++++++++--------- 1 file changed, 25 insertions(+), 9 deletions(-) diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs index 902e743..83d2e08 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -32,14 +32,30 @@ import Internal.Lib type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) applyKeys :: XConfig l -> IO (XConfig l) -applyKeys config@(XConfig {modMask = modm}) = do - ks <- newKeys - withWindowNavigation (xK_k, xK_h, xK_j, xK_l) $ - config { keys = ks } - -newKeys :: IO (KeyMap l) -newKeys = - withNewMarkContext $ \markContext -> +applyKeys config@(XConfig {modMask = modm}) = + withNewMarkContext $ \markContext -> do + ks <- newKeys markContext + ms <- newMouse markContext + withWindowNavigation (xK_k, xK_h, xK_j, xK_l) $ + config { keys = ks, mouseBindings = ms } + +newMouse :: MarkContext -> IO (XConfig l -> Map (KeyMask, Button) (Window -> X ())) +newMouse markContext = + return $ \config@(XConfig {modMask = modm}) -> + Map.fromList [ + ((modm, button1), \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster) + , ((modm, button2), windows . (W.shiftMaster .) . W.focusWindow) + , ((modm, button3), \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster) + + , ((modm, 6), const (relativeWorkspaceShift prev)) + , ((modm, 7), const (relativeWorkspaceShift next)) + + , ((modm, 8), const (relativeWorkspaceShift prev)) + , ((modm, 9), const (relativeWorkspaceShift next)) + ] + +newKeys :: MarkContext -> IO (KeyMap l) +newKeys markContext = return $ \config@(XConfig {modMask = modm}) -> Map.fromList [ ((modm, xK_F12), (void $ spawn "spotify-control next")) @@ -99,7 +115,7 @@ newKeys = -- Buttons programmed on my mouse. , ((shiftMask, xK_F1), withFocused $ windows . W.sink) - , ((shiftMask, xK_F2), kill) + , ((shiftMask, xK_F2), sendMessage ToggleZoom) , ((shiftMask, xK_F3), kill) ] -- cgit From 475a99a72e43a3ebd8c5761d67309f5ac9d90e6d Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 7 Apr 2020 10:05:36 -0600 Subject: Add the ability to swap screens using Mod4-Mod1-aoe --- src/Internal/Keys.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs index 83d2e08..75a1de9 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -113,6 +113,10 @@ newKeys markContext = , ((modm .|. shiftMask, xK_o), runXPlus markContext config (withScreen W.shift 1)) , ((modm .|. shiftMask, xK_e), runXPlus markContext config (withScreen W.shift 2)) + , ((modm .|. mod1Mask, xK_a), runXPlus markContext config (withScreen W.greedyView 0)) + , ((modm .|. mod1Mask, xK_o), runXPlus markContext config (withScreen W.greedyView 1)) + , ((modm .|. mod1Mask, xK_e), runXPlus markContext config (withScreen W.greedyView 2)) + -- Buttons programmed on my mouse. , ((shiftMask, xK_F1), withFocused $ windows . W.sink) , ((shiftMask, xK_F2), sendMessage ToggleZoom) -- cgit From b5738a4792ea94f0f754aae4137d87ddc2a0f077 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 22 Apr 2020 11:34:55 -0600 Subject: Change how clicking works. Allow click through on focus and change focus to current window when pressing the mouse macro buttons. --- src/Internal/Keys.hs | 14 +++++++++++--- src/Main.hs | 1 + 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs index 75a1de9..19ff5b5 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -1,6 +1,8 @@ {-# LANGUAGE RankNTypes #-} module Internal.Keys where +import System.Process +import XMonad.Util.Ungrab import Internal.XPlus import Data.Maybe (isJust) import Debug.Trace @@ -54,6 +56,12 @@ newMouse markContext = , ((modm, 9), const (relativeWorkspaceShift next)) ] +click :: X () +click = do + (dpy, root) <- asks $ (,) <$> display <*> theRoot + (_, _, window, _, _, _, _, _) <- io $ queryPointer dpy root + focus window + newKeys :: MarkContext -> IO (KeyMap l) newKeys markContext = return $ \config@(XConfig {modMask = modm}) -> @@ -118,9 +126,9 @@ newKeys markContext = , ((modm .|. mod1Mask, xK_e), runXPlus markContext config (withScreen W.greedyView 2)) -- Buttons programmed on my mouse. - , ((shiftMask, xK_F1), withFocused $ windows . W.sink) - , ((shiftMask, xK_F2), sendMessage ToggleZoom) - , ((shiftMask, xK_F3), kill) + , ((shiftMask, xK_F1), click >> (withFocused $ windows . W.sink)) + , ((shiftMask, xK_F2), click >> sendMessage ToggleZoom) + , ((shiftMask, xK_F3), click >> kill) ] mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> Map (KeyMask, KeySym) (X ()) diff --git a/src/Main.hs b/src/Main.hs index 7522ebc..1d07ef8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -44,6 +44,7 @@ main = do , workspaces = map return (['0'..'9'] ++ ['a'..'z']) , handleEventHook = fullscreenEventHook , focusFollowsMouse = False + , clickJustFocuses = False } let toggleStructsKey XConfig {XMonad.modMask = modMask} = (modMask, xK_b) -- cgit