From 33879cd90b0dd488540f7526d3eceab152a23d0f Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 7 Dec 2023 12:38:10 -0700 Subject: WIP trying to use pin-window as a layout. Not really working too well --- src/Rahm/Desktop/Keys.hs | 11 +++- src/Rahm/Desktop/Layout.hs | 6 ++- src/Rahm/Desktop/Layout/PinWindow.hs | 102 +++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/StackSet.hs | 8 +++ 4 files changed, 123 insertions(+), 4 deletions(-) create mode 100644 src/Rahm/Desktop/Layout/PinWindow.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 76634b0..3b08f37 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -42,6 +42,7 @@ import Graphics.X11.ExtraTypes.XF86 import Rahm.Desktop.Common ( Location (..), click, + duplWindow, focusLocation, getCurrentWorkspace, gotoWorkspace, @@ -51,7 +52,7 @@ import Rahm.Desktop.Common runMaybeT_, setBorderColor, withBorderColor, - withBorderColorM, duplWindow, + withBorderColorM, ) import Rahm.Desktop.DMenu (runDMenu) import qualified Rahm.Desktop.Dragging as D @@ -117,6 +118,7 @@ import Rahm.Desktop.Layout.List toNextLayout, toPreviousLayout, ) +import Rahm.Desktop.Layout.PinWindow (toggleWindowPin) import Rahm.Desktop.Layout.Pop (togglePop) import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.Logger @@ -307,7 +309,7 @@ keymap = runKeys $ do justMod $ doc "Run the command which opened this window again." $ X.withFocused duplWindow - + bind xK_w $ do justMod $ doc "Swap windows with other windows" $ @@ -567,6 +569,11 @@ keymap = runKeys $ do doc "Lock the screen" $ spawnX "xsecurelock" + bind xK_p $ + justMod $ + doc "Pin a window" $ + withFocused toggleWindowPin + bind xK_minus $ do justMod $ doc diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index d71989f..f6fb49e 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -18,6 +18,7 @@ import Rahm.Desktop.Layout.List nil, (|:), ) +import Rahm.Desktop.Layout.PinWindow (PinWindowLayout (PinWindowLayout)) import Rahm.Desktop.Layout.Pop (poppable) import Rahm.Desktop.Layout.Redescribe (Describer (..), Redescribe (..)) import Rahm.Desktop.Layout.ReinterpretMessage (DoReinterpret (..), ReinterpretMessage (..)) @@ -41,8 +42,9 @@ import XMonad.Layout.Spiral (spiral) myLayout = fullscreenFull $ - hole $ - avoidStruts myLayoutList + PinWindowLayout $ + hole $ + avoidStruts myLayoutList mySpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True diff --git a/src/Rahm/Desktop/Layout/PinWindow.hs b/src/Rahm/Desktop/Layout/PinWindow.hs new file mode 100644 index 0000000..959cc33 --- /dev/null +++ b/src/Rahm/Desktop/Layout/PinWindow.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TypeOperators #-} + +module Rahm.Desktop.Layout.PinWindow where + +import Control.Arrow (Arrow (second)) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Foldable (find) +import Data.List (nubBy) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe, maybe) +import Data.Semigroup (Endo (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Rahm.Desktop.Common (runMaybeT_) +import Rahm.Desktop.Logger +import qualified Rahm.Desktop.StackSet as W +import XMonad +import qualified XMonad.StackSet as W (filter) +import qualified XMonad.Util.ExtensibleState as XS + +newtype PinWindowState = PinWindowState (Map ScreenId (Set Window)) + deriving (Show, Read) + +instance Default PinWindowState where + def = PinWindowState mempty + +instance ExtensionClass PinWindowState where + initialValue = def + extensionType = PersistentExtension + +newtype PinWindowLayout (l :: * -> *) (a :: *) = PinWindowLayout (l a) + deriving (Show, Read) + +instance (LayoutClass l a, sid ~ ScreenId, a ~ Window) => LayoutClass (PinWindowLayout l) a where + runLayout (W.Workspace t (PinWindowLayout l) stack) rect = do + (PinWindowState pinned) <- XS.get + let allPinned = mconcat $ Map.elems pinned + + (W.StackSet cur vis _ floating) <- gets windowset + + (stack', winAndRect) <- case find ((== t) . (W.tag . W.workspace)) (cur : vis) of + Just (W.Screen ws sid _) -> do + let winsToMove = fromMaybe mempty (Map.lookup sid pinned) + + modifyWindowSet $ + appEndo $ + mconcat $ map (Endo . W.shiftWinNoFocus (W.tag ws)) (Set.toList winsToMove) + + updatedWorkspace <- withWindowSet $ return . W.findWorkspace t + + return + ( maybe stack W.stack updatedWorkspace, + map (second (scaleRationalRect rect)) $ + mapMaybe (\w -> (w,) <$> Map.lookup w floating) (Set.toList winsToMove) + ) + Nothing -> return (stack, []) + + (rects, maybeNewLayout) <- + runLayout (W.Workspace t l (W.filter (not . (`Map.member` floating)) =<< stack')) rect + + return + ( winAndRect ++ rects, + PinWindowLayout <$> maybeNewLayout + ) + +pinWindow :: Window -> X () +pinWindow win = runMaybeT_ $ do + lift $ logs Debug "Pinning window %d" win + + ws@(W.StackSet cur vis _ _) <- gets windowset + t <- hoist (W.findTag win ws) + scr <- hoist $ find ((== t) . (W.tag . W.workspace)) (cur : vis) + + lift $ + XS.modify $ \(PinWindowState mp) -> + PinWindowState $ + Map.alter + (Just . maybe (Set.singleton win) (Set.insert win)) + (W.screen scr) + mp + where + hoist = MaybeT . return + +unpinWindow :: Window -> X () +unpinWindow win = do + XS.modify $ \(PinWindowState mp) -> + PinWindowState $ + Map.map (Set.delete win) mp + +toggleWindowPin :: Window -> X () +toggleWindowPin win = do + isPinned <- isWindowPinned win + if isPinned + then unpinWindow win + else pinWindow win + +isWindowPinned :: Window -> X Bool +isWindowPinned win = do + (PinWindowState mp) <- XS.get + return $ any (Set.member win) (Map.elems mp) diff --git a/src/Rahm/Desktop/StackSet.hs b/src/Rahm/Desktop/StackSet.hs index 2dc8787..94c044e 100644 --- a/src/Rahm/Desktop/StackSet.hs +++ b/src/Rahm/Desktop/StackSet.hs @@ -1,6 +1,7 @@ module Rahm.Desktop.StackSet ( masterWindow, allVisibleWindows, + shiftWinNoFocus, differentiateWithFocus, concatMapTiledWindows, windowsOnWorkspace, @@ -273,6 +274,13 @@ differentiateWithFocus thing lst = getFocusedWindow :: StackSet i l a s sd -> Maybe a getFocusedWindow (StackSet cur _ _ _) = W.focus <$> (W.stack . W.workspace) cur +shiftWinNoFocus :: (Ord a, Eq s, Eq i) => i -> a -> StackSet i l a s sd -> StackSet i l a s sd +shiftWinNoFocus n w s = case findTag w s of + Just from | n `tagMember` s && n /= from -> go from s + _ -> s + where go from = onWorkspace n (focusDown . insertUp w) . onWorkspace from (delete' w) + onWorkspace n f s = view (currentTag s) . f . view n $ s + sinkBy :: (Eq a, Eq i, Ord a) => a -> a -> StackSet i l a s sd -> StackSet i l a s sd sinkBy win toSinkBy ss = case (findTag win ss, findTag toSinkBy ss) of -- cgit From 9f176adbff807dafec2caee5e3b104e65caf9029 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 8 Dec 2023 16:13:24 -0700 Subject: Got the pin window layout to work. It works better than the main branch for now except the border color does not change. --- src/Rahm/Desktop/Dragging.hs | 27 ++++++++- src/Rahm/Desktop/Keys.hs | 57 ++++++++++++------ src/Rahm/Desktop/Keys/Wml.hs | 4 +- src/Rahm/Desktop/Layout.hs | 5 +- src/Rahm/Desktop/Layout/PinWindow.hs | 113 +++++++++++++++++++++++++---------- 5 files changed, 148 insertions(+), 58 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Dragging.hs b/src/Rahm/Desktop/Dragging.hs index 5252390..853cf43 100644 --- a/src/Rahm/Desktop/Dragging.hs +++ b/src/Rahm/Desktop/Dragging.hs @@ -5,8 +5,9 @@ import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) import Data.IORef (newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) -import Rahm.Desktop.Common (runMaybeT_, setBorderColor, pointerWindow, pointerLocation) +import Rahm.Desktop.Common (pointerLocation, pointerWindow, runMaybeT_, setBorderColor) import Rahm.Desktop.Layout.Hole (addHoleForWindow, removeHoleForWindow, resetHole) +import Rahm.Desktop.Layout.PinWindow (isWindowPinned, pinWindow, unpinWindow) import Rahm.Desktop.Logger import Rahm.Desktop.Marking (setAlternateWindows) import qualified Rahm.Desktop.StackSet as W @@ -80,6 +81,26 @@ ifReleased but (AfterDragAction act) = AfterDragAction $ \win b -> do ifReleased' :: X.Button -> (X.Window -> X.Button -> X ()) -> AfterDragAction ifReleased' but act = ifReleased but (AfterDragAction act) +mouseResizeWindowAndThen :: (X.Window -> X ()) -> + AfterDragAction -> X.Window -> X () +mouseResizeWindowAndThen beforeAction (AfterDragAction releaseAction) window = do + beforeAction window + windowPinned <- isWindowPinned window + unpinWindow window + tilePosition <- X.withWindowSet $ return . W.windowTilePosition window + mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition + + X.mouseResizeWindow window + + afterDrag $ do + X.broadcastMessage $ removeHoleForWindow window + curev <- X.asks X.currentEvent + when windowPinned $ + pinWindow window + releaseAction window (maybe 0 X.ev_button curev) + X.refresh + + mouseMoveWindowAndThen :: (X.Window -> X ()) -> AfterDragAction -> @@ -87,6 +108,8 @@ mouseMoveWindowAndThen :: X () mouseMoveWindowAndThen beforeAction (AfterDragAction releaseAction) window = do beforeAction window + windowPinned <- isWindowPinned window + unpinWindow window tilePosition <- X.withWindowSet $ return . W.windowTilePosition window mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition X.mouseMoveWindow window @@ -94,6 +117,8 @@ mouseMoveWindowAndThen beforeAction (AfterDragAction releaseAction) window = do afterDrag $ do X.broadcastMessage $ removeHoleForWindow window curev <- X.asks X.currentEvent + when windowPinned $ + pinWindow window releaseAction window (maybe 0 X.ev_button curev) X.refresh diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 3b08f37..94308e5 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -118,7 +118,7 @@ import Rahm.Desktop.Layout.List toNextLayout, toPreviousLayout, ) -import Rahm.Desktop.Layout.PinWindow (toggleWindowPin) +import Rahm.Desktop.Layout.PinWindow (pinWindow, toggleWindowPin, unpinWindow, withWindowsUnpinned) import Rahm.Desktop.Layout.Pop (togglePop) import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.Logger @@ -569,10 +569,21 @@ keymap = runKeys $ do doc "Lock the screen" $ spawnX "xsecurelock" - bind xK_p $ + bind xK_p $ do justMod $ - doc "Pin a window" $ - withFocused toggleWindowPin + doc "Pin a windowset" $ + pushPendingBuffer "p " $ + runMaybeT_ $ + do + windows <- mapMaybe locationWindow <$> readNextLocationSet + lift $ mapM_ pinWindow windows + + shiftMod $ + doc "Unpin a windowset" $ + pushPendingBuffer "P " $ + runMaybeT_ $ do + windows <- mapMaybe locationWindow <$> readNextLocationSet + lift $ mapM_ unpinWindow windows bind xK_minus $ do justMod $ @@ -709,17 +720,18 @@ keymap = runKeys $ do ) (W.findTag win stackset) - windows $ - finalSwap - . ( \ss -> - case shiftType of - ShiftAndFollow - | (w : _) <- selection, - Just ws <- W.findTag w ss -> - W.greedyView ws ss - _ -> ss - ) - . allMovements + withWindowsUnpinned selection $ + windows $ + 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" @@ -998,7 +1010,13 @@ myMouseMoveWindow = D.mouseMoveWindowAndThen X.focus $ mconcat [ D.ifReleased button3 D.sinkOnRelease, - D.ifReleased' button13 $ \w _ -> X.killWindow w + D.ifReleased' button2 $ \w _ -> X.killWindow w + ] + +myMouseResizeAction = + D.mouseResizeWindowAndThen X.focus $ + mconcat + [ D.ifReleased button1 D.sinkOnRelease ] mouseMap :: forall l. XConfig l -> ButtonBindings @@ -1035,8 +1053,9 @@ mouseMap = runButtons $ do bind button3 $ do justMod $ - doc "Float and resize a window" $ - \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster + doc + "Float and resize a window" + myMouseResizeAction bind button6 $ justMod $ @@ -1120,7 +1139,7 @@ mouseMap = runButtons $ do bind button3 $ noMod $ - doc "Resize the window under the cursor" mouseResizeWindow + doc "Resize the window under the cursor" myMouseResizeAction let resizeButtons = [ ( button4, diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 0d0691f..6555312 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -88,6 +88,7 @@ import Rahm.Desktop.History nextLocation, -- pastHistory, ) +import Rahm.Desktop.Layout.PinWindow (pinnedWindows) import Rahm.Desktop.Logger (LogLevel (Info, Trace), logs) import Rahm.Desktop.Marking ( farLeftWindow, @@ -634,8 +635,7 @@ readNextLocationSet' = (_, _, ".") -> (: []) <$> mt getCurrentLocation -- The selected windows in the selection set. (_, _, "#") -> - fromMaybeTX $ - mapM windowLocation =<< MaybeT (Just <$> fromX getAndResetWindowSelection) + MaybeT . fromX $ Just . map (Location "*" . Just) <$> pinnedWindows -- The window on the far-left of the screens. (_, _, "^") -> (: []) <$> fromMaybeTX farLeftWindow -- The windows on the far-right of the screens. diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index f6fb49e..4dfba25 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -18,7 +18,7 @@ import Rahm.Desktop.Layout.List nil, (|:), ) -import Rahm.Desktop.Layout.PinWindow (PinWindowLayout (PinWindowLayout)) +import Rahm.Desktop.Layout.PinWindow (PinWindowLayout (PinWindowLayout), pinnable) import Rahm.Desktop.Layout.Pop (poppable) import Rahm.Desktop.Layout.Redescribe (Describer (..), Redescribe (..)) import Rahm.Desktop.Layout.ReinterpretMessage (DoReinterpret (..), ReinterpretMessage (..)) @@ -42,14 +42,13 @@ import XMonad.Layout.Spiral (spiral) myLayout = fullscreenFull $ - PinWindowLayout $ hole $ avoidStruts myLayoutList mySpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True mods = - mySpacing . poppable . flippable . rotateable + pinnable . poppable . mySpacing . flippable . rotateable myLayoutList = layoutList $ diff --git a/src/Rahm/Desktop/Layout/PinWindow.hs b/src/Rahm/Desktop/Layout/PinWindow.hs index 959cc33..fe98afd 100644 --- a/src/Rahm/Desktop/Layout/PinWindow.hs +++ b/src/Rahm/Desktop/Layout/PinWindow.hs @@ -3,6 +3,8 @@ module Rahm.Desktop.Layout.PinWindow where import Control.Arrow (Arrow (second)) +import Control.Exception (throw) +import Control.Monad (unless, when) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.Foldable (find) @@ -20,7 +22,7 @@ import XMonad import qualified XMonad.StackSet as W (filter) import qualified XMonad.Util.ExtensibleState as XS -newtype PinWindowState = PinWindowState (Map ScreenId (Set Window)) +newtype PinWindowState = PinWindowState (Map ScreenId [(Window, W.RationalRect)]) deriving (Show, Read) instance Default PinWindowState where @@ -35,59 +37,85 @@ newtype PinWindowLayout (l :: * -> *) (a :: *) = PinWindowLayout (l a) instance (LayoutClass l a, sid ~ ScreenId, a ~ Window) => LayoutClass (PinWindowLayout l) a where runLayout (W.Workspace t (PinWindowLayout l) stack) rect = do + -- Clean up window id's thare should not be pinned anymore because the + -- windows were unmanaged. + (PinWindowState pinned') <- XS.get + ws <- gets windowset + XS.put $ PinWindowState (cleanupPinned pinned' ws) (PinWindowState pinned) <- XS.get - let allPinned = mconcat $ Map.elems pinned - (W.StackSet cur vis _ floating) <- gets windowset - - (stack', winAndRect) <- case find ((== t) . (W.tag . W.workspace)) (cur : vis) of - Just (W.Screen ws sid _) -> do - let winsToMove = fromMaybe mempty (Map.lookup sid pinned) - - modifyWindowSet $ - appEndo $ - mconcat $ map (Endo . W.shiftWinNoFocus (W.tag ws)) (Set.toList winsToMove) - - updatedWorkspace <- withWindowSet $ return . W.findWorkspace t - - return - ( maybe stack W.stack updatedWorkspace, - map (second (scaleRationalRect rect)) $ - mapMaybe (\w -> (w,) <$> Map.lookup w floating) (Set.toList winsToMove) - ) - Nothing -> return (stack, []) + let myScreen = find ((== t) . W.tag . W.workspace) (W.screens ws) + pinnedRects = + maybe + [] + (map $ second (scaleRationalRect rect)) + (((`Map.lookup` pinned) . W.screen) =<< myScreen) + allPinned = Set.fromList $ map fst $ concat $ Map.elems pinned + pinnedOnMyScreen = map fst pinnedRects + + windowsToMove = + filter (\win -> W.findTag win ws /= Just t) pinnedOnMyScreen + + modifyWindowSet $ + appEndo . mconcat $ + -- Move the windows that are supposed to now be on this workspace here + map (Endo . W.shiftWinNoFocus t) windowsToMove + ++ + -- once again, sink the windows that are supposed to be here. Make + -- sure they don't float. + map (Endo . W.sink) (Set.toList allPinned) (rects, maybeNewLayout) <- - runLayout (W.Workspace t l (W.filter (not . (`Map.member` floating)) =<< stack')) rect + runLayout + (W.Workspace t l (W.filter (not . (`Set.member` allPinned)) =<< stack)) + rect + + return (pinnedRects ++ rects, PinWindowLayout <$> maybeNewLayout) + where + cleanupPinned mp ss = + let aw = Set.fromList (W.allWindows ss) + in Map.map (filter ((`Set.member` aw) . fst)) mp - return - ( winAndRect ++ rects, - PinWindowLayout <$> maybeNewLayout - ) + handleMessage (PinWindowLayout l) a = do + maybeNewLayout <- handleMessage l a + return (PinWindowLayout <$> maybeNewLayout) pinWindow :: Window -> X () pinWindow win = runMaybeT_ $ do lift $ logs Debug "Pinning window %d" win - ws@(W.StackSet cur vis _ _) <- gets windowset + ws@(W.StackSet cur vis _ flt) <- gets windowset t <- hoist (W.findTag win ws) scr <- hoist $ find ((== t) . (W.tag . W.workspace)) (cur : vis) + rect <- hoist $ Map.lookup win flt - lift $ + lift $ do XS.modify $ \(PinWindowState mp) -> PinWindowState $ Map.alter - (Just . maybe (Set.singleton win) (Set.insert win)) + (Just . maybe [(win, rect)] ((win, rect) :)) (W.screen scr) mp + + -- Don't float the window anymore. + modifyWindowSet $ W.sink win where hoist = MaybeT . return unpinWindow :: Window -> X () -unpinWindow win = do - XS.modify $ \(PinWindowState mp) -> - PinWindowState $ - Map.map (Set.delete win) mp +unpinWindow win = runMaybeT_ $ do + (PinWindowState mp) <- lift XS.get + (win, rect) <- hoist $ find ((== win) . fst) (concat $ Map.elems mp) + + lift $ do + XS.put $ + PinWindowState $ + Map.map (filter ((/= win) . fst)) mp + + -- refloat the window. + modifyWindowSet $ W.float win rect + where + hoist = MaybeT . return toggleWindowPin :: Window -> X () toggleWindowPin win = do @@ -99,4 +127,23 @@ toggleWindowPin win = do isWindowPinned :: Window -> X Bool isWindowPinned win = do (PinWindowState mp) <- XS.get - return $ any (Set.member win) (Map.elems mp) + return $ any (any $ (== win) . fst) (Map.elems mp) + +pinnedWindows :: X [Window] +pinnedWindows = do + (PinWindowState s) <- XS.get + return $ map fst $ concat $ Map.elems s + +pinnable :: l a -> PinWindowLayout l a +pinnable = PinWindowLayout + +-- Unpins the window, executes the action, then repins the window. Useful for +-- window shifts and whatnot. +withWindowsUnpinned :: [Window] -> X () -> X () +withWindowsUnpinned wins fn = + ( do + mapM_ unpinWindow wins + fn + mapM_ pinWindow wins + ) + `catchX` mapM_ pinWindow wins -- cgit