xmonad-contrib/XMonad/Hooks/ManageDocks.hs

{-# LANGUAGE DeriveDataTypeable, PatternGuards, FlexibleInstances, MultiParamTypeClasses, CPP #-}
-----------------------------------------------------------------------------
-- |
-- 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, docksStartupHook,
    ToggleStruts(..),
    SetStruts(..),
    module XMonad.Util.Types,

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

    -- for XMonad.Actions.FloatSnap
    calcGap, calcGapForAll
    ) 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 Data.Functor((<$>))

import qualified Data.Set as S
import qualified Data.Map as M
import Data.Maybe (fromMaybe, catMaybes)
import Control.Monad (when, forM_, filterM)

-- $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.
manageDocks :: ManageHook
manageDocks = checkDock --> (doIgnore <+> clearGapCache)
    where clearGapCache = do
            ask >>= \win -> liftX $ withDisplay $ \dpy -> do
                io $ selectInput dpy win propertyChangeMask
                rstrut <- getRawStrut win
                broadcastMessage (UpdateDock rstrut)
            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
        rstrut <- getRawStrut w
        broadcastMessage (UpdateDock rstrut)
        refresh
    return (All True)
docksEventHook (PropertyEvent { ev_window = w
                              , ev_atom = a }) = do
    whenX (runQuery checkDock w) $ do
        nws <- getAtom "_NET_WM_STRUT"
        nwsp <- getAtom "_NET_WM_STRUT_PARTIAL"
        when (a == nws || a == nwsp) $ do
            rstrut <- getRawStrut w
            broadcastMessage $ UpdateDock rstrut
    return (All True)
docksEventHook (UnmapEvent {ev_window = w}) = do
    whenX (runQuery checkDock w) $
        broadcastMessage (RemoveDock w)
    return (All True)
docksEventHook _ = return (All True)

docksStartupHook :: X ()
docksStartupHook = withDisplay $ \dpy -> do
    rootw <- asks theRoot
    (_,_,wins) <- io $ queryTree dpy rootw
    docks <- filterM (runQuery checkDock) wins
    forM_ docks $ \win -> do
        rstrut <- getRawStrut win
        broadcastMessage (UpdateDock rstrut)

    refresh

getRawStrut :: Window -> X (Window, Maybe (Either [CLong] [CLong]))
getRawStrut w = do
    msp <- fromMaybe [] <$> getProp32s "_NET_WM_STRUT_PARTIAL" w
    if null msp
        then do
            mp <- fromMaybe [] <$> getProp32s "_NET_WM_STRUT" w
            if null mp then return (w, Nothing)
                       else return (w, Just (Left mp))
        else return (w, Just (Right msp))

getRawStruts :: [Window] -> X (M.Map Window (Maybe (Either [CLong] [CLong])))
getRawStruts wins = M.fromList <$> mapM getRawStrut wins


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

calcGapForAll :: S.Set Direction2D -> X (Rectangle -> Rectangle)
calcGapForAll ss = withDisplay $ \dpy -> do
    rootw <- asks theRoot
    (_,_,wins) <- io $ queryTree dpy rootw
    calcGap wins ss

-- | Goes through the list of windows and find the gap so that all
--   STRUT settings are satisfied.
calcGap :: [Window] -> S.Set Direction2D -> X (Rectangle -> Rectangle)
calcGap wins ss = withDisplay $ \dpy -> do
    rootw <- asks theRoot
    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 M.empty

data AvoidStruts a = AvoidStruts {
    avoidStrutsDirection :: S.Set Direction2D,
    avoidStrutsRectCache :: Maybe (S.Set Direction2D, Rectangle, Rectangle),
    strutMap :: M.Map Window (Maybe (Either [CLong] [CLong]))
}  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 DockMessage = UpdateDock (Window, Maybe (Either [CLong] [CLong]))
                 | RemoveDock Window
  deriving (Read,Show,Typeable)
instance Message DockMessage


-- | 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 smap) w r = do
        let dockWins = M.keys smap
        nsmap <- getRawStruts dockWins
        (nr, nsmap) <- case cache of
            Just (ss', r', nr) | ss' == ss, r' == r -> do
                nsmap <- getRawStruts dockWins
                if nsmap /= smap
                  then do
                    nr <- fmap ($ r) (calcGap dockWins ss)
                    setWorkarea nr
                    return (nr, nsmap)
                  else do
                    return (nr, smap)
            _ -> do
                nsset <- getRawStruts dockWins
                nr <- fmap ($ r) (calcGap dockWins ss)
                setWorkarea nr
                return (nr, nsset)
        arranged <- runLayout w nr
        let newCache = Just (ss, r, nr)
        return (arranged, if newCache == cache && smap == nsmap
                    then Nothing
                    else Just as { avoidStrutsRectCache = newCache
                                 , strutMap = nsmap })

    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 (UpdateDock dock) <- fromMessage m = Just $ as { avoidStrutsRectCache = Nothing
                                                              , strutMap = M.insert (fst dock) (snd dock) $ strutMap as }
        | Just (RemoveDock dock) <- fromMessage m = Just $ as { avoidStrutsRectCache = Nothing
                                                              , strutMap = M.delete dock $ strutMap 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

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