WIP trying to use pin-window as a layout. Not really working too well

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