aboutsummaryrefslogtreecommitdiff
path: root/src/Rahm
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rahm')
-rw-r--r--src/Rahm/Desktop/Common.hs7
-rw-r--r--src/Rahm/Desktop/Dragging.hs177
-rw-r--r--src/Rahm/Desktop/Keys.hs158
3 files changed, 189 insertions, 153 deletions
diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index c3a6a31..5c29a1c 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -48,7 +48,6 @@ import qualified Rahm.Desktop.StackSet as S
workspaces,
)
import Text.Printf (printf)
-import qualified XMonad as X
import XMonad
( ScreenId,
Window,
@@ -69,6 +68,7 @@ import XMonad
withFocused,
withWindowSet,
)
+import qualified XMonad as X
import XMonad.Prompt (XPrompt (commandToComplete, showXPrompt))
import XMonad.Util.XUtils (pixelToString, stringToPixel)
@@ -80,8 +80,8 @@ data Location = Location
deriving (Read, Show, Eq, Ord)
focusLocation :: Location -> X ()
-focusLocation (Location ws Nothing) = windows $ S.greedyView ws
-focusLocation (Location _ (Just win)) = windows $ S.focusWindow win
+focusLocation (Location ws mWin) =
+ windows $ maybe id S.focusWindow mWin . S.greedyView ws
masterWindow :: MaybeT X Window
masterWindow = MaybeT $
@@ -225,4 +225,3 @@ click = do
(dpy, root) <- asks $ (,) <$> display <*> X.theRoot
(_, _, window, _, _, _, _, _) <- io $ X.queryPointer dpy root
focus window
-
diff --git a/src/Rahm/Desktop/Dragging.hs b/src/Rahm/Desktop/Dragging.hs
index 555555d..8485a46 100644
--- a/src/Rahm/Desktop/Dragging.hs
+++ b/src/Rahm/Desktop/Dragging.hs
@@ -1,13 +1,31 @@
module Rahm.Desktop.Dragging where
-import Control.Monad (filterM)
+import Control.Monad (filterM, when)
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
+import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
-import qualified Rahm.Desktop.Common as C
+import Rahm.Desktop.Common (runMaybeT_, setBorderColor)
import Rahm.Desktop.Layout.Hole (addHoleForWindow, removeHoleForWindow, resetHole)
import Rahm.Desktop.Logger
+import Rahm.Desktop.Marking (setAlternateWindows)
import qualified Rahm.Desktop.StackSet as W
import XMonad (X, io)
import qualified XMonad as X
+import XMonad.Util.WindowProperties (getProp32s)
+
+-- Action which happens after a dragging event.
+--
+-- The window is the window under
+newtype AfterDragAction = AfterDragAction (X.Window -> X.Button -> X ())
+
+instance Semigroup AfterDragAction where
+ (AfterDragAction f1) <> (AfterDragAction f2) =
+ AfterDragAction $ \w b -> f1 w b >> f2 w b
+
+instance Monoid AfterDragAction where
+ mappend = (<>)
+ mempty = AfterDragAction $ \_ _ -> return ()
afterDrag :: X () -> X ()
afterDrag action = do
@@ -22,7 +40,7 @@ windowsUnderCursor = do
aw <- X.withWindowSet (return . W.allVisibleWindows)
let fi :: (Integral a, Integral b) => a -> b
fi = fromIntegral
- (_, _, _, fi -> cx, fi -> cy, _, _, _) <- io $ X.queryPointer dpy root
+ (cx, cy) <- pointerLocation
filterM
( \win -> do
@@ -36,34 +54,9 @@ windowsUnderCursor = do
)
aw
--- mouseMoveWindowAndSink :: X ()
--- mouseMoveWindowAndSink = do
--- C.click
--- (>>=) (X.withWindowSet $ return . W.getFocusedWindow) $
--- mapM_ $ \window -> do
--- tilePosition <- X.withWindowSet $ return . W.windowTilePosition window
--- logs Debug "TilePos %s" (show tilePosition)
--- mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition
--- X.mouseMoveWindow window
---
--- afterDrag $ do
--- curev <- X.asks X.currentEvent
--- logs Debug "Current Event: %s" (show curev)
---
--- logs Info "\n\n***AFTER DRAG****\n\n"
--- wins <- filter (/= window) <$> windowsUnderCursor
--- logs Debug "Remove hole for window [%s]" (show window)
--- X.broadcastMessage $ removeHoleForWindow window
--- logs Debug "Windows under cursor %s" (show wins)
--- X.windows $
--- W.focusWindow window
--- . case wins of
--- (h : _) -> W.sinkBy window h
--- _ -> W.sink window
-thenSink :: X.Window -> X.Button -> X ()
-thenSink window _ = do
- (dpy, root) <- X.asks $ (,) <$> X.display <*> X.theRoot
- (_, _, _, fi -> cx, fi -> cy, _, _, _) <- io $ X.queryPointer dpy root
+sinkOnRelease :: AfterDragAction
+sinkOnRelease = AfterDragAction $ \window _ -> do
+ (cx, cy) <- pointerLocation
wins <- filter (/= window) <$> windowsUnderCursor
t <- fmap (W.tag . W.workspace) <$> X.pointScreen cx cy
@@ -79,19 +72,109 @@ thenSink window _ = do
where
fi = fromIntegral
-mouseMoveWindowAndSink :: X ()
-mouseMoveWindowAndSink = mouseMoveWindow thenSink
-
-mouseMoveWindow :: (X.Window -> X.Button -> X ()) -> X ()
-mouseMoveWindow afterAction = do
- C.click
- (>>=) (X.withWindowSet $ return . W.getFocusedWindow) $
- mapM_ $ \window -> do
- tilePosition <- X.withWindowSet $ return . W.windowTilePosition window
- mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition
- X.mouseMoveWindow window
-
- afterDrag $ do
- X.broadcastMessage $ removeHoleForWindow window
- curev <- X.asks X.currentEvent
- afterAction window (maybe 0 X.ev_button curev)
+ifReleased :: X.Button -> AfterDragAction -> AfterDragAction
+ifReleased but (AfterDragAction act) = AfterDragAction $ \win b -> do
+ when (but == b) $ act win b
+
+-- Like ifReleased, but with a function instead of an AfterDragAction
+ifReleased' :: X.Button -> (X.Window -> X.Button -> X ()) -> AfterDragAction
+ifReleased' but act = ifReleased but (AfterDragAction act)
+
+mouseMoveWindowAndThen ::
+ (X.Window -> X ()) ->
+ AfterDragAction ->
+ X.Window ->
+ X ()
+mouseMoveWindowAndThen beforeAction (AfterDragAction releaseAction) window = do
+ beforeAction window
+ tilePosition <- X.withWindowSet $ return . W.windowTilePosition window
+ mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition
+ X.mouseMoveWindow window
+
+ afterDrag $ do
+ X.broadcastMessage $ removeHoleForWindow window
+ curev <- X.asks X.currentEvent
+ releaseAction window (maybe 0 X.ev_button curev)
+ X.refresh
+
+getDisplayAndRoot :: X (X.Display, X.Window)
+getDisplayAndRoot = X.asks $ (,) <$> X.display <*> X.theRoot
+
+pointerLocation :: (Integral a, Integral b) => X (a, b)
+pointerLocation = do
+ (dpy, root) <- getDisplayAndRoot
+ (_, _, _, fromIntegral -> x, fromIntegral -> y, _, _, _) <-
+ io $ X.queryPointer dpy root
+ return (x, y)
+
+pointerWindow :: X X.Window
+pointerWindow = do
+ (dpy, root) <- getDisplayAndRoot
+ (_, _, w, _, _, _, _, _) <-
+ io $ X.queryPointer dpy root
+ return w
+
+dragWorkspace :: X ()
+dragWorkspace = do
+ (ox, oy) <- pointerLocation
+ X.mouseDrag (\_ _ -> return ()) $ do
+ (nx, ny) <- pointerLocation
+ runMaybeT_ $ do
+ (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ X.pointScreen ox oy
+ (W.Screen (W.tag -> ws2) _ _) <- MaybeT $ X.pointScreen nx ny
+
+ lift $ X.windows $ W.switchWorkspaces ws1 ws2
+
+dragWindow :: X ()
+dragWindow = do
+ w <- pointerWindow
+ if w == 0
+ then dragWorkspace
+ else do
+ cleanup <- setBorderColor "#00ffff" [w]
+
+ ref <- io $ newIORef (w, return ())
+
+ X.mouseDrag
+ ( \_ _ -> do
+ w' <- pointerWindow
+ (ow, ocleanup) <- io $ readIORef ref
+ case () of
+ () | ow /= w' -> do
+ ocleanup
+ cleanup' <-
+ if w' == 0 || w' == w
+ then return (return ())
+ else setBorderColor "#80a0a0" [w']
+ io $ writeIORef ref (w', cleanup')
+ () -> return ()
+
+ return ()
+ )
+ $ do
+ (nx, ny) <- pointerLocation
+ w' <- pointerWindow
+ (_, iocleanup) <- io $ readIORef ref
+ dock <- X.getAtom "_NET_WM_WINDOW_TYPE_DOCK"
+ desk <- X.getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
+ mbr <-
+ if w' == 0
+ then return Nothing
+ else getProp32s "_NET_WM_WINDOW_TYPE" w'
+
+ let isDock =
+ maybe False (any ((`elem` [dock, desk]) . fromIntegral)) mbr
+ case w' of
+ _ | w' == 0 || isDock ->
+ runMaybeT_ $ do
+ (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ X.pointScreen nx ny
+ lift $ do
+ setAlternateWindows [w]
+ X.windows $ W.sink w . W.shiftWin ws1 w
+ _ -> do
+ X.windows $ W.focusWindow w . W.swapWindows [(w, w')]
+
+ setAlternateWindows [w, w']
+
+ iocleanup
+ cleanup
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index f84ccad..fe96338 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -276,6 +276,8 @@ mapWindows fn (W.StackSet cur vis hidden float) =
mapScreen fn (W.Screen ws s sd) = W.Screen (mapWorkspace fn ws) s sd
mapWorkspace fn (W.Workspace t l s) = W.Workspace t l (fmap (fmap fn) s)
+data ShiftType = JustShift | ShiftAndFollow | ShiftAndSwap
+
keymap :: XConfig l -> KeyBindings
keymap = runKeys $ do
config <- getConfig
@@ -608,21 +610,42 @@ keymap = runKeys $ do
sendMessage rotateLayout
bind xK_s $ do
- forM_ [(False, justMod), (True, shiftMod)] $ \(doView, f) ->
+ forM_ [(JustShift, justMod), (ShiftAndSwap, shiftMod), (ShiftAndFollow, controlMod)] $ \(shiftType, f) ->
f $
doc
- ( if doView
- then "Shift a windowset to a workspace and goto that workspace."
- else "Shift a windowset to a workspace"
+ ( case shiftType of
+ ShiftAndFollow ->
+ "Shift-and-follow: Like shift-and-swap with the implicit \
+ \third parameter being the current workspace (.)"
+ ShiftAndSwap ->
+ "Shift-and-swap: Shift a windowset to a workspace then swap \
+ \that workspace with another. Primary use case is to move a \
+ \that workspace to a different screen than the current screen. \
+ \Note that this command will only work with normal workspaces."
+ JustShift -> "Shift a windowset to a workspace"
)
- $ pushPendingBuffer (if doView then "S " else "s ") $
- runMaybeT_ $
+ $ pushPendingBuffer
+ ( case shiftType of
+ ShiftAndSwap -> "S "
+ JustShift -> "s "
+ ShiftAndFollow -> "^s "
+ )
+ $ runMaybeT_ $
do
stackset <- lift $ X.windowset <$> X.get
selection <- mapMaybe locationWindow <$> readNextLocationSet
withBorderColorM "#00ffff" selection $ do
+ lift $ addStringToPendingBuffer " "
ws <- readNextWorkspace
+ finalSwap <-
+ case shiftType of
+ ShiftAndSwap -> do
+ lift $ addStringToPendingBuffer " "
+ wsName <- MaybeT . return $ workspaceName ws
+ W.switchWorkspaces wsName <$> readNextWorkspaceName
+ _ -> return id
+
lift $ do
(Endo allMovements) <-
mconcat
@@ -639,15 +662,15 @@ keymap = runKeys $ do
(W.findTag win stackset)
windows $
- ( \ss ->
- case () of
- ()
- | doView,
- (w : _) <- selection,
- Just ws <- W.findTag w ss ->
- W.greedyView ws ss
- _ -> ss
- )
+ finalSwap
+ . ( \ss ->
+ case shiftType of
+ ShiftAndFollow
+ | (w : _) <- selection,
+ Just ws <- W.findTag w ss ->
+ W.greedyView ws ss
+ _ -> ss
+ )
. allMovements
altMod $ spawnX "sudo -A systemctl suspend && xsecurelock"
@@ -714,7 +737,7 @@ keymap = runKeys $ do
\have 'x' on 'z' instead. If a theater does explicity place a window,\n\t\
\the window is placed in the hidden workspace (which is '*')\n"
$ do
- addStringToPendingBuffer "g "
+ addStringToPendingBuffer " g "
runMaybeT_ $
do
mapNextString $ \_ str -> lift $
@@ -923,6 +946,13 @@ buttonBindingsToButtonMap bindings config = Map.mapWithKey bindingToX (bindings
)
window
+myMouseMoveWindow =
+ D.mouseMoveWindowAndThen X.focus $
+ mconcat
+ [ D.ifReleased button3 D.sinkOnRelease,
+ D.ifReleased' button13 $ \w _ -> X.killWindow w
+ ]
+
mouseMap :: forall l. XConfig l -> ButtonBindings
mouseMap = runButtons $ do
config <- getConfig
@@ -988,7 +1018,7 @@ mouseMap = runButtons $ do
bind button1 $
noMod $
doc "Swap a window with another window by dragging." $
- noWindow dragWindow
+ noWindow D.dragWindow
bind button13 $ do
noMod $
@@ -1028,17 +1058,8 @@ mouseMap = runButtons $ do
subMouse $ do
bind button1 $
noMod $
- doc "Start moving the window under the cursor" $
- noWindow $
- D.mouseMoveWindow $ \win button ->
- if (button == button3)
- then D.thenSink win button
- else refresh
-
- bind button14 $
- noMod $
- doc "Start moving the mouse under the cursor, but tile when completed." $
- noWindow D.mouseMoveWindowAndSink
+ doc "Move the mouse under the cursor (like how Mod+leftMouse works)" $
+ myMouseMoveWindow
bind button2 $
noMod $
@@ -1049,19 +1070,19 @@ mouseMap = runButtons $ do
noMod $
doc "Resize the window under the cursor" mouseResizeWindow
- let swapButtons =
+ let resizeButtons =
[ ( button4,
- "Swap the current window with the next one in the stack",
- noWindow $ windows W.swapDown
+ "Increase the size of the master region",
+ noWindow $ sendMessage Expand
),
( button5,
- "Swap the current window with the last one in the stack",
- noWindow $ windows W.swapUp
+ "Shrink the size of the master region",
+ noWindow $ sendMessage Shrink
)
]
continuous $
- forM_ swapButtons $ \(b, d, a) ->
+ forM_ resizeButtons $ \(b, d, a) ->
bind b $ noMod $ doc d a
bind button13 $
@@ -1099,7 +1120,7 @@ mouseMap = runButtons $ do
bind button1 $
noMod $
doc "'drag' a workspace to another screen" $
- noWindow dragWorkspace
+ noWindow D.dragWorkspace
let workspaceButtons =
[ ( button2,
@@ -1287,70 +1308,3 @@ modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) ->
where
clip i | i < 0 = 0
clip i = i
-
-dragWorkspace :: X ()
-dragWorkspace = do
- (dpy, root) <- asks $ (,) <$> display <*> theRoot
- (_, _, _, fromIntegral -> ox, fromIntegral -> oy, _, _, _) <- io $ queryPointer dpy root
- mouseDrag (\_ _ -> return ()) $ do
- (_, _, _, fromIntegral -> nx, fromIntegral -> ny, _, _, _) <- io $ queryPointer dpy root
- runMaybeT_ $ do
- (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ pointScreen ox oy
- (W.Screen (W.tag -> ws2) _ _) <- MaybeT $ pointScreen nx ny
-
- lift $ windows $ W.switchWorkspaces ws1 ws2
-
-dragWindow :: X ()
-dragWindow = do
- (dpy, root) <- asks $ (,) <$> display <*> theRoot
- (_, _, w, _, _, _, _, _) <- io $ queryPointer dpy root
- if w == 0
- then dragWorkspace
- else do
- cleanup <- setBorderColor "#00ffff" [w]
-
- ref <- io $ newIORef (w, return ())
-
- mouseDrag
- ( \_ _ -> do
- (_, _, w', _, _, _, _, _) <- io $ queryPointer dpy root
- (ow, ocleanup) <- io $ readIORef ref
- logs Debug "%s, %s, %s\n" (show w) (show w') (show ow)
- case () of
- () | ow /= w' -> do
- ocleanup
- cleanup' <-
- if w' == 0 || w' == w
- then return (return ())
- else setBorderColor "#80a0a0" [w']
- io $ writeIORef ref (w', cleanup')
- () -> return ()
-
- return ()
- )
- $ do
- (_, _, w', fromIntegral -> nx, fromIntegral -> ny, _, _, _) <- io $ queryPointer dpy root
- (_, iocleanup) <- io $ readIORef ref
- dock <- getAtom "_NET_WM_WINDOW_TYPE_DOCK"
- desk <- getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
- mbr <-
- if w' == 0
- then return Nothing
- else getProp32s "_NET_WM_WINDOW_TYPE" w'
-
- let isDock =
- maybe False (any ((`elem` [dock, desk]) . fromIntegral)) mbr
- case w' of
- _ | w' == 0 || isDock ->
- runMaybeT_ $ do
- (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ pointScreen nx ny
- lift $ do
- setAlternateWindows [w]
- windows $ W.sink w . W.shiftWin ws1 w
- _ -> do
- windows $ W.focusWindow w . W.swapWindows [(w, w')]
-
- setAlternateWindows [w, w']
-
- iocleanup
- cleanup
generated by cgit (git 2.34.1) at 2026-02-22 18:00:05 +0000