aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Hooks/ManageDocks.hs
blob: d52df0778904c186f9ff2b6697fde87529fb2979 (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
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
{-# LANGUAGE DeriveDataTypeable, PatternGuards, FlexibleInstances, MultiParamTypeClasses, CPP #-}
-- deriving Typeable for ghc-6.6 compatibility, which is retained in the core
-----------------------------------------------------------------------------
-- |
-- Module       : XMonad.Hooks.ManageDocks
-- Copyright    : (c) Joachim Breitner <mail@joachim-breitner.de>
-- License      : BSD
--
-- Maintainer   : Joachim Breitner <mail@joachim-breitner.de>
-- Stability    : unstable
-- Portability  : unportable
--
-- This module provides tools to automatically manage 'dock' type programs,
-- such as gnome-panel, kicker, dzen, and xmobar.

module XMonad.Hooks.ManageDocks (
    -- * Usage
    -- $usage
    manageDocks, checkDock, AvoidStruts, avoidStruts, avoidStrutsOn,
    docksEventHook,
    ToggleStruts(..),
    SetStruts(..),
    module XMonad.Util.Types,

#ifdef TESTING
    r2c,
    c2r,
    RectC(..),
#endif

    -- for XMonad.Actions.FloatSnap
    calcGap
    ) where


-----------------------------------------------------------------------------
import XMonad
import Foreign.C.Types (CLong)
import XMonad.Layout.LayoutModifier
import XMonad.Util.Types
import XMonad.Util.WindowProperties (getProp32s)
import XMonad.Util.XUtils (fi)
import Data.Monoid (All(..), mempty)

import qualified Data.Set as S

-- $usage
-- To use this module, add the following import to @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Hooks.ManageDocks
--
-- The first component is a 'ManageHook' which recognizes these
-- windows and de-manages them, so that xmonad does not try to tile
-- them.  To enable it:
--
-- > manageHook = ... <+> manageDocks
--
-- The second component is a layout modifier that prevents windows
-- from overlapping these dock windows.  It is intended to replace
-- xmonad's so-called \"gap\" support.  First, you must add it to your
-- list of layouts:
--
-- > layoutHook = avoidStruts (tall ||| mirror tall ||| ...)
-- >                   where  tall = Tall 1 (3/100) (1/2)
--
-- The third component is an event hook that causes new docks to appear
-- immediately, instead of waiting for the next focus change.
--
-- > handleEventHook = ... <+> docksEventHook
--
-- 'AvoidStruts' also supports toggling the dock gaps; add a keybinding
-- similar to:
--
-- > ,((modm, xK_b     ), sendMessage ToggleStruts)
--
-- If you have multiple docks, you can toggle their gaps individually.
-- For example, to toggle only the top gap:
--
-- > ,((modm .|. controlMask, xK_t), sendMessage $ ToggleStrut U)
--
-- Similarly, you can use 'D', 'L', and 'R' to individually toggle
-- gaps on the bottom, left, or right.
--
-- If you want certain docks to be avoided but others to be covered by
-- default, you can manually specify the sides of the screen on which
-- docks should be avoided, using 'avoidStrutsOn'.  For example:
--
-- > layoutHook = avoidStrutsOn [U,L] (tall ||| mirror tall ||| ...)
--
-- /Important note/: if you are switching from manual gaps
-- (defaultGaps in your config) to avoidStruts (recommended, since
-- manual gaps will probably be phased out soon), be sure to switch
-- off all your gaps (with mod-b) /before/ reloading your config with
-- avoidStruts!  Toggling struts with a 'ToggleStruts' message will
-- not work unless your gaps are set to zero.
--
-- For detailed instructions on editing your key bindings, see
-- "XMonad.Doc.Extending#Editing_key_bindings".
--

-- | Detects if the given window is of type DOCK and if so, reveals
--   it, but does not manage it. If the window has the STRUT property
--   set, adjust the gap accordingly.
manageDocks :: ManageHook
manageDocks = checkDock --> (doIgnore <+> clearGapCache)
    where clearGapCache = do
            liftX (broadcastMessage ClearGapCache)
            mempty

-- | Checks if a window is a DOCK or DESKTOP window
checkDock :: Query Bool
checkDock = ask >>= \w -> liftX $ do
    dock <- getAtom "_NET_WM_WINDOW_TYPE_DOCK"
    desk <- getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
    mbr <- getProp32s "_NET_WM_WINDOW_TYPE" w
    case mbr of
        Just rs -> return $ any (`elem` [dock,desk]) (map fromIntegral rs)
        _       -> return False

-- | Whenever a new dock appears, refresh the layout immediately to avoid the
-- new dock.
docksEventHook :: Event -> X All
docksEventHook (MapNotifyEvent {ev_window = w}) = do
    whenX ((not `fmap` (isClient w)) <&&> runQuery checkDock w) $ do
        broadcastMessage ClearGapCache
        refresh
    return (All True)
docksEventHook _ = return (All True)

-- | Gets the STRUT config, if present, in xmonad gap order
getStrut :: Window -> X [Strut]
getStrut w = do
    msp <- getProp32s "_NET_WM_STRUT_PARTIAL" w
    case msp of
        Just sp -> return $ parseStrutPartial sp
        Nothing -> fmap (maybe [] parseStrut) $ getProp32s "_NET_WM_STRUT" w
 where
    parseStrut xs@[_, _, _, _] = parseStrutPartial . take 12 $ xs ++ cycle [minBound, maxBound]
    parseStrut _ = []

    parseStrutPartial [l, r, t, b, ly1, ly2, ry1, ry2, tx1, tx2, bx1, bx2]
     = filter (\(_, n, _, _) -> n /= 0)
        [(L, l, ly1, ly2), (R, r, ry1, ry2), (U, t, tx1, tx2), (D, b, bx1, bx2)]
    parseStrutPartial _ = []

-- | Goes through the list of windows and find the gap so that all
--   STRUT settings are satisfied.
calcGap :: S.Set Direction2D -> X (Rectangle -> Rectangle)
calcGap ss = withDisplay $ \dpy -> do
    rootw <- asks theRoot
    -- We don't keep track of dock like windows, so we find all of them here
    (_,_,wins) <- io $ queryTree dpy rootw
    struts <- (filter careAbout . concat) `fmap` mapM getStrut wins

    -- we grab the window attributes of the root window rather than checking
    -- the width of the screen because xlib caches this info and it tends to
    -- be incorrect after RAndR
    wa <- io $ getWindowAttributes dpy rootw
    let screen = r2c $ Rectangle (fi $ wa_x wa) (fi $ wa_y wa) (fi $ wa_width wa) (fi $ wa_height wa)
    return $ \r -> c2r $ foldr (reduce screen) (r2c r) struts
  where careAbout (s,_,_,_) = s `S.member` ss

-- | Adjust layout automagically: don't cover up any docks, status
--   bars, etc.
avoidStruts :: LayoutClass l a => l a -> ModifiedLayout AvoidStruts l a
avoidStruts = avoidStrutsOn [U,D,L,R]

-- | Adjust layout automagically: don't cover up docks, status bars,
--   etc. on the indicated sides of the screen.  Valid sides are U
--   (top), D (bottom), R (right), or L (left).
avoidStrutsOn :: LayoutClass l a =>
                 [Direction2D]
              -> l a
              -> ModifiedLayout AvoidStruts l a
avoidStrutsOn ss = ModifiedLayout $ AvoidStruts (S.fromList ss) Nothing

data AvoidStruts a = AvoidStruts {
    avoidStrutsDirection :: S.Set Direction2D,
    avoidStrutsRectCache :: Maybe (S.Set Direction2D, Rectangle, Rectangle )
}  deriving ( Read, Show )

-- | Message type which can be sent to an 'AvoidStruts' layout
--   modifier to alter its behavior.
data ToggleStruts = ToggleStruts
                  | ToggleStrut Direction2D
  deriving (Read,Show,Typeable)

instance Message ToggleStruts


-- | message sent to ensure that caching the gaps won't give a wrong result
-- because a new dock has been added
data ClearGapCache = ClearGapCache
  deriving (Read,Show,Typeable)
instance Message ClearGapCache

-- | SetStruts is a message constructor used to set or unset specific struts,
-- regardless of whether or not the struts were originally set. Here are some
-- example bindings:
--
-- Show all gaps:
--
-- >   ,((modm .|. shiftMask  ,xK_b),sendMessage $ SetStruts [minBound .. maxBound] [])
--
-- Hide all gaps:
--
-- >   ,((modm .|. controlMask,xK_b),sendMessage $ SetStruts [] [minBound .. maxBound])
--
-- Show only upper and left gaps:
--
-- >   ,((modm .|. controlMask .|. shiftMask,xK_b),sendMessage $ SetStruts [U,L] [minBound .. maxBound])
--
-- Hide the bottom keeping whatever the other values were:
--
-- >   ,((modm .|. controlMask .|. shiftMask,xK_g),sendMessage $ SetStruts [] [D])
data SetStruts = SetStruts { addedStruts   :: [Direction2D]
                           , removedStruts :: [Direction2D] -- ^ These are removed from the currently set struts before 'addedStruts' are added.
                           }
  deriving (Read,Show,Typeable)

instance Message SetStruts

instance LayoutModifier AvoidStruts a where
    modifyLayoutWithUpdate as@(AvoidStruts ss cache) w r = do
        nr <- case cache of
            Just (ss', r', nr) | ss' == ss, r' == r -> return nr
            _ -> do
                nr <- fmap ($ r) (calcGap ss)
                setWorkarea nr
                return nr
        arranged <- runLayout w nr
        let newCache = Just (ss, r, nr)
        return (arranged, if newCache == cache
                    then Nothing
                    else Just as{ avoidStrutsRectCache = newCache } )

    pureMess as@(AvoidStruts { avoidStrutsDirection = ss }) m
        | Just ToggleStruts    <- fromMessage m = Just $ as { avoidStrutsDirection = toggleAll ss }
        | Just (ToggleStrut s) <- fromMessage m = Just $ as { avoidStrutsDirection = toggleOne s ss }
        | Just (SetStruts n k) <- fromMessage m
        , let newSS = S.fromList n `S.union` (ss S.\\ S.fromList k)
        , newSS /= ss = Just $ as { avoidStrutsDirection = newSS }
        | Just ClearGapCache <- fromMessage m = Just $ as { avoidStrutsRectCache = Nothing }
        | otherwise = Nothing
      where toggleAll x | S.null x = S.fromList [minBound .. maxBound]
                        | otherwise = S.empty
            toggleOne x xs | x `S.member` xs = S.delete x xs
                           | otherwise   = x `S.insert` xs

setWorkarea :: Rectangle -> X ()
setWorkarea (Rectangle x y w h) = withDisplay $ \dpy -> do
    a <- getAtom "_NET_WORKAREA"
    c <- getAtom "CARDINAL"
    r <- asks theRoot
    io $ changeProperty32 dpy r a c propModeReplace [fi x, fi y, fi w, fi h]


-- | (Direction, height\/width, initial pixel, final pixel).

type Strut = (Direction2D, CLong, CLong, CLong)

-- | (Initial x pixel, initial y pixel,
--    final x pixel, final y pixel).

newtype RectC = RectC (CLong, CLong, CLong, CLong) deriving (Eq,Show)

-- | Invertible conversion.

r2c :: Rectangle -> RectC
r2c (Rectangle x y w h) = RectC (fi x, fi y, fi x + fi w - 1, fi y + fi h - 1)

-- | Invertible conversion.

c2r :: RectC -> Rectangle
c2r (RectC (x1, y1, x2, y2)) = Rectangle (fi x1) (fi y1) (fi $ x2 - x1 + 1) (fi $ y2 - y1 + 1)


reduce :: RectC -> Strut -> RectC -> RectC
reduce (RectC (sx0, sy0, sx1, sy1)) (s, n, l, h) (RectC (x0, y0, x1, y1)) =
 RectC $ case s of
    L | p (y0, y1) && qh x1     -> (mx x0 sx0, y0       , x1       , y1       )
    R | p (y0, y1) && qv sx1 x0 -> (x0       , y0       , mn x1 sx1, y1       )
    U | p (x0, x1) && qh y1     -> (x0       , mx y0 sy0, x1       , y1       )
    D | p (x0, x1) && qv sy1 y0 -> (x0       , y0       , x1       , mn y1 sy1)
    _                           -> (x0       , y0       , x1       , y1       )
 where
    mx a b = max a (b + n)
    mn a b = min a (b - n)
    p r = r `overlaps` (l, h)
    -- Filter out struts that cover the entire rectangle:
    qh d1 = n <= d1
    qv sd1 d0 = sd1 - n >= d0

-- | Do the two ranges overlap?
--
-- Precondition for every input range @(x, y)@: @x '<=' y@.
--
-- A range @(x, y)@ is assumed to include every pixel from @x@ to @y@.

overlaps :: Ord a => (a, a) -> (a, a) -> Bool
(a, b) `overlaps` (x, y) =
  inRange (a, b) x || inRange (a, b) y || inRange (x, y) a
  where
  inRange (i, j) k = i <= k && k <= j