Layout modifier to resize windows by dragging their borders with the mouse

Ignore-this: 5cf197ea14b7c502fa13a16773215762

darcs-hash:20091011222214-594c5-06b94d3e2a973583f2e06fe18ebcc37b5416a01f.gz

1 files changed, 170 insertions, 0 deletions

diff --git a/XMonad/Layout/BorderResize.hs b/XMonad/Layout/BorderResize.hs
new file mode 100644
index 0000000..2fd42f8
--- /dev/null
+++ b/XMonad/Layout/BorderResize.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-}
+----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.BorderResize
+-- Copyright   :  (c) Jan Vornberger 2009
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  jan.vornberger@informatik.uni-oldenburg.de
+-- Stability   :  unstable
+-- Portability :  not portable
+--
+-- This layout modifier will allow to resize windows by dragging their
+-- borders with the mouse. However, it only works in layouts or modified
+-- layouts that react to the SetGeometry message.
+-- "XMonad.Layout.WindowArranger" can be used to create such a setup.
+-- BorderResize is probably most useful in floating layouts.
+--
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.BorderResize
+    ( -- * Usage
+      -- $usage
+      borderResize
+    , BorderResize (..)
+    ) where
+
+import XMonad
+import XMonad.Layout.Decoration
+import XMonad.Layout.WindowArranger
+import XMonad.Util.XUtils
+import Control.Monad(when,forM)
+
+-- $usage
+-- You can use this module with the following in your
+-- @~\/.xmonad\/xmonad.hs@:
+--
+-- > import XMonad.Layout.BorderResize
+-- > myLayout = borderResize (... layout setup that reacts to SetGeometry ...)
+-- > 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)
+
+data BorderResize a = BR [BorderWithWin] deriving (Show, Read)
+
+brBorderOffset :: Position
+brBorderOffset = 5
+brBorderSize :: Dimension
+brBorderSize = 10
+
+brCursorRightSide :: Glyph
+brCursorRightSide = 96
+brCursorLeftSide :: Glyph
+brCursorLeftSide = 70
+brCursorTopSide :: Glyph
+brCursorTopSide = 138
+brCursorBottomSide :: Glyph
+brCursorBottomSide = 16
+
+borderResize :: l a -> ModifiedLayout BorderResize l a
+borderResize = ModifiedLayout (BR [])
+
+instance LayoutModifier BorderResize Window where
+    redoLayout _       _ Nothing  wrs = return (wrs, Nothing)
+    redoLayout (BR borders) _ _ wrs =
+        let preparedBorders = for wrs $ \wr -> (wr, prepareBorders wr)
+        in do
+            mapM_ deleteBorder borders
+            newBorders <- forM preparedBorders $ \(wr, (b1, b2, b3, b4)) -> do
+                                (b1WR, b1BWW) <- createBorder b1
+                                (b2WR, b2BWW) <- createBorder b2
+                                (b3WR, b3BWW) <- createBorder b3
+                                (b4WR, b4BWW) <- createBorder b4
+                                return ([b1WR, b2WR, b3WR, b4WR, wr],
+                                        [b1BWW, b2BWW, b3BWW, b4BWW])
+            let wrs' = concat $ map fst newBorders
+                newBordersSerialized = concat $ map snd newBorders
+            return (wrs', Just $ BR newBordersSerialized)
+                -- 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
+        | Just Hide             <- fromMessage m = releaseResources >> return (Just $ BR [])
+        | Just ReleaseResources <- fromMessage m = releaseResources >> return (Just $ BR [])
+        where releaseResources = mapM_ deleteBorder borders
+    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 ()
+handleResize borders ButtonEvent { ev_window = ew, ev_event_type = et }
+    | et == buttonPress = do
+        case (lookup ew borders) of
+            Just (RightSideBorder hostWin (Rectangle hx hy _ hht)) -> do
+                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)
+            Just (LeftSideBorder hostWin (Rectangle hx hy hwh hht)) -> do
+                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)
+            Just (TopSideBorder hostWin (Rectangle hx hy hwh hht)) -> do
+                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)
+            Just (BottomSideBorder hostWin (Rectangle hx hy hwh _)) -> do
+                mouseDrag (\_ y -> do
+                             let nht = max 1 $ fi (y - hy)
+                                 rect = Rectangle hx hy hwh nht
+                             focus hostWin
+                             when (y - hy > 0) $ sendMessage (SetGeometry rect)) (focus hostWin)
+            Nothing -> return ()
+handleResize _ _ = return ()
+
+createBorder :: BorderWithRect -> X (((Window, Rectangle), BorderWithWin))
+createBorder (_, borderRect, borderCursor, borderInfo) = do
+    borderWin <- createInputWindow borderCursor borderRect
+    return ((borderWin, borderRect), (borderWin, borderInfo))
+
+deleteBorder :: BorderWithWin -> X ()
+deleteBorder (borderWin, _) = deleteWindow borderWin
+
+createInputWindow :: Glyph -> Rectangle -> X Window
+createInputWindow cursorGlyph r = withDisplay $ \d -> do
+    win <- mkInputWindow d r
+    io $ selectInput d win (exposureMask .|. buttonPressMask)
+    cursor <- io $ createFontCursor d cursorGlyph
+    io $ defineCursor d win cursor
+    io $ freeCursor d cursor
+    showWindow win
+    return win
+
+mkInputWindow :: Display -> Rectangle -> X Window
+mkInputWindow d (Rectangle x y w h) = do
+  rw <- asks theRoot
+  let screen   = defaultScreenOfDisplay d
+      visual   = defaultVisualOfScreen screen
+      attrmask = cWOverrideRedirect
+  io $ allocaSetWindowAttributes $
+         \attributes -> do
+           set_override_redirect attributes True
+           createWindow d rw x y w h 0 0 inputOnly visual attrmask attributes
+
+for :: [a] -> (a -> b) -> [b]
+for = flip map