mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-05-19 03:20:21 -07:00
Implemented smarter system of managing borders for BorderResize
This commit is contained in:
Jan Vornberger
parent
e2c5fa876a
commit
c198812fb6
@ -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
|
||||
deriving (Show, Read, Eq)
|
||||
type BorderWithRect = (Rectangle, Rectangle, Glyph, BorderInfo)
|
||||
type BorderWithWin = (Window, BorderInfo)
|
||||
type BorderBlueprint = (Rectangle, Glyph, BorderType)
|
||||
|
||||
data BorderResize a = BR [BorderWithWin] deriving (Show, Read)
|
||||
data BorderType = RightSideBorder
|
||||
| LeftSideBorder
|
||||
| TopSideBorder
|
||||
| BottomSideBorder
|
||||
deriving (Show, Read, Eq)
|
||||
data BorderInfo = BI { bWin :: Window,
|
||||
bRect :: Rectangle,
|
||||
bType :: BorderType
|
||||
} deriving (Show, Read)
|
||||
|
||||
type RectWithBorders = (Rectangle, [BorderInfo])
|
||||
|
||||
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.
|
||||
where
|
||||
testIfUnchanged entry@(rLastTime, _) rCurrent =
|
||||
if rLastTime == rCurrent
|
||||
then (Nothing, entry)
|
||||
else (Just rCurrent, entry)
|
||||
|
||||
handleMess (BR borders) m
|
||||
| Just e <- fromMessage m :: Maybe Event = handleResize borders e >> return Nothing
|
||||
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)
|
||||
)
|
||||
compileWrs :: M.Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)]
|
||||
compileWrs wrsThisTime correctOrder = let wrs = reorder (M.toList wrsThisTime) correctOrder
|
||||
in concat $ map compileWr wrs
|
||||
|
||||
handleResize :: [BorderWithWin] -> Event -> X ()
|
||||
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 -> []
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user