Got the pin window layout to work. It works better than the main branch for now except the border color does not change.pinwindow

5 files changed, 148 insertions, 58 deletions

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