Implemented smarter system of managing borders for BorderResize

Ignore-this: 4775c082249e598a84c79b2e819f28b0

darcs-hash:20091122233651-594c5-9f3be5403a874170dbe55cd3c1562d0dc91369a5.gz

1 files changed, 109 insertions, 42 deletions

diff --git a/XMonad/Layout/BorderResize.hs b/XMonad/Layout/BorderResize.hs
index b1fc083..ec67a32 100644
--- a/XMonad/Layout/BorderResize.hs
+++ b/XMonad/Layout/BorderResize.hs
@@ -30,9 +30,8 @@ import XMonad
 import XMonad.Layout.Decoration
 import XMonad.Layout.WindowArranger
 import XMonad.Util.XUtils
-import Control.Monad(when,forM)
-import Control.Arrow(first)
-import Control.Applicative((<$>))
+import Control.Monad(when)
+import qualified Data.Map as M
 
 -- $usage
 -- You can use this module with the following in your
@@ -43,15 +42,21 @@ import Control.Applicative((<$>))
 -- > main = xmonad defaultConfig { layoutHook = myLayout }
 --
 
-data BorderInfo = RightSideBorder Window Rectangle
-                    | LeftSideBorder Window Rectangle
-                    | TopSideBorder Window Rectangle
-                    | BottomSideBorder Window Rectangle
+type BorderBlueprint = (Rectangle, Glyph, BorderType)
+
+data BorderType = RightSideBorder
+                    | LeftSideBorder
+                    | TopSideBorder
+                    | BottomSideBorder
                     deriving (Show, Read, Eq)
-type BorderWithRect = (Rectangle, Rectangle, Glyph, BorderInfo)
-type BorderWithWin = (Window, BorderInfo)
+data BorderInfo = BI { bWin :: Window,
+                        bRect :: Rectangle,
+                        bType :: BorderType
+                     } deriving (Show, Read)
+
+type RectWithBorders = (Rectangle, [BorderInfo])
 
-data BorderResize a = BR [BorderWithWin] deriving (Show, Read)
+data BorderResize a = BR (M.Map Window RectWithBorders) deriving (Show, Read)
 
 brBorderOffset :: Position
 brBorderOffset = 5
@@ -68,64 +73,119 @@ brCursorBottomSide :: Glyph
 brCursorBottomSide = 16
 
 borderResize :: l a -> ModifiedLayout BorderResize l a
-borderResize = ModifiedLayout (BR [])
+borderResize = ModifiedLayout (BR M.empty)
 
 instance LayoutModifier BorderResize Window where
     redoLayout _       _ Nothing  wrs = return (wrs, Nothing)
