content: {-# 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,
      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.
  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
  