From 6d633961451e1ab4747dcf1b5d3a6ea672d4d938 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 18 Apr 2022 01:31:22 -0600 Subject: Add basic language for moving windows around --- src/Rahm/Desktop/Common.hs | 17 ++++++ src/Rahm/Desktop/Keys.hs | 88 +++++++++++----------------- src/Rahm/Desktop/Lang.hs | 127 +++++++++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/Marking.hs | 98 ++++++++++++++++--------------- src/Rahm/Desktop/Submap.hs | 20 ++++--- src/Rahm/Desktop/Workspaces.hs | 24 -------- 6 files changed, 242 insertions(+), 132 deletions(-) create mode 100644 src/Rahm/Desktop/Lang.hs (limited to 'src') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 926d5ff..5a5aecf 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -2,6 +2,7 @@ module Rahm.Desktop.Common where import Prelude hiding ((!!)) +import Control.Monad (void) import Control.Monad.Trans.Maybe import XMonad.Actions.DynamicWorkspaces import XMonad.Util.Run @@ -42,6 +43,14 @@ masterWindow = MaybeT $ withWindowSet $ \ss -> (a:_) -> return $ Just a _ -> return Nothing +windowsInWorkspace :: WorkspaceId -> X [Location] +windowsInWorkspace wid = + withWindowSet $ + return . concatMap (\ws -> + if S.tag ws == wid + then map (Location wid . Just) $ S.integrate' (S.stack ws) + else []) . S.workspaces + data WinPrompt = WinPrompt instance XPrompt WinPrompt where @@ -84,3 +93,11 @@ getCurrentWorkspace = withWindowSet $ \(S.StackSet (S.Screen (S.Workspace t _ _) _ _) _ _ _) -> do return t +getCurrentLocation :: X Location +getCurrentLocation = do + ws <- getCurrentWorkspace + win <- withWindowSet (return . peek) + return (Location ws win) + +runMaybeT_ :: (Monad m) => MaybeT m a -> m () +runMaybeT_ = void . runMaybeT diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 1369a17..23927ef 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -1,5 +1,6 @@ module Rahm.Desktop.Keys (applyKeys) where +import Control.Monad.Trans.Maybe import Control.Applicative import Control.Monad import Control.Monad.Fix (fix) @@ -11,7 +12,7 @@ import Data.Char import Data.List hiding ((!!)) import Data.List.Safe ((!!)) import Data.Map (Map) -import Data.Maybe (isJust, fromMaybe) +import Data.Maybe (isJust, fromMaybe, mapMaybe) import Data.Monoid (Endo(..)) import Debug.Trace import Graphics.X11.ExtraTypes.XF86; @@ -51,6 +52,7 @@ import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.Common import Rahm.Desktop.Logger import Rahm.Desktop.Marking +import Rahm.Desktop.Lang import Rahm.Desktop.MouseMotion import Rahm.Desktop.PassMenu import Rahm.Desktop.PromptConfig @@ -141,13 +143,11 @@ keymap = runKeys $ do bind xK_apostrophe $ do justMod $ doc "Jumps between marks." $ - mapNextString $ const (mapM_ focusLocation <=< markToLocation) - - shiftMod $ - doc "Move the marked window to the current workspace." $ - mapNextString $ \_ str -> do - mapM_ (\loc -> moveLocationToWorkspace loc <$> getCurrentWorkspace) - =<< markToLocation str + runMaybeT_ $ do + l <- readNextLocationSet + case l of + (h:_) -> lift (focusLocation h) + _ -> return () bind xK_BackSpace $ do -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if @@ -279,50 +279,23 @@ keymap = runKeys $ do \_: Black hole. Sending a window here closes it.\n\n\t\ \Other keybindings starting with H-g\n\t\t\ \F1: display this help.\n\n\t" $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just w) -> gotoWorkspace =<< w - -- Test binding. Tests that I can still submap keysyms alone (keys - -- where XLookupString won't return anything helpful.) - ((f, _), _) | f == xK_F1 -> - (safeSpawn "gxmessage" [ - "-fn", "Source Code Pro", - documentation (keymap config)] :: X ()) - _ -> return () + runMaybeT_ $ (lift . gotoWorkspaceFn) =<< readNextWorkspace shiftMod $ doc "Move the currently focused window to another workspace" $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just w) -> shiftToWorkspace =<< w - ((_, "_"), _) -> CopyWindow.kill1 - _ -> return () + runMaybeT_ $ do + ws <- readNextWorkspace + loc <- lift getCurrentLocation + lift $ moveLocationToWorkspaceFn ws loc controlMod $ doc "Move the current focused window to another workspace and view that workspace" $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just w) -> do - ws <- w - shiftToWorkspace ws - gotoWorkspace ws - _ -> return () - - altMod $ - doc "Copy a window to the given workspace" $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just ws) -> windows . CopyWindow.copy =<< ws - _ -> return () - - shiftAltMod $ - doc "Swap this workspace with another workspace (rename)." $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just ws) -> swapWorkspace =<< ws - ((_, "_"), _) -> - mapM_ (\w -> focus w >> CopyWindow.kill1) =<< windowsInCurrentWorkspace - _ -> return () + runMaybeT_ $ do + ws <- readNextWorkspace + loc <- lift getCurrentLocation + lift $ do + moveLocationToWorkspaceFn ws loc + gotoWorkspaceFn ws bind xK_h $ do justMod $ @@ -382,7 +355,7 @@ keymap = runKeys $ do bind xK_m $ do justMod $ doc "Mark the current window with the next typed character." $ - mapNextString $ \_ str -> + runMaybeT_ $ mapNextString $ \_ str -> lift $ case str of [ch] | isAlpha ch -> markCurrentWindow str _ -> return () @@ -417,16 +390,19 @@ keymap = runKeys $ do sendMessage rotateLayout bind xK_s $ do - justMod $ - mapNextString $ \_ mark -> do - loc' <- markToLocation mark - case loc' of - Nothing -> return () - Just loc -> do - mapM_ setAlternateWindow (locationWindow loc) - mapNextString $ \_ ws -> do - mapM_ (moveLocationToWorkspace loc=<<) (selectWorkspace ws) + justMod $ runMaybeT_ $ do + locations <- readNextLocationSet + + workspace <- readNextWorkspace + mapM_ (lift . moveLocationToWorkspaceFn workspace) locations + lift $ setAlternateWindows (mapMaybe locationWindow locations) + forM_ locations $ \loc -> + case locationWindow loc of + Nothing -> return () + Just win -> do + lift $ logs $ printf "setAlternate %s %s" (show win) (show $ locationWorkspace loc) + lift $ setAlternateWorkspace win (locationWorkspace loc) altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" diff --git a/src/Rahm/Desktop/Lang.hs b/src/Rahm/Desktop/Lang.hs new file mode 100644 index 0000000..374500d --- /dev/null +++ b/src/Rahm/Desktop/Lang.hs @@ -0,0 +1,127 @@ +module Rahm.Desktop.Lang where + +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class + +import Data.Char (isAlphaNum, isAlpha, isDigit, ord) +import XMonad.Actions.CopyWindow as CopyWindow +import XMonad.Util.Run (safeSpawn) +import qualified XMonad.StackSet as W + +import Rahm.Desktop.Common +import Rahm.Desktop.Keys.Dsl +import Rahm.Desktop.History +import Rahm.Desktop.Marking +import Rahm.Desktop.Workspaces +import Rahm.Desktop.Submap +import Rahm.Desktop.Logger + +import Text.Printf + +import XMonad + +data Workspace = + Workspace { + moveLocationToWorkspaceFn :: Location -> X () + , gotoWorkspaceFn :: X () + , workspaceName :: String + } + +justWorkspace :: String -> Workspace +justWorkspace s = + Workspace { + moveLocationToWorkspaceFn = flip moveLocationToWorkspace s + , gotoWorkspaceFn = gotoWorkspace s + , workspaceName = s + } + +blackHoleWorkspace :: Workspace +blackHoleWorkspace = + Workspace { + moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow + , gotoWorkspaceFn = return () -- can't navigate to black hole + , workspaceName = "blackhole" + } + +alternateWorkspace :: Workspace +alternateWorkspace = + Workspace { + moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do + logs $ "Moving Location: " ++ show l + case maybeWin of + Nothing -> return () + Just win -> do + alter <- getAlternateWorkspace win + logs $ printf "Moving %s to %s" (show win) (show alter) + mapM_ (moveLocationToWorkspace l) alter + + , gotoWorkspaceFn = do + (Location _ maybeWin) <- getCurrentLocation + case maybeWin of + Nothing -> return () + Just win -> do + mapM_ gotoWorkspace =<< getAlternateWorkspace win + + , workspaceName = "@" + } + +readNextWorkspace :: MaybeT X Workspace +readNextWorkspace = + mapNextStringWithKeysym $ \mask sym str -> + case (mask, sym, str) of + (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch] + (_, _, "[") -> lift $ + justWorkspace <$> + (adjacentWorkspaceNotVisible prev =<< getCurrentWorkspace) + (_, _, "]") -> lift $ + justWorkspace <$> + (adjacentWorkspaceNotVisible next =<< getCurrentWorkspace) + (_, _, "(") -> lift $ + justWorkspace <$> + (adjacentWorkspace prev =<< getCurrentWorkspace) + (_, _, ")") -> lift $ + justWorkspace <$> + (adjacentWorkspace next =<< getCurrentWorkspace) + (_, _, "}") -> lift $ justWorkspace <$> adjacentScreen next + (_, _, "{") -> lift $ justWorkspace <$> adjacentScreen prev + (_, _, "^") -> lift $ justWorkspace <$> firstWorkspaceId + (_, _, "'") -> justWorkspace . locationWorkspace <$> MaybeT lastLocation + (_, _, ".") -> lift $ justWorkspace <$> getCurrentWorkspace + (_, _, "$") -> lift $ justWorkspace <$> lastWorkspaceId + (_, _, "/") -> do + justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) + (_, _, " ") -> lift $ + justWorkspace . accompaningWorkspace <$> getCurrentWorkspace + (_, _, "_") -> return blackHoleWorkspace + (_, _, "-") -> return alternateWorkspace + _ -> MaybeT (return Nothing) + +readNextLocationSet :: MaybeT X [Location] +readNextLocationSet = + mapNextStringWithKeysym $ \mask sym str -> + case (mask, sym, str) of + (_, _, [ch]) | isAlpha ch -> lift $ getMarkedLocations [ch] + (_, _, "0") -> (:[]) <$> MaybeT getMostRecentLocationInHistory + (_, _, [ch]) | isDigit ch -> + (:[]) <$> MaybeT (pastHistory (ord ch - 0x30)) + (_, _, ".") -> (:[]) <$> lift getCurrentLocation + (_, _, "^") -> (:[]) <$> farLeftWindow + (_, _, "$") -> (:[]) <$> farRightWindow + (_, _, "\"") -> (:[]) <$> MaybeT nextLocation + (_, _, "'") -> (:[]) <$> MaybeT lastLocation + (_, _, "*") -> (:[]) <$> (windowLocation =<< masterWindow) + (_, _, "-") -> mapM windowLocation =<< lift getAlternateWindows + (_, _, "/") -> (:[]) <$> (windowLocation =<< MaybeT askWindowId) + (_, _, "%") -> + mapM windowLocation =<< lift (withWindowSet (return . W.allWindows)) + (_, _, "@") -> (lift . windowsInWorkspace . workspaceName) =<< readNextWorkspace + (_, _, "&") -> do + l1 <- readNextLocationSet + l2 <- readNextLocationSet + return (l1 ++ l2) + (_, _, "\\") -> do + l1 <- readNextLocationSet + l2 <- readNextLocationSet + return $ filter (not . flip elem l2) l1 + + _ -> MaybeT (return Nothing) diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 5caaa3b..f4e0d9a 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -1,18 +1,29 @@ module Rahm.Desktop.Marking ( markCurrentWindow, jumpToMark, - markToLocation, moveLocationToWorkspace, - setAlternateWindow, - getAlternateWindow + setAlternateWindows, + getAlternateWindows, + setAlternateWorkspace, + getAlternateWorkspace, + getMarkedLocations, + farLeftWindow, + farRightWindow, + windowLocation ) where + +import Prelude hiding (head) + +import Data.Maybe (fromMaybe) +import Control.Monad.Trans (lift) import Data.Ord (Down(..)) import Control.Exception -import Control.Monad (when) +import Control.Monad (when, (<=<)) import Control.Monad.Trans.Maybe import Data.Char (isAlpha, isDigit, ord) import Data.IORef import Data.List (sortOn, sort, sortBy, find) +import Data.List.Safe (head) import Data.Map (Map) import Data.Maybe (catMaybes) import Data.Sequence (Seq(..)) @@ -36,13 +47,14 @@ type Mark = String data MarkState = MarkState { - markStateMap :: Map Mark Location - , alternateWindow :: Maybe Window + markStateMap :: Map Mark [Location] + , alternateWindows :: [Window] + , alternateWorkspaces :: Map Window WorkspaceId } deriving (Read, Show) instance ExtensionClass MarkState where - initialValue = MarkState Map.empty Nothing + initialValue = MarkState Map.empty [] Map.empty extensionType = PersistentExtension -- greedyFocus :: Window -> X () @@ -53,19 +65,24 @@ instance ExtensionClass MarkState where -- mapM_ (windows . greedyView . tag) ws -- focus win -setAlternateWindow :: Window -> X () -setAlternateWindow win = XS.modify (\m -> m { alternateWindow = Just win }) +setAlternateWorkspace :: Window -> WorkspaceId -> X () +setAlternateWorkspace win wid = + XS.modify $ \m -> m { + alternateWorkspaces = Map.insert win wid (alternateWorkspaces m) + } -getAlternateWindow :: MaybeT X Window -getAlternateWindow = MaybeT $ alternateWindow <$> XS.get +getAlternateWorkspace :: Window -> X (Maybe WorkspaceId) +getAlternateWorkspace window = + Map.lookup window . alternateWorkspaces <$> XS.get -withMaybeFocused :: (Maybe Window -> X a) -> X a -withMaybeFocused f = withWindowSet $ f . peek +setAlternateWindows :: [Window] -> X () +setAlternateWindows wins = XS.modify (\m -> m { alternateWindows = wins }) -getCurrentLocation :: X Location -getCurrentLocation = - (\ws -> withMaybeFocused (return . Location ws)) =<< getCurrentWorkspace +getAlternateWindows :: X [Window] +getAlternateWindows = alternateWindows <$> XS.get +withMaybeFocused :: (Maybe Window -> X a) -> X a +withMaybeFocused f = withWindowSet $ f . peek markCurrentWindow :: Mark -> X () markCurrentWindow mark = do @@ -74,13 +91,18 @@ markCurrentWindow mark = do withFocused $ \win -> XS.modify $ \state@MarkState {markStateMap = ms} -> state { - markStateMap = Map.insert mark (Location ws $ Just win) ms + markStateMap = Map.insertWith (++) mark [Location ws $ Just win] ms } jumpToMark :: Mark -> X () jumpToMark mark = do MarkState {markStateMap = m} <- XS.get - mapM_ focusLocation $ Map.lookup mark m + mapM_ focusLocation $ head =<< Map.lookup mark m + +getMarkedLocations :: Mark -> X [Location] +getMarkedLocations mark = do + MarkState {markStateMap = m} <- XS.get + return (fromMaybe [] $ Map.lookup mark m) setFocusedWindow :: a -> StackSet i l a s sd -> StackSet i l a s sd setFocusedWindow @@ -122,30 +144,16 @@ windowLocation win = do tag <- MaybeT $ withWindowSet $ return . findTag win return (Location tag (Just win)) -markToLocation :: Mark -> X (Maybe Location) -markToLocation mark = - case mark of - [ch] | isAlpha ch -> Map.lookup mark . markStateMap <$> XS.get - "0" -> getMostRecentLocationInHistory - [ch] | isDigit ch -> pastHistory (ord ch - 0x30) - "." -> Just <$> getCurrentLocation - "\"" -> nextLocation - "'" -> lastLocation - "/" -> runMaybeT $ windowLocation =<< MaybeT askWindowId - "^" -> do - rects <- sortOn (\(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects - case rects of - ((w, _) : _) -> runMaybeT (windowLocation w) - _ -> return Nothing - "$" -> do - rects <- sortOn (Down . \(_, Rectangle x _ _ _) -> x) - <$> getWindowsAndRects - case rects of - ((w, _) : _) -> runMaybeT (windowLocation w) - _ -> return Nothing - - "*" -> runMaybeT (windowLocation =<< masterWindow) - - "@" -> runMaybeT (windowLocation =<< getAlternateWindow) - - _ -> return Nothing +farLeftWindow :: MaybeT X Location +farLeftWindow = do + rects <- lift $ sortOn (\(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects + case rects of + ((w, _) : _) -> windowLocation w + _ -> MaybeT (return Nothing) + +farRightWindow :: MaybeT X Location +farRightWindow = do + rects <- lift $ sortOn (Down . \(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects + case rects of + ((w, _) : _) -> windowLocation w + _ -> MaybeT (return Nothing) diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index 5db8928..48a3144 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -9,6 +9,10 @@ module Rahm.Desktop.Submap ( submapDefault, submapDefaultWithKey) where +import Rahm.Desktop.Common +import Control.Monad.Trans.Maybe +import Control.Monad.Trans +import Control.Monad (void) import XMonad hiding (keys) import Control.Monad.Fix (fix) import qualified Data.Map as Map @@ -54,7 +58,8 @@ getMaskEventWithTimeout timeout d mask fn = do - but also allows submappings for keys that may not have a character associated - with them (for example, the function keys). -} -mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X ()) -> X () +mapNextStringWithKeysym :: + (KeyMask -> KeySym -> String -> MaybeT X a) -> MaybeT X a mapNextStringWithKeysym fn = do XConf { theRoot = root, display = d } <- ask io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime @@ -76,17 +81,18 @@ mapNextStringWithKeysym fn = do Nothing -> return Nothing io $ ungrabKeyboard d currentTime - case ret of - Just (m, str, keysym) -> fn m keysym str - Nothing -> return () + + (m, str, keysym) <- MaybeT $ return ret + fn m keysym str {- Like submap, but on the character typed rather than the kysym. -} -mapNextString :: (KeyMask -> String -> X ()) -> X () +mapNextString :: (KeyMask -> String -> MaybeT X a) -> MaybeT X a mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X () -submapDefaultWithKey def m = mapNextStringWithKeysym $ \mask sym _ -> do - Map.findWithDefault (def (mask, sym)) (mask, sym) m +submapDefaultWithKey def m = runMaybeT_ $ + mapNextStringWithKeysym $ \mask sym _ -> lift $ do + Map.findWithDefault (def (mask, sym)) (mask, sym) m submapDefault :: X () -> Map (KeyMask, KeySym) (X ()) -> X () submapDefault def = submapDefaultWithKey (const def) diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs index 3a26823..f11520a 100644 --- a/src/Rahm/Desktop/Workspaces.hs +++ b/src/Rahm/Desktop/Workspaces.hs @@ -147,27 +147,3 @@ workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) -> W.tag <$> find (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack) (map W.workspace (c : v) ++ h) - -selectWorkspace :: String -> Maybe (X WorkspaceId) -selectWorkspace s = case s of - [ch] | isAlphaNum ch || ch == '*' -> Just $ return [ch] - "]" -> Just $ adjacentWorkspaceNotVisible next - =<< getCurrentWorkspace - "[" -> Just $ adjacentWorkspaceNotVisible prev - =<< getCurrentWorkspace - ")" -> Just $ adjacentWorkspace next =<< getCurrentWorkspace - "(" -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace - "}" -> Just $ adjacentScreen next - "{" -> Just $ adjacentScreen prev - "^" -> Just firstWorkspaceId - "'" -> Just $ do - l <- lastLocation - case l of - Just (Location ws _) -> return ws - Nothing -> getCurrentWorkspace - "." -> Just getCurrentWorkspace - "$" -> Just lastWorkspaceId - "/" -> Just $ fromMaybe <$> getCurrentWorkspace <*> runMaybeT ( - (MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) - " " -> Just $ accompaningWorkspace <$> getCurrentWorkspace - _ -> Nothing -- cgit