diff options
Diffstat (limited to 'XMonad')
| -rw-r--r-- | XMonad/Layout/BorderResize.hs | 151 |
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 -> [] |