-    redoLayout (BR borders) _ _ wrs = do
-        let preparedBorders = for wrs $ \wr -> (wr, prepareBorders wr)
-        mapM_ deleteBorder borders
-        newBorders <- forM preparedBorders $ \(wr, (b1, b2, b3, b4)) ->
-                        first (++[wr]) . unzip <$> mapM createBorder [b1,b2,b3,b4]
-        let wrs' = concat $ map fst newBorders
-            newBordersSerialized = concat $ map snd newBorders
-        return (wrs', Just $ BR newBordersSerialized)
+    redoLayout (BR wrsLastTime) _ _ wrs = do
+            let correctOrder = map fst wrs
+                wrsCurrent = M.fromList wrs
+                wrsGone = M.difference wrsLastTime wrsCurrent
+                wrsAppeared = M.difference wrsCurrent wrsLastTime
+                wrsStillThere = M.intersectionWith testIfUnchanged wrsLastTime wrsCurrent
+            handleGone wrsGone
+            wrsCreated <- handleAppeared wrsAppeared
+            let wrsChanged = handleStillThere wrsStillThere
+                wrsThisTime = M.union wrsChanged wrsCreated
+            return (compileWrs wrsThisTime correctOrder, Just $ BR wrsThisTime)
             -- What we return is the original wrs with the new border
             -- windows inserted at the correct positions - this way, the core
             -- will restack the borders correctly.
             -- We also return information about our borders, so that we
             -- can handle events that they receive and destroy them when
             -- they are no longer needed.
-
-    handleMess (BR borders) m
-        | Just e <- fromMessage m :: Maybe Event = handleResize borders e >> return Nothing
+        where
+            testIfUnchanged entry@(rLastTime, _) rCurrent =
+                if rLastTime == rCurrent
+                    then (Nothing, entry)
+                    else (Just rCurrent, entry)
+
+    handleMess (BR wrsLastTime) m
+        | Just e <- fromMessage m :: Maybe Event =
+            handleResize (createBorderLookupTable wrsLastTime) e >> return Nothing
         | Just _ <- fromMessage m :: Maybe LayoutMessages =
-            mapM_ deleteBorder borders >> return (Just $ BR [])
+            handleGone wrsLastTime >> return (Just $ BR M.empty)
     handleMess _ _ = return Nothing
 
-prepareBorders :: (Window, Rectangle) -> (BorderWithRect, BorderWithRect, BorderWithRect, BorderWithRect)
-prepareBorders (w, r@(Rectangle x y wh ht)) =
-    ((r, (Rectangle (x + fi wh - brBorderOffset) y brBorderSize ht) , brCursorRightSide     , RightSideBorder w r),
-     (r, (Rectangle (x - brBorderOffset) y brBorderSize ht)         , brCursorLeftSide      , LeftSideBorder w r),
-     (r, (Rectangle x (y - brBorderOffset) wh brBorderSize)         , brCursorTopSide       , TopSideBorder w r),
-     (r, (Rectangle x (y + fi ht - brBorderOffset) wh brBorderSize) , brCursorBottomSide    , BottomSideBorder w r)
-    )
-
-handleResize :: [BorderWithWin] -> Event -> X ()
+compileWrs :: M.Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)]
+compileWrs wrsThisTime correctOrder = let wrs = reorder (M.toList wrsThisTime) correctOrder
+                                      in concat $ map compileWr wrs
+
+compileWr :: (Window, RectWithBorders) -> [(Window, Rectangle)]
+compileWr (w, (r, borderInfos)) =
+    let borderWrs = for borderInfos $ \bi -> (bWin bi, bRect bi)
+    in borderWrs ++ [(w, r)]
+
+handleGone :: M.Map Window RectWithBorders -> X ()
+handleGone wrsGone = mapM_ deleteWindow borderWins
+    where
+        borderWins = map bWin . concat . map snd . M.elems $ wrsGone
+
+handleAppeared :: M.Map Window Rectangle -> X (M.Map Window RectWithBorders)
+handleAppeared wrsAppeared = do
+    let wrs = M.toList wrsAppeared
+    wrsCreated <- mapM handleSingleAppeared wrs
+    return $ M.fromList wrsCreated
+
+handleSingleAppeared :: (Window, Rectangle) -> X (Window, RectWithBorders)
+handleSingleAppeared (w, r) = do
+    let borderBlueprints = prepareBorders r
+    borderInfos <- mapM createBorder borderBlueprints
+    return (w, (r, borderInfos))
+
+handleStillThere :: M.Map Window (Maybe Rectangle, RectWithBorders) -> M.Map Window RectWithBorders
+handleStillThere wrsStillThere = M.map handleSingleStillThere wrsStillThere
+
+handleSingleStillThere :: (Maybe Rectangle, RectWithBorders) -> RectWithBorders
+handleSingleStillThere (Nothing, entry) = entry
+handleSingleStillThere (Just rCurrent, (_, borderInfos)) = (rCurrent, updatedBorderInfos)
+    where
+        changedBorderBlueprints = prepareBorders rCurrent
+        updatedBorderInfos = map updateBorderInfo . zip borderInfos $ changedBorderBlueprints
+          -- assuming that the four borders are always in the same order
+
+updateBorderInfo :: (BorderInfo, BorderBlueprint) -> BorderInfo
+updateBorderInfo (borderInfo, (r, _, _)) = borderInfo { bRect = r }
+
+createBorderLookupTable :: M.Map Window RectWithBorders -> [(Window, (BorderType, Window, Rectangle))]
+createBorderLookupTable wrsLastTime = concat $ map processSingleEntry $ M.toList wrsLastTime
+    where
+        processSingleEntry :: (Window, RectWithBorders) -> [(Window, (BorderType, Window, Rectangle))]
+        processSingleEntry (w, (r, borderInfos)) = for borderInfos $ \bi -> (bWin bi, (bType bi, w, r))
+
+prepareBorders :: Rectangle -> [BorderBlueprint]
+prepareBorders (Rectangle x y wh ht) =
+    [((Rectangle (x + fi wh - brBorderOffset) y brBorderSize ht), brCursorRightSide     , RightSideBorder),
+     ((Rectangle (x - brBorderOffset) y brBorderSize ht)        , brCursorLeftSide      , LeftSideBorder),
+     ((Rectangle x (y - brBorderOffset) wh brBorderSize)        , brCursorTopSide       , TopSideBorder),
+     ((Rectangle x (y + fi ht - brBorderOffset) wh brBorderSize), brCursorBottomSide    , BottomSideBorder)
+    ]
+
+handleResize :: [(Window, (BorderType, Window, Rectangle))] -> Event -> X ()
 handleResize borders ButtonEvent { ev_window = ew, ev_event_type = et }
     | et == buttonPress, Just edge <- lookup ew borders =
     case edge of
