aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Layout/BorderResize.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--XMonad/Layout/BorderResize.hs151
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 -> []