aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Rahm/Desktop/Keys.hs11
-rw-r--r--src/Rahm/Desktop/Layout.hs6
-rw-r--r--src/Rahm/Desktop/Layout/PinWindow.hs102
-rw-r--r--src/Rahm/Desktop/StackSet.hs8
4 files changed, 123 insertions, 4 deletions
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
generated by cgit (git 2.34.1) at 2026-02-22 15:51:05 +0000