module XMonad.Hooks.ManageDocks (
manageDocks, AvoidStruts, avoidStruts, ToggleStruts(ToggleStruts)
) where
import XMonad
import Foreign.C.Types (CLong)
import Control.Monad
manageDocks :: ManageHook
manageDocks = checkDock --> doIgnore
checkDock :: Query Bool
checkDock = ask >>= \w -> liftX $ do
a <- getAtom "_NET_WM_WINDOW_TYPE"
dock <- getAtom "_NET_WM_WINDOW_TYPE_DOCK"
desk <- getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
mbr <- getProp a w
case mbr of
Just [r] -> return $ elem (fromIntegral r) [dock, desk]
_ -> return False
getStrut :: Window -> X [Strut]
getStrut w = do
spa <- getAtom "_NET_WM_STRUT_PARTIAL"
sa <- getAtom "_NET_WM_STRUT"
msp <- getProp spa w
case msp of
Just sp -> return $ parseStrutPartial sp
Nothing -> fmap (maybe [] parseStrut) $ getProp sa 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), (T, t, tx1, tx2), (B, b, bx1, bx2)]
parseStrutPartial _ = []
getProp :: Atom -> Window -> X (Maybe [CLong])
getProp a w = withDisplay $ \dpy -> io $ getWindowProperty32 dpy a w
calcGap :: X (Rectangle -> Rectangle)
calcGap = withDisplay $ \dpy -> do
rootw <- asks theRoot
(_,_,wins) <- io $ queryTree dpy rootw
struts <- concat `fmap` mapM getStrut wins
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
fi :: (Integral a, Num b) => a -> b
fi = fromIntegral
r2c :: Rectangle -> RectC
r2c (Rectangle x y w h) = (fi x, fi y, fi x + fi w, fi y + fi h)
c2r :: RectC -> Rectangle
c2r (x1, y1, x2, y2) = Rectangle (fi x1) (fi y1) (fi $ x2 x1) (fi $ y2 y1)
avoidStruts :: LayoutClass l a => l a -> AvoidStruts l a
avoidStruts = AvoidStruts True
data AvoidStruts l a = AvoidStruts Bool (l a) deriving ( Read, Show )
data ToggleStruts = ToggleStruts deriving (Read,Show,Typeable)
instance Message ToggleStruts
instance LayoutClass l a => LayoutClass (AvoidStruts l) a where
doLayout (AvoidStruts True lo) r s =
do rect <- fmap ($ r) calcGap
(wrs,mlo') <- doLayout lo rect s
return (wrs, AvoidStruts True `fmap` mlo')
doLayout (AvoidStruts False lo) r s = do (wrs,mlo') <- doLayout lo r s
return (wrs, AvoidStruts False `fmap` mlo')
handleMessage (AvoidStruts b l) m
| Just ToggleStruts <- fromMessage m = return $ Just $ AvoidStruts (not b) l
| otherwise = do ml' <- handleMessage l m
return (AvoidStruts b `fmap` ml')
description (AvoidStruts _ l) = description l
data Side = L | R | T | B
type Strut = (Side, CLong, CLong, CLong)
type RectC = (CLong, CLong, CLong, CLong)
reduce :: RectC -> Strut -> RectC -> RectC
reduce (sx0, sy0, sx1, sy1) (s, n, l, h) (x0, y0, x1, y1) = case s of
L | p (y0, y1) -> (mx x0 sx0 , y0 , x1 , y1 )
R | p (y0, y1) -> (x0 , y0 , mn x1 sx1, y1 )
T | p (x0, x1) -> (x0 , mx y0 sy0, x1 , y1 )
B | p (x0, x1) -> (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)
inRange (a, b) c = c > a && c < b
p (a, b) = inRange (a, b) l || inRange (a, b) h || inRange (a, b) l || inRange (l, h) b