-        RightSideBorder hostWin (Rectangle hx hy _ hht) ->
+        (RightSideBorder, hostWin, (Rectangle hx hy _ hht)) ->
             mouseDrag (\x _ -> do
                             let nwh = max 1 $ fi (x - hx)
                                 rect = Rectangle hx hy nwh hht
                             focus hostWin
                             when (x - hx > 0) $ sendMessage (SetGeometry rect)) (focus hostWin)
-        LeftSideBorder hostWin (Rectangle hx hy hwh hht) ->
+        (LeftSideBorder, hostWin, (Rectangle hx hy hwh hht)) ->
             mouseDrag (\x _ -> do
                             let nx = max 0 $ min (hx + fi hwh) $ x
                                 nwh = max 1 $ hwh + fi (hx - x)
                                 rect = Rectangle nx hy nwh hht
                             focus hostWin
                             when (x < hx + fi hwh) $ sendMessage (SetGeometry rect)) (focus hostWin)
-        TopSideBorder hostWin (Rectangle hx hy hwh hht) ->
+        (TopSideBorder, hostWin, (Rectangle hx hy hwh hht)) ->
             mouseDrag (\_ y -> do
                             let ny = max 0 $ min (hy + fi hht) $ y
                                 nht = max 1 $ hht + fi (hy - y)
                                 rect = Rectangle hx ny hwh nht
                             focus hostWin
                             when (y < hy + fi hht) $ sendMessage (SetGeometry rect)) (focus hostWin)
-        BottomSideBorder hostWin (Rectangle hx hy hwh _) ->
+        (BottomSideBorder, hostWin, (Rectangle hx hy hwh _)) ->
             mouseDrag (\_ y -> do
                             let nht = max 1 $ fi (y - hy)
                                 rect = Rectangle hx hy hwh nht
@@ -133,13 +193,10 @@ handleResize borders ButtonEvent { ev_window = ew, ev_event_type = et }
                             when (y - hy > 0) $ sendMessage (SetGeometry rect)) (focus hostWin)
 handleResize _ _ = return ()
 
-createBorder :: BorderWithRect -> X (((Window, Rectangle), BorderWithWin))
-createBorder (_, borderRect, borderCursor, borderInfo) = do
+createBorder :: BorderBlueprint -> X (BorderInfo)
+createBorder (borderRect, borderCursor, borderType) = do
     borderWin <- createInputWindow borderCursor borderRect
-    return ((borderWin, borderRect), (borderWin, borderInfo))
-
-deleteBorder :: BorderWithWin -> X ()
-deleteBorder (borderWin, _) = deleteWindow borderWin
+    return BI { bWin = borderWin, bRect = borderRect, bType = borderType }
 
 createInputWindow :: Glyph -> Rectangle -> X Window
 createInputWindow cursorGlyph r = withDisplay $ \d -> do
@@ -164,3 +221,13 @@ mkInputWindow d (Rectangle x y w h) = do
 
 for :: [a] -> (a -> b) -> [b]
 for = flip map
+
+reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)]
+reorder wrs order =
+    let ordered = concat $ map (pickElem wrs) order
+        rest = filter (\(w, _) -> not (w `elem` order)) wrs
+    in ordered ++ rest
+    where
+        pickElem list e = case (lookup e list) of
+                                Just result -> [(e, result)]
+                                Nothing -> []