aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Layout/BorderResize.hs
blob: ec67a3253c3e2d962adc50c7bde9c5e4fbb2b830 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
{-# 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,
-- but it is probably must useful in a floating layout such as
-- "XMonad.Layout.PositionStoreFloat" with which it has been mainly tested.
-- See the documentation of PositionStoreFloat for a typical usage example.
--
-----------------------------------------------------------------------------

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)
import qualified Data.Map as M

-- $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 }
--

type BorderBlueprint = (Rectangle, Glyph, BorderType)

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
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 M.empty)

instance LayoutModifier BorderResize Window where
    redoLayout _       _ Nothing  wrs = return (wrs, Nothing)
    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 wrsLastTime) m
        | Just e <- fromMessage m :: Maybe Event =
            handleResize (createBorderLookupTable wrsLastTime) e >> return Nothing
        | Just _ <- fromMessage m :: Maybe LayoutMessages =
            handleGone wrsLastTime >> return (Just $ BR M.empty)
    handleMess _ _ = return Nothing

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)) ->
            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)) ->
            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)) ->
            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 _)) ->
            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)
handleResize _ _ = return ()

createBorder :: BorderBlueprint -> X (BorderInfo)
createBorder (borderRect, borderCursor, borderType) = do
    borderWin <- createInputWindow borderCursor borderRect
    return BI { bWin = borderWin, bRect = borderRect, bType = borderType }

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

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 -> []