{-# LANGUAGE PatternGuards, FlexibleInstances, MultiParamTypeClasses, CPP, LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- 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

import qualified Data.Set        as S
import qualified Data.Map        as M
import qualified XMonad.StackSet as W

-- $usage
-- To use this module, add the following import to @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
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.
--

-- | Add docks functionality to the given config.  See above for an example.
docks :: XConfig a -> XConfig a
docks :: forall (a :: * -> *). XConfig a -> XConfig a
docks XConfig a
c = XConfig a
c { startupHook :: X ()
startupHook     = X ()
docksStartupHook forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig a
c
            , handleEventHook :: Event -> X All
handleEventHook = Event -> X All
docksEventHook forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig a
c
            , manageHook :: Query (Endo WindowSet)
manageHook      = Query (Endo WindowSet)
manageDocks forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *). XConfig l -> Query (Endo WindowSet)
manageHook XConfig a
c }

type WindowStruts = M.Map Window [Strut]

data UpdateDocks = UpdateDocks
instance Message UpdateDocks

refreshDocks :: X ()
refreshDocks :: X ()
refreshDocks = forall a. Message a => a -> X ()
sendMessage UpdateDocks
UpdateDocks

-- Nothing means cache hasn't been initialized yet
newtype StrutCache = StrutCache { StrutCache -> Maybe WindowStruts
fromStrutCache :: Maybe WindowStruts }
    deriving StrutCache -> StrutCache -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StrutCache -> StrutCache -> Bool
$c/= :: StrutCache -> StrutCache -> Bool
== :: StrutCache -> StrutCache -> Bool
$c== :: StrutCache -> StrutCache -> Bool
Eq

instance ExtensionClass StrutCache where
    initialValue :: StrutCache
initialValue = Maybe WindowStruts -> StrutCache
StrutCache forall a. Maybe a
Nothing

modifiedStrutCache :: (Maybe WindowStruts -> X WindowStruts) -> X Bool
modifiedStrutCache :: (Maybe WindowStruts -> X WindowStruts) -> X Bool
modifiedStrutCache Maybe WindowStruts -> X WindowStruts
f = forall a (m :: * -> *).
(ExtensionClass a, Eq a, XLike m) =>
(a -> m a) -> m Bool
XS.modifiedM forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe WindowStruts -> StrutCache
StrutCache forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe WindowStruts -> X WindowStruts
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrutCache -> Maybe WindowStruts
fromStrutCache

getStrutCache :: X WindowStruts
getStrutCache :: X WindowStruts
getStrutCache = do
    WindowStruts
cache <- Maybe WindowStruts -> X WindowStruts
maybeInitStrutCache forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets StrutCache -> Maybe WindowStruts
fromStrutCache
    WindowStruts
cache forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Maybe WindowStruts -> StrutCache
StrutCache (forall a. a -> Maybe a
Just WindowStruts
cache))

updateStrutCache :: Window -> X Bool
updateStrutCache :: EventMask -> X Bool
updateStrutCache EventMask
w = (Maybe WindowStruts -> X WindowStruts) -> X Bool
modifiedStrutCache forall a b. (a -> b) -> a -> b
$ EventMask -> WindowStruts -> X WindowStruts
updateStrut EventMask
w forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Maybe WindowStruts -> X WindowStruts
maybeInitStrutCache

deleteFromStrutCache :: Window -> X Bool
deleteFromStrutCache :: EventMask -> X Bool
deleteFromStrutCache EventMask
w = (Maybe WindowStruts -> X WindowStruts) -> X Bool
modifiedStrutCache forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> Map k a -> Map k a
M.delete EventMask
w) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe WindowStruts -> X WindowStruts
maybeInitStrutCache

maybeInitStrutCache :: Maybe WindowStruts -> X WindowStruts
maybeInitStrutCache :: Maybe WindowStruts -> X WindowStruts
maybeInitStrutCache = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (X [EventMask]
queryDocks forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (forall a b c. (a -> b -> c) -> b -> a -> c
flip EventMask -> WindowStruts -> X WindowStruts
updateStrut) forall k a. Map k a
M.empty) forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    queryDocks :: X [EventMask]
queryDocks = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
        (EventMask
_, EventMask
_, [EventMask]
wins) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> EventMask -> IO (EventMask, EventMask, [EventMask])
queryTree Display
dpy forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> EventMask
theRoot
        forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall a. Query a -> EventMask -> X a
runQuery Query Bool
checkDock) [EventMask]
wins

updateStrut :: Window -> WindowStruts -> X WindowStruts
updateStrut :: EventMask -> WindowStruts -> X WindowStruts
updateStrut EventMask
w WindowStruts
cache = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventMask
w forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` WindowStruts
cache) forall a b. (a -> b) -> a -> b
$ EventMask -> X ()
requestDockEvents EventMask
w
    [Strut]
strut <- EventMask -> X [Strut]
getStrut EventMask
w
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert EventMask
w [Strut]
strut WindowStruts
cache

-- | Detects if the given window is of type DOCK and if so, reveals
--   it, but does not manage it.
manageDocks :: ManageHook
manageDocks :: Query (Endo WindowSet)
manageDocks = Query Bool
checkDock forall (m :: * -> *) a. (Monad m, Monoid a) => m Bool -> m a -> m a
--> (Query (Endo WindowSet)
doIgnore forall a. Semigroup a => a -> a -> a
<> Query (Endo WindowSet)
doRequestDockEvents)
  where
    doRequestDockEvents :: Query (Endo WindowSet)
doRequestDockEvents = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. X a -> Query a
liftX forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventMask -> X ()
requestDockEvents forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Monoid a => a
mempty

-- | Request events for a dock window.
-- (Only if not already a client to avoid overriding 'clientMask')
requestDockEvents :: Window -> X ()
requestDockEvents :: EventMask -> X ()
requestDockEvents EventMask
w = X Bool -> X () -> X ()
whenX (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventMask -> X Bool
isClient EventMask
w) forall a b. (a -> b) -> a -> b
$ forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy ->
    Display -> EventMask -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes Display
dpy EventMask
w forall a b. (a -> b) -> a -> b
$ \WindowAttributes
attrs -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> EventMask -> IO ()
selectInput Display
dpy EventMask
w forall a b. (a -> b) -> a -> b
$
        WindowAttributes -> EventMask
wa_your_event_mask WindowAttributes
attrs forall a. Bits a => a -> a -> a
.|. EventMask
propertyChangeMask forall a. Bits a => a -> a -> a
.|. EventMask
structureNotifyMask

-- | Checks if a window is a DOCK or DESKTOP window.
-- Ignores xmonad's own windows (usually _NET_WM_WINDOW_TYPE_DESKTOP) to avoid
-- unnecessary refreshes.
checkDock :: Query Bool
checkDock :: Query Bool
checkDock = Query Bool
isDockOrDesktop forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query Bool
isXMonad)
  where
    isDockOrDesktop :: Query Bool
isDockOrDesktop = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EventMask
w -> forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ do
        EventMask
dock <- String -> X EventMask
getAtom String
"_NET_WM_WINDOW_TYPE_DOCK"
        EventMask
desk <- String -> X EventMask
getAtom String
"_NET_WM_WINDOW_TYPE_DESKTOP"
        Maybe [CLong]
mbr <- String -> EventMask -> X (Maybe [CLong])
getProp32s String
"_NET_WM_WINDOW_TYPE" EventMask
w
        case Maybe [CLong]
mbr of
            Just [CLong]
rs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EventMask
dock,EventMask
desk]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) [CLong]
rs
            Maybe [CLong]
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    isXMonad :: Query Bool
isXMonad = Query String
className forall a. Eq a => Query a -> a -> Query Bool
=? String
"xmonad"

-- | Whenever a new dock appears, refresh the layout immediately to avoid the
-- new dock.
{-# DEPRECATED docksEventHook "Use docks instead." #-}
docksEventHook :: Event -> X All
docksEventHook :: Event -> X All
docksEventHook MapNotifyEvent{ ev_window :: Event -> EventMask
ev_window = EventMask
w } = do
    X Bool -> X () -> X ()
whenX (forall a. Query a -> EventMask -> X a
runQuery Query Bool
checkDock EventMask
w forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventMask -> X Bool
isClient EventMask
w)) forall a b. (a -> b) -> a -> b
$
        X Bool -> X () -> X ()
whenX (EventMask -> X Bool
updateStrutCache EventMask
w) X ()
refreshDocks
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
docksEventHook PropertyEvent{ ev_window :: Event -> EventMask
ev_window = EventMask
w
                            , ev_atom :: Event -> EventMask
ev_atom = EventMask
a } = do
    EventMask
nws <- String -> X EventMask
getAtom String
"_NET_WM_STRUT"
    EventMask
nwsp <- String -> X EventMask
getAtom String
"_NET_WM_STRUT_PARTIAL"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventMask
a forall a. Eq a => a -> a -> Bool
== EventMask
nws Bool -> Bool -> Bool
|| EventMask
a forall a. Eq a => a -> a -> Bool
== EventMask
nwsp) forall a b. (a -> b) -> a -> b
$
        X Bool -> X () -> X ()
whenX (EventMask -> X Bool
updateStrutCache EventMask
w) X ()
refreshDocks
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
docksEventHook DestroyWindowEvent{ ev_window :: Event -> EventMask
ev_window = EventMask
w } = do
    X Bool -> X () -> X ()
whenX (EventMask -> X Bool
deleteFromStrutCache EventMask
w) X ()
refreshDocks
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
docksEventHook Event
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

{-# DEPRECATED docksStartupHook "Use docks instead." #-}
docksStartupHook :: X ()
docksStartupHook :: X ()
docksStartupHook = forall (f :: * -> *) a. Functor f => f a -> f ()
void X WindowStruts
getStrutCache

-- | Gets the STRUT config, if present, in xmonad gap order
getStrut :: Window -> X [Strut]
getStrut :: EventMask -> X [Strut]
getStrut EventMask
w = do
    Maybe [CLong]
msp <- String -> EventMask -> X (Maybe [CLong])
getProp32s String
"_NET_WM_STRUT_PARTIAL" EventMask
w
    case Maybe [CLong]
msp of
        Just [CLong]
sp -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {d}. (Eq d, Num d) => [d] -> [(Direction2D, d, d, d)]
parseStrutPartial [CLong]
sp
        Maybe [CLong]
Nothing -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall {d}.
(Eq d, Num d, Bounded d) =>
[d] -> [(Direction2D, d, d, d)]
parseStrut forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> EventMask -> X (Maybe [CLong])
getProp32s String
"_NET_WM_STRUT" EventMask
w
 where
    parseStrut :: [d] -> [(Direction2D, d, d, d)]
parseStrut xs :: [d]
xs@[d
_, d
_, d
_, d
_] = forall {d}. (Eq d, Num d) => [d] -> [(Direction2D, d, d, d)]
parseStrutPartial forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
12 forall a b. (a -> b) -> a -> b
$ [d]
xs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
cycle [forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound]
    parseStrut [d]
_ = []

    parseStrutPartial :: [d] -> [(Direction2D, d, d, d)]
parseStrutPartial [d
l, d
r, d
t, d
b, d
ly1, d
ly2, d
ry1, d
ry2, d
tx1, d
tx2, d
bx1, d
bx2]
     = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Direction2D
_, d
n, d
_, d
_) -> d
n forall a. Eq a => a -> a -> Bool
/= d
0)
        [(Direction2D
L, d
l, d
ly1, d
ly2), (Direction2D
R, d
r, d
ry1, d
ry2), (Direction2D
U, d
t, d
tx1, d
tx2), (Direction2D
D, d
b, d
bx1, d
bx2)]
    parseStrutPartial [d]
_ = []

-- | 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 :: Set Direction2D -> X (Rectangle -> Rectangle)
calcGap Set Direction2D
ss = do
    EventMask
rootw <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> EventMask
theRoot
    [Strut]
struts <- forall a. (a -> Bool) -> [a] -> [a]
filter forall {b} {c} {d}. (Direction2D, b, c, d) -> Bool
careAbout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> X WindowStruts
getStrutCache

    -- If possible, 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
    RectC
screen <- EventMask -> X (Maybe WindowAttributes)
safeGetWindowAttributes EventMask
rootw forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe WindowAttributes
Nothing -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ Rectangle -> RectC
r2c forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScreenDetail -> Rectangle
screenRect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
        Just WindowAttributes
wa -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> RectC
r2c forall a b. (a -> b) -> a -> b
$ Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_x WindowAttributes
wa) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_y WindowAttributes
wa) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_width WindowAttributes
wa) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_height WindowAttributes
wa)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Rectangle
r -> RectC -> Rectangle
c2r forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (RectC -> Strut -> RectC -> RectC
reduce RectC
screen) (Rectangle -> RectC
r2c Rectangle
r) [Strut]
struts
  where careAbout :: (Direction2D, b, c, d) -> Bool
careAbout (Direction2D
s,b
_,c
_,d
_) = Direction2D
s forall a. Ord a => a -> Set a -> Bool
`S.member` Set Direction2D
ss

-- | Adjust layout automagically: don't cover up any docks, status
--   bars, etc.
--
--   Note that this modifier must be applied before any modifier that
--   changes the screen rectangle, or struts will be applied in the wrong
--   place and may affect the other modifier(s) in odd ways. This is
--   most commonly seen with the 'spacing' modifier and friends.
avoidStruts :: LayoutClass l a => l a -> ModifiedLayout AvoidStruts l a
avoidStruts :: forall (l :: * -> *) a.
LayoutClass l a =>
l a -> ModifiedLayout AvoidStruts l a
avoidStruts = forall (l :: * -> *) a.
LayoutClass l a =>
[Direction2D] -> l a -> ModifiedLayout AvoidStruts l a
avoidStrutsOn [Direction2D
U,Direction2D
D,Direction2D
L,Direction2D
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). The warning in
--   'avoidStruts' applies to this modifier as well.
avoidStrutsOn :: LayoutClass l a =>
                 [Direction2D]
              -> l a
              -> ModifiedLayout AvoidStruts l a
avoidStrutsOn :: forall (l :: * -> *) a.
LayoutClass l a =>
[Direction2D] -> l a -> ModifiedLayout AvoidStruts l a
avoidStrutsOn [Direction2D]
ss = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout forall a b. (a -> b) -> a -> b
$ forall a. Set Direction2D -> AvoidStruts a
AvoidStruts (forall a. Ord a => [a] -> Set a
S.fromList [Direction2D]
ss)

newtype AvoidStruts a = AvoidStruts (S.Set Direction2D) deriving ( ReadPrec [AvoidStruts a]
ReadPrec (AvoidStruts a)
ReadS [AvoidStruts a]
forall a. ReadPrec [AvoidStruts a]
forall a. ReadPrec (AvoidStruts a)
forall a. Int -> ReadS (AvoidStruts a)
forall a. ReadS [AvoidStruts a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AvoidStruts a]
$creadListPrec :: forall a. ReadPrec [AvoidStruts a]
readPrec :: ReadPrec (AvoidStruts a)
$creadPrec :: forall a. ReadPrec (AvoidStruts a)
readList :: ReadS [AvoidStruts a]
$creadList :: forall a. ReadS [AvoidStruts a]
readsPrec :: Int -> ReadS (AvoidStruts a)
$creadsPrec :: forall a. Int -> ReadS (AvoidStruts a)
Read, Int -> AvoidStruts a -> ShowS
forall a. Int -> AvoidStruts a -> ShowS
forall a. [AvoidStruts a] -> ShowS
forall a. AvoidStruts a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AvoidStruts a] -> ShowS
$cshowList :: forall a. [AvoidStruts a] -> ShowS
show :: AvoidStruts a -> String
$cshow :: forall a. AvoidStruts a -> String
showsPrec :: Int -> AvoidStruts a -> ShowS
$cshowsPrec :: forall a. Int -> AvoidStruts a -> ShowS
Show )

-- | Message type which can be sent to an 'AvoidStruts' layout
--   modifier to alter its behavior.
data ToggleStruts = ToggleStruts
                  | ToggleStrut Direction2D
  deriving (ReadPrec [ToggleStruts]
ReadPrec ToggleStruts
Int -> ReadS ToggleStruts
ReadS [ToggleStruts]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ToggleStruts]
$creadListPrec :: ReadPrec [ToggleStruts]
readPrec :: ReadPrec ToggleStruts
$creadPrec :: ReadPrec ToggleStruts
readList :: ReadS [ToggleStruts]
$creadList :: ReadS [ToggleStruts]
readsPrec :: Int -> ReadS ToggleStruts
$creadsPrec :: Int -> ReadS ToggleStruts
Read,Int -> ToggleStruts -> ShowS
[ToggleStruts] -> ShowS
ToggleStruts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ToggleStruts] -> ShowS
$cshowList :: [ToggleStruts] -> ShowS
show :: ToggleStruts -> String
$cshow :: ToggleStruts -> String
showsPrec :: Int -> ToggleStruts -> ShowS
$cshowsPrec :: Int -> ToggleStruts -> ShowS
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 { SetStruts -> [Direction2D]
addedStruts   :: [Direction2D]
                           , SetStruts -> [Direction2D]
removedStruts :: [Direction2D] -- ^ These are removed from the currently set struts before 'addedStruts' are added.
                           }
  deriving (ReadPrec [SetStruts]
ReadPrec SetStruts
Int -> ReadS SetStruts
ReadS [SetStruts]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SetStruts]
$creadListPrec :: ReadPrec [SetStruts]
readPrec :: ReadPrec SetStruts
$creadPrec :: ReadPrec SetStruts
readList :: ReadS [SetStruts]
$creadList :: ReadS [SetStruts]
readsPrec :: Int -> ReadS SetStruts
$creadsPrec :: Int -> ReadS SetStruts
Read,Int -> SetStruts -> ShowS
[SetStruts] -> ShowS
SetStruts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SetStruts] -> ShowS
$cshowList :: [SetStruts] -> ShowS
show :: SetStruts -> String
$cshow :: SetStruts -> String
showsPrec :: Int -> SetStruts -> ShowS
$cshowsPrec :: Int -> SetStruts -> ShowS
Show)

instance Message SetStruts

instance LayoutModifier AvoidStruts a where
    modifyLayout :: forall (l :: * -> *).
LayoutClass l a =>
AvoidStruts a
-> Workspace String (l a) a
-> Rectangle
-> X ([(a, Rectangle)], Maybe (l a))
modifyLayout (AvoidStruts Set Direction2D
ss) Workspace String (l a) a
w Rectangle
r = do
        Rectangle
srect <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ Rectangle
r) (Set Direction2D -> X (Rectangle -> Rectangle)
calcGap Set Direction2D
ss)
        -- Ensure _NET_WORKAREA is not set.
        -- See: https://github.com/xmonad/xmonad-contrib/pull/79
        X ()
rmWorkarea
        forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l a) a
w Rectangle
srect

    pureMess :: AvoidStruts a -> SomeMessage -> Maybe (AvoidStruts a)
pureMess as :: AvoidStruts a
as@(AvoidStruts Set Direction2D
ss) SomeMessage
m
        | Just ToggleStruts
ToggleStruts    <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Set Direction2D -> AvoidStruts a
AvoidStruts (forall {a} {a}. (Ord a, Bounded a, Enum a) => Set a -> Set a
toggleAll Set Direction2D
ss)
        | Just (ToggleStrut Direction2D
s) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Set Direction2D -> AvoidStruts a
AvoidStruts (forall {a}. Ord a => a -> Set a -> Set a
toggleOne Direction2D
s Set Direction2D
ss)
        | Just (SetStruts [Direction2D]
n [Direction2D]
k) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m
        , let newSS :: Set Direction2D
newSS = forall a. Ord a => [a] -> Set a
S.fromList [Direction2D]
n forall a. Ord a => Set a -> Set a -> Set a
`S.union` (Set Direction2D
ss forall a. Ord a => Set a -> Set a -> Set a
S.\\ forall a. Ord a => [a] -> Set a
S.fromList [Direction2D]
k)
        , Set Direction2D
newSS forall a. Eq a => a -> a -> Bool
/= Set Direction2D
ss = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Set Direction2D -> AvoidStruts a
AvoidStruts Set Direction2D
newSS
        | Just UpdateDocks
UpdateDocks <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = forall a. a -> Maybe a
Just AvoidStruts a
as
        | Bool
otherwise = forall a. Maybe a
Nothing
      where toggleAll :: Set a -> Set a
toggleAll Set a
x | forall a. Set a -> Bool
S.null Set a
x = forall a. Ord a => [a] -> Set a
S.fromList [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
                        | Bool
otherwise = forall a. Set a
S.empty
            toggleOne :: a -> Set a -> Set a
toggleOne a
x Set a
xs | a
x forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
xs = forall {a}. Ord a => a -> Set a -> Set a
S.delete a
x Set a
xs
                           | Bool
otherwise   = a
x forall {a}. Ord a => a -> Set a -> Set a
`S.insert` Set a
xs

rmWorkarea :: X ()
rmWorkarea :: X ()
rmWorkarea = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    EventMask
a <- String -> X EventMask
getAtom String
"_NET_WORKAREA"
    EventMask
r <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> EventMask
theRoot
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> EventMask -> EventMask -> IO ()
deleteProperty Display
dpy EventMask
r EventMask
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 (RectC -> RectC -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RectC -> RectC -> Bool
$c/= :: RectC -> RectC -> Bool
== :: RectC -> RectC -> Bool
$c== :: RectC -> RectC -> Bool
Eq,Int -> RectC -> ShowS
[RectC] -> ShowS
RectC -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RectC] -> ShowS
$cshowList :: [RectC] -> ShowS
show :: RectC -> String
$cshow :: RectC -> String
showsPrec :: Int -> RectC -> ShowS
$cshowsPrec :: Int -> RectC -> ShowS
Show)

-- | Invertible conversion.

r2c :: Rectangle -> RectC
r2c :: Rectangle -> RectC
r2c (Rectangle Position
x Position
y Dimension
w Dimension
h) = (CLong, CLong, CLong, CLong) -> RectC
RectC (forall a b. (Integral a, Num b) => a -> b
fi Position
x, forall a b. (Integral a, Num b) => a -> b
fi Position
y, forall a b. (Integral a, Num b) => a -> b
fi Position
x forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
w forall a. Num a => a -> a -> a
- CLong
1, forall a b. (Integral a, Num b) => a -> b
fi Position
y forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
h forall a. Num a => a -> a -> a
- CLong
1)

-- | Invertible conversion.

c2r :: RectC -> Rectangle
c2r :: RectC -> Rectangle
c2r (RectC (CLong
x1, CLong
y1, CLong
x2, CLong
y2)) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (forall a b. (Integral a, Num b) => a -> b
fi CLong
x1) (forall a b. (Integral a, Num b) => a -> b
fi CLong
y1) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ CLong
x2 forall a. Num a => a -> a -> a
- CLong
x1 forall a. Num a => a -> a -> a
+ CLong
1) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ CLong
y2 forall a. Num a => a -> a -> a
- CLong
y1 forall a. Num a => a -> a -> a
+ CLong
1)


reduce :: RectC -> Strut -> RectC -> RectC
reduce :: RectC -> Strut -> RectC -> RectC
reduce (RectC (CLong
sx0, CLong
sy0, CLong
sx1, CLong
sy1)) (Direction2D
s, CLong
n, CLong
l, CLong
h) (RectC (CLong
x0, CLong
y0, CLong
x1, CLong
y1)) =
 (CLong, CLong, CLong, CLong) -> RectC
RectC forall a b. (a -> b) -> a -> b
$ case Direction2D
s of
    Direction2D
L | (CLong, CLong) -> Bool
p (CLong
y0, CLong
y1) Bool -> Bool -> Bool
&& CLong -> Bool
qh CLong
x1     -> (CLong -> CLong -> CLong
mx CLong
x0 CLong
sx0, CLong
y0       , CLong
x1       , CLong
y1       )
    Direction2D
R | (CLong, CLong) -> Bool
p (CLong
y0, CLong
y1) Bool -> Bool -> Bool
&& CLong -> CLong -> Bool
qv CLong
sx1 CLong
x0 -> (CLong
x0       , CLong
y0       , CLong -> CLong -> CLong
mn CLong
x1 CLong
sx1, CLong
y1       )
    Direction2D
U | (CLong, CLong) -> Bool
p (CLong
x0, CLong
x1) Bool -> Bool -> Bool
&& CLong -> Bool
qh CLong
y1     -> (CLong
x0       , CLong -> CLong -> CLong
mx CLong
y0 CLong
sy0, CLong
x1       , CLong
y1       )
    Direction2D
D | (CLong, CLong) -> Bool
p (CLong
x0, CLong
x1) Bool -> Bool -> Bool
&& CLong -> CLong -> Bool
qv CLong
sy1 CLong
y0 -> (CLong
x0       , CLong
y0       , CLong
x1       , CLong -> CLong -> CLong
mn CLong
y1 CLong
sy1)
    Direction2D
_                           -> (CLong
x0       , CLong
y0       , CLong
x1       , CLong
y1       )
 where
    mx :: CLong -> CLong -> CLong
mx CLong
a CLong
b = forall a. Ord a => a -> a -> a
max CLong
a (CLong
b forall a. Num a => a -> a -> a
+ CLong
n)
    mn :: CLong -> CLong -> CLong
mn CLong
a CLong
b = forall a. Ord a => a -> a -> a
min CLong
a (CLong
b forall a. Num a => a -> a -> a
- CLong
n)
    p :: (CLong, CLong) -> Bool
p (CLong, CLong)
r = (CLong, CLong)
r forall a. Ord a => (a, a) -> (a, a) -> Bool
`overlaps` (CLong
l, CLong
h)
    -- Filter out struts that cover the entire rectangle:
    qh :: CLong -> Bool
qh CLong
d1 = CLong
n forall a. Ord a => a -> a -> Bool
<= CLong
d1
    qv :: CLong -> CLong -> Bool
qv CLong
sd1 CLong
d0 = CLong
sd1 forall a. Num a => a -> a -> a
- CLong
n forall a. Ord a => a -> a -> Bool
>= CLong
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
a, a
b) overlaps :: forall a. Ord a => (a, a) -> (a, a) -> Bool
`overlaps` (a
x, a
y) =
  forall {a}. Ord a => (a, a) -> a -> Bool
inRange (a
a, a
b) a
x Bool -> Bool -> Bool
|| forall {a}. Ord a => (a, a) -> a -> Bool
inRange (a
a, a
b) a
y Bool -> Bool -> Bool
|| forall {a}. Ord a => (a, a) -> a -> Bool
inRange (a
x, a
y) a
a
  where
  inRange :: (a, a) -> a -> Bool
inRange (a
i, a
j) a
k = a
i forall a. Ord a => a -> a -> Bool
<= a
k Bool -> Bool -> Bool
&& a
k forall a. Ord a => a -> a -> Bool
<= a
j