mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-05-19 03:20:21 -07:00
c2e36da92c
This will make it easier to transition to an implementation of EWMH that doesn't expose the individual hooks: X.H.ManageDocks would become a deprecated compatibility reexport of X.H.EWMH.Struts for a release or two, but the individual hooks need to be removed before that. Note that individual hooks in X.H.EwmhDesktops were deprecated earlier and individual hooks in XMonad.Hooks.UrgencyHook aren't exported any more (or perhaps never been), so this only leaves X.H.SetWMName, which unfortunately does not have a combinator interface at this point. Related: https://github.com/xmonad/xmonad-contrib/pull/625
339 lines
12 KiB
Haskell
339 lines
12 KiB
Haskell
{-# LANGUAGE PatternGuards, FlexibleInstances, MultiParamTypeClasses, CPP #-}
|
|
-----------------------------------------------------------------------------
|
|
-- |
|
|
-- Module : XMonad.Hooks.ManageDocks
|
|
-- Description : Automatically manage 'dock' type programs.
|
|
-- 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
|
|
docks, manageDocks, checkDock, AvoidStruts(..), avoidStruts, avoidStrutsOn,
|
|
ToggleStruts(..),
|
|
SetStruts(..),
|
|
module XMonad.Util.Types,
|
|
|
|
#ifdef TESTING
|
|
r2c,
|
|
c2r,
|
|
RectC(..),
|
|
#endif
|
|
|
|
-- * For developers of other modules ("XMonad.Actions.FloatSnap")
|
|
calcGap,
|
|
|
|
-- * Standalone hooks (deprecated)
|
|
docksEventHook, docksStartupHook,
|
|
) where
|
|
|
|
|
|
-----------------------------------------------------------------------------
|
|
import XMonad
|
|
import Foreign.C.Types (CLong)
|
|
import XMonad.Layout.LayoutModifier
|
|
import XMonad.Util.Types
|
|
import XMonad.Util.WindowProperties (getProp32s)
|
|
import qualified XMonad.Util.ExtensibleState as XS
|
|
import XMonad.Prelude (All (..), fi, filterM, foldlM, void, when, (<=<))
|
|
|
|
import qualified Data.Set as S
|
|
import qualified Data.Map as M
|
|
|
|
-- $usage
|
|
-- To use this module, add the following import to @~\/.xmonad\/xmonad.hs@:
|
|
--
|
|
-- > import XMonad.Hooks.ManageDocks
|
|
--
|
|
-- Wrap your xmonad config with a call to 'docks', like so:
|
|
--
|
|
-- > main = xmonad $ … . docks . … $ def{…}
|
|
--
|
|
-- Then add 'avoidStruts' or 'avoidStrutsOn' layout modifier to your layout
|
|
-- to prevent windows from overlapping these windows.
|
|
--
|
|
-- > layoutHook = avoidStruts (tall ||| mirror tall ||| ...)
|
|
-- > where tall = Tall 1 (3/100) (1/2)
|
|
--
|
|
-- '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 ||| ...)
|
|
--
|
|
-- For detailed instructions on editing your key bindings, see
|
|
-- "XMonad.Doc.Extending#Editing_key_bindings".
|
|
--
|
|
|
|
-- | Add docks functionality to the given config. See above for an example.
|
|
docks :: XConfig a -> XConfig a
|
|
docks c = c { startupHook = docksStartupHook <+> startupHook c
|
|
, handleEventHook = docksEventHook <+> handleEventHook c
|
|
, manageHook = manageDocks <+> manageHook c }
|
|
|
|
type WindowStruts = M.Map Window [Strut]
|
|
|
|
data UpdateDocks = UpdateDocks
|
|
instance Message UpdateDocks
|
|
|
|
refreshDocks :: X ()
|
|
refreshDocks = sendMessage UpdateDocks
|
|
|
|
-- Nothing means cache hasn't been initialized yet
|
|
newtype StrutCache = StrutCache { fromStrutCache :: Maybe WindowStruts }
|
|
deriving Eq
|
|
|
|
instance ExtensionClass StrutCache where
|
|
initialValue = StrutCache Nothing
|
|
|
|
modifiedStrutCache :: (Maybe WindowStruts -> X WindowStruts) -> X Bool
|
|
modifiedStrutCache f = XS.modifiedM $ fmap (StrutCache . Just) . f . fromStrutCache
|
|
|
|
getStrutCache :: X WindowStruts
|
|
getStrutCache = do
|
|
cache <- maybeInitStrutCache =<< XS.gets fromStrutCache
|
|
cache <$ XS.put (StrutCache (Just cache))
|
|
|
|
updateStrutCache :: Window -> X Bool
|
|
updateStrutCache w = modifiedStrutCache $ updateStrut w <=< maybeInitStrutCache
|
|
|
|
deleteFromStrutCache :: Window -> X Bool
|
|
deleteFromStrutCache w = modifiedStrutCache $ fmap (M.delete w) . maybeInitStrutCache
|
|
|
|
maybeInitStrutCache :: Maybe WindowStruts -> X WindowStruts
|
|
maybeInitStrutCache = maybe (queryDocks >>= foldlM (flip updateStrut) M.empty) pure
|
|
where
|
|
queryDocks = withDisplay $ \dpy -> do
|
|
(_, _, wins) <- io . queryTree dpy =<< asks theRoot
|
|
filterM (runQuery checkDock) wins
|
|
|
|
updateStrut :: Window -> WindowStruts -> X WindowStruts
|
|
updateStrut w cache = do
|
|
when (w `M.notMember` cache) $ requestDockEvents w
|
|
strut <- getStrut w
|
|
pure $ M.insert w strut cache
|
|
|
|
-- | Detects if the given window is of type DOCK and if so, reveals
|
|
-- it, but does not manage it.
|
|
manageDocks :: ManageHook
|
|
manageDocks = checkDock --> (doIgnore <+> doRequestDockEvents)
|
|
where
|
|
doRequestDockEvents = ask >>= liftX . requestDockEvents >> mempty
|
|
|
|
-- | Request events for a dock window.
|
|
-- (Only if not already a client to avoid overriding 'clientMask')
|
|
requestDockEvents :: Window -> X ()
|
|
requestDockEvents w = whenX (not <$> isClient w) $ withDisplay $ \dpy ->
|
|
withWindowAttributes dpy w $ \attrs -> io $ selectInput dpy w $
|
|
wa_your_event_mask attrs .|. propertyChangeMask .|. structureNotifyMask
|
|
|
|
-- | 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]) . fromIntegral) rs
|
|
_ -> return False
|
|
|
|
-- | Whenever a new dock appears, refresh the layout immediately to avoid the
|
|
-- new dock.
|
|
{-# DEPRECATED docksEventHook "Use docks instead." #-}
|
|
docksEventHook :: Event -> X All
|
|
docksEventHook MapNotifyEvent{ ev_window = w } = do
|
|
whenX (runQuery checkDock w <&&> (not <$> isClient w)) $
|
|
whenX (updateStrutCache w) refreshDocks
|
|
return (All True)
|
|
docksEventHook PropertyEvent{ ev_window = w
|
|
, ev_atom = a } = do
|
|
nws <- getAtom "_NET_WM_STRUT"
|
|
nwsp <- getAtom "_NET_WM_STRUT_PARTIAL"
|
|
when (a == nws || a == nwsp) $
|
|
whenX (updateStrutCache w) refreshDocks
|
|
return (All True)
|
|
docksEventHook DestroyWindowEvent{ ev_window = w } = do
|
|
whenX (deleteFromStrutCache w) refreshDocks
|
|
return (All True)
|
|
docksEventHook _ = return (All True)
|
|
|
|
{-# DEPRECATED docksStartupHook "Use docks instead." #-}
|
|
docksStartupHook :: X ()
|
|
docksStartupHook = void getStrutCache
|
|
|
|
-- | 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 -> 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
|
|
struts <- filter careAbout . concat . M.elems <$> getStrutCache
|
|
|
|
-- 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)
|
|
|
|
newtype AvoidStruts a = AvoidStruts (S.Set Direction2D) 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)
|
|
|
|
instance Message ToggleStruts
|
|
|
|
-- | 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)
|
|
|
|
instance Message SetStruts
|
|
|
|
instance LayoutModifier AvoidStruts a where
|
|
modifyLayout (AvoidStruts ss) w r = do
|
|
srect <- fmap ($ r) (calcGap ss)
|
|
-- Ensure _NET_WORKAREA is not set.
|
|
-- See: https://github.com/xmonad/xmonad-contrib/pull/79
|
|
rmWorkarea
|
|
runLayout w srect
|
|
|
|
pureMess as@(AvoidStruts ss) m
|
|
| Just ToggleStruts <- fromMessage m = Just $ AvoidStruts (toggleAll ss)
|
|
| Just (ToggleStrut s) <- fromMessage m = Just $ AvoidStruts (toggleOne s ss)
|
|
| Just (SetStruts n k) <- fromMessage m
|
|
, let newSS = S.fromList n `S.union` (ss S.\\ S.fromList k)
|
|
, newSS /= ss = Just $ AvoidStruts newSS
|
|
| Just UpdateDocks <- fromMessage m = Just as
|
|
| 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
|
|
|
|
rmWorkarea :: X ()
|
|
rmWorkarea = withDisplay $ \dpy -> do
|
|
a <- getAtom "_NET_WORKAREA"
|
|
r <- asks theRoot
|
|
io (deleteProperty dpy r a)
|
|
|
|
-- | (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
|