{-# 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 :: XConfig a -> XConfig a
docks XConfig a
c = XConfig a
c { startupHook :: X ()
startupHook     = X ()
docksStartupHook X () -> X () -> X ()
forall m. Monoid m => m -> m -> m
<+> XConfig a -> X ()
forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig a
c
            , handleEventHook :: Event -> X All
handleEventHook = Event -> X All
docksEventHook (Event -> X All) -> (Event -> X All) -> Event -> X All
forall m. Monoid m => m -> m -> m
<+> XConfig a -> Event -> X All
forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig a
c
            , manageHook :: ManageHook
manageHook      = ManageHook
manageDocks ManageHook -> ManageHook -> ManageHook
forall m. Monoid m => m -> m -> m
<+> XConfig a -> ManageHook
forall (l :: * -> *). XConfig l -> ManageHook
manageHook XConfig a
c }

type WindowStruts = M.Map Window [Strut]

data UpdateDocks = UpdateDocks
instance Message UpdateDocks

refreshDocks :: X ()
refreshDocks :: X ()
refreshDocks = UpdateDocks -> X ()
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
(StrutCache -> StrutCache -> Bool)
-> (StrutCache -> StrutCache -> Bool) -> Eq StrutCache
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 Maybe WindowStruts
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 = (StrutCache -> X StrutCache) -> X Bool
forall a (m :: * -> *).
(ExtensionClass a, Eq a, XLike m) =>
(a -> m a) -> m Bool
XS.modifiedM ((StrutCache -> X StrutCache) -> X Bool)
-> (StrutCache -> X StrutCache) -> X Bool
forall a b. (a -> b) -> a -> b
$ (WindowStruts -> StrutCache) -> X WindowStruts -> X StrutCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe WindowStruts -> StrutCache
StrutCache (Maybe WindowStruts -> StrutCache)
-> (WindowStruts -> Maybe WindowStruts)
-> WindowStruts
-> StrutCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowStruts -> Maybe WindowStruts
forall a. a -> Maybe a
Just) (X WindowStruts -> X StrutCache)
-> (StrutCache -> X WindowStruts) -> StrutCache -> X StrutCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe WindowStruts -> X WindowStruts
f (Maybe WindowStruts -> X WindowStruts)
-> (StrutCache -> Maybe WindowStruts)
-> StrutCache
-> X WindowStruts
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 (Maybe WindowStruts -> X WindowStruts)
-> X (Maybe WindowStruts) -> X WindowStruts
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (StrutCache -> Maybe WindowStruts) -> X (Maybe WindowStruts)
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets StrutCache -> Maybe WindowStruts
fromStrutCache
    WindowStruts
cache WindowStruts -> X () -> X WindowStruts
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ StrutCache -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Maybe WindowStruts -> StrutCache
StrutCache (WindowStruts -> Maybe WindowStruts
forall a. a -> Maybe a
Just WindowStruts
cache))

updateStrutCache :: Window -> X Bool
updateStrutCache :: Window -> X Bool
updateStrutCache Window
w = (Maybe WindowStruts -> X WindowStruts) -> X Bool
modifiedStrutCache ((Maybe WindowStruts -> X WindowStruts) -> X Bool)
-> (Maybe WindowStruts -> X WindowStruts) -> X Bool
forall a b. (a -> b) -> a -> b
$ Window -> WindowStruts -> X WindowStruts
updateStrut Window
w (WindowStruts -> X WindowStruts)
-> (Maybe WindowStruts -> X WindowStruts)
-> Maybe WindowStruts
-> X WindowStruts
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 :: Window -> X Bool
deleteFromStrutCache Window
w = (Maybe WindowStruts -> X WindowStruts) -> X Bool
modifiedStrutCache ((Maybe WindowStruts -> X WindowStruts) -> X Bool)
-> (Maybe WindowStruts -> X WindowStruts) -> X Bool
forall a b. (a -> b) -> a -> b
$ (WindowStruts -> WindowStruts) -> X WindowStruts -> X WindowStruts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Window -> WindowStruts -> WindowStruts
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Window
w) (X WindowStruts -> X WindowStruts)
-> (Maybe WindowStruts -> X WindowStruts)
-> Maybe WindowStruts
-> X WindowStruts
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 = X WindowStruts
-> (WindowStruts -> X WindowStruts)
-> Maybe WindowStruts
-> X WindowStruts
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (X [Window]
queryDocks X [Window] -> ([Window] -> X WindowStruts) -> X WindowStruts
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (WindowStruts -> Window -> X WindowStruts)
-> WindowStruts -> [Window] -> X WindowStruts
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ((Window -> WindowStruts -> X WindowStruts)
-> WindowStruts -> Window -> X WindowStruts
forall a b c. (a -> b -> c) -> b -> a -> c
flip Window -> WindowStruts -> X WindowStruts
updateStrut) WindowStruts
forall k a. Map k a
M.empty) WindowStruts -> X WindowStruts
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    queryDocks :: X [Window]
queryDocks = (Display -> X [Window]) -> X [Window]
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X [Window]) -> X [Window])
-> (Display -> X [Window]) -> X [Window]
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
        (Window
_, Window
_, [Window]
wins) <- IO (Window, Window, [Window]) -> X (Window, Window, [Window])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Window, Window, [Window]) -> X (Window, Window, [Window]))
-> (Window -> IO (Window, Window, [Window]))
-> Window
-> X (Window, Window, [Window])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> Window -> IO (Window, Window, [Window])
queryTree Display
dpy (Window -> X (Window, Window, [Window]))
-> X Window -> X (Window, Window, [Window])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
        (Window -> X Bool) -> [Window] -> X [Window]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Query Bool -> Window -> X Bool
forall a. Query a -> Window -> X a
runQuery Query Bool
checkDock) [Window]
wins

updateStrut :: Window -> WindowStruts -> X WindowStruts
updateStrut :: Window -> WindowStruts -> X WindowStruts
updateStrut Window
w WindowStruts
cache = do
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
w Window -> WindowStruts -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` WindowStruts
cache) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ Window -> X ()
requestDockEvents Window
w
    [Strut]
strut <- Window -> X [Strut]
getStrut Window
w
    WindowStruts -> X WindowStruts
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WindowStruts -> X WindowStruts) -> WindowStruts -> X WindowStruts
forall a b. (a -> b) -> a -> b
$ Window -> [Strut] -> WindowStruts -> WindowStruts
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Window
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 :: ManageHook
manageDocks = Query Bool
checkDock Query Bool -> ManageHook -> ManageHook
forall (m :: * -> *) a. (Monad m, Monoid a) => m Bool -> m a -> m a
--> (ManageHook
doIgnore ManageHook -> ManageHook -> ManageHook
forall m. Monoid m => m -> m -> m
<+> ManageHook
doRequestDockEvents)
  where
    doRequestDockEvents :: ManageHook
doRequestDockEvents = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query ()) -> Query ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= X () -> Query ()
forall a. X a -> Query a
liftX (X () -> Query ()) -> (Window -> X ()) -> Window -> Query ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> X ()
requestDockEvents Query () -> ManageHook -> ManageHook
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ManageHook
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 :: Window -> X ()
requestDockEvents Window
w = X Bool -> X () -> X ()
whenX (Bool -> Bool
not (Bool -> Bool) -> X Bool -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Window -> X Bool
isClient Window
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy ->
    Display -> Window -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes Display
dpy Window
w ((WindowAttributes -> X ()) -> X ())
-> (WindowAttributes -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowAttributes
attrs -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO ()
selectInput Display
dpy Window
w (Window -> IO ()) -> Window -> IO ()
forall a b. (a -> b) -> a -> b
$
        WindowAttributes -> Window
wa_your_event_mask WindowAttributes
attrs Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
propertyChangeMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
structureNotifyMask

-- | Checks if a window is a DOCK or DESKTOP window
checkDock :: Query Bool
checkDock :: Query Bool
checkDock = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query Bool) -> Query Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> X Bool -> Query Bool
forall a. X a -> Query a
liftX (X Bool -> Query Bool) -> X Bool -> Query Bool
forall a b. (a -> b) -> a -> b
$ do
    Window
dock <- String -> X Window
getAtom String
"_NET_WM_WINDOW_TYPE_DOCK"
    Window
desk <- String -> X Window
getAtom String
"_NET_WM_WINDOW_TYPE_DESKTOP"
    Maybe [CLong]
mbr <- String -> Window -> X (Maybe [CLong])
getProp32s String
"_NET_WM_WINDOW_TYPE" Window
w
    case Maybe [CLong]
mbr of
        Just [CLong]
rs -> Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> X Bool) -> Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ (CLong -> Bool) -> [CLong] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Window -> [Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window
dock,Window
desk]) (Window -> Bool) -> (CLong -> Window) -> CLong -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> Window
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [CLong]
rs
        Maybe [CLong]
_       -> Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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 :: Event -> X All
docksEventHook MapNotifyEvent{ ev_window :: Event -> Window
ev_window = Window
w } = do
    X Bool -> X () -> X ()
whenX (Query Bool -> Window -> X Bool
forall a. Query a -> Window -> X a
runQuery Query Bool
checkDock Window
w X Bool -> X Bool -> X Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> (Bool -> Bool
not (Bool -> Bool) -> X Bool -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Window -> X Bool
isClient Window
w)) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
        X Bool -> X () -> X ()
whenX (Window -> X Bool
updateStrutCache Window
w) X ()
refreshDocks
    All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
docksEventHook PropertyEvent{ ev_window :: Event -> Window
ev_window = Window
w
                            , ev_atom :: Event -> Window
ev_atom = Window
a } = do
    Window
nws <- String -> X Window
getAtom String
"_NET_WM_STRUT"
    Window
nwsp <- String -> X Window
getAtom String
"_NET_WM_STRUT_PARTIAL"
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
a Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
nws Bool -> Bool -> Bool
|| Window
a Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
nwsp) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
        X Bool -> X () -> X ()
whenX (Window -> X Bool
updateStrutCache Window
w) X ()
refreshDocks
    All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
docksEventHook DestroyWindowEvent{ ev_window :: Event -> Window
ev_window = Window
w } = do
    X Bool -> X () -> X ()
whenX (Window -> X Bool
deleteFromStrutCache Window
w) X ()
refreshDocks
    All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
docksEventHook Event
_ = All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

{-# DEPRECATED docksStartupHook "Use docks instead." #-}
docksStartupHook :: X ()
docksStartupHook :: X ()
docksStartupHook = X WindowStruts -> X ()
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 :: Window -> X [Strut]
getStrut Window
w = do
    Maybe [CLong]
msp <- String -> Window -> X (Maybe [CLong])
getProp32s String
"_NET_WM_STRUT_PARTIAL" Window
w
    case Maybe [CLong]
msp of
        Just [CLong]
sp -> [Strut] -> X [Strut]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Strut] -> X [Strut]) -> [Strut] -> X [Strut]
forall a b. (a -> b) -> a -> b
$ [CLong] -> [Strut]
forall d. (Eq d, Num d) => [d] -> [(Direction2D, d, d, d)]
parseStrutPartial [CLong]
sp
        Maybe [CLong]
Nothing -> [Strut] -> ([CLong] -> [Strut]) -> Maybe [CLong] -> [Strut]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [CLong] -> [Strut]
forall d.
(Eq d, Num d, Bounded d) =>
[d] -> [(Direction2D, d, d, d)]
parseStrut (Maybe [CLong] -> [Strut]) -> X (Maybe [CLong]) -> X [Strut]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Window -> X (Maybe [CLong])
getProp32s String
"_NET_WM_STRUT" Window
w
 where
    parseStrut :: [d] -> [(Direction2D, d, d, d)]
parseStrut xs :: [d]
xs@[d
_, d
_, d
_, d
_] = [d] -> [(Direction2D, d, d, d)]
forall d. (Eq d, Num d) => [d] -> [(Direction2D, d, d, d)]
parseStrutPartial ([d] -> [(Direction2D, d, d, d)])
-> ([d] -> [d]) -> [d] -> [(Direction2D, d, d, d)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [d] -> [d]
forall a. Int -> [a] -> [a]
take Int
12 ([d] -> [(Direction2D, d, d, d)])
-> [d] -> [(Direction2D, d, d, d)]
forall a b. (a -> b) -> a -> b
$ [d]
xs [d] -> [d] -> [d]
forall a. [a] -> [a] -> [a]
++ [d] -> [d]
forall a. [a] -> [a]
cycle [d
forall a. Bounded a => a
minBound, d
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]
     = ((Direction2D, d, d, d) -> Bool)
-> [(Direction2D, d, d, d)] -> [(Direction2D, d, d, d)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Direction2D
_, d
n, d
_, d
_) -> d
n d -> d -> Bool
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 = (Display -> X (Rectangle -> Rectangle))
-> X (Rectangle -> Rectangle)
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (Rectangle -> Rectangle))
 -> X (Rectangle -> Rectangle))
-> (Display -> X (Rectangle -> Rectangle))
-> X (Rectangle -> Rectangle)
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    Window
rootw <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
    [Strut]
struts <- (Strut -> Bool) -> [Strut] -> [Strut]
forall a. (a -> Bool) -> [a] -> [a]
filter Strut -> Bool
forall b c d. (Direction2D, b, c, d) -> Bool
careAbout ([Strut] -> [Strut])
-> (WindowStruts -> [Strut]) -> WindowStruts -> [Strut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Strut]] -> [Strut]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Strut]] -> [Strut])
-> (WindowStruts -> [[Strut]]) -> WindowStruts -> [Strut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowStruts -> [[Strut]]
forall k a. Map k a -> [a]
M.elems (WindowStruts -> [Strut]) -> X WindowStruts -> X [Strut]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> X WindowStruts
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
    WindowAttributes
wa <- IO WindowAttributes -> X WindowAttributes
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO WindowAttributes -> X WindowAttributes)
-> IO WindowAttributes -> X WindowAttributes
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO WindowAttributes
getWindowAttributes Display
dpy Window
rootw
    let screen :: RectC
screen = Rectangle -> RectC
r2c (Rectangle -> RectC) -> Rectangle -> RectC
forall a b. (a -> b) -> a -> b
$ Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_x WindowAttributes
wa) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_y WindowAttributes
wa) (CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_width WindowAttributes
wa) (CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_height WindowAttributes
wa)
    (Rectangle -> Rectangle) -> X (Rectangle -> Rectangle)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Rectangle -> Rectangle) -> X (Rectangle -> Rectangle))
-> (Rectangle -> Rectangle) -> X (Rectangle -> Rectangle)
forall a b. (a -> b) -> a -> b
$ \Rectangle
r -> RectC -> Rectangle
c2r (RectC -> Rectangle) -> RectC -> Rectangle
forall a b. (a -> b) -> a -> b
$ (Strut -> RectC -> RectC) -> RectC -> [Strut] -> RectC
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 Direction2D -> Set Direction2D -> Bool
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.
avoidStruts :: LayoutClass l a => l a -> ModifiedLayout AvoidStruts l a
avoidStruts :: l a -> ModifiedLayout AvoidStruts l a
avoidStruts = [Direction2D] -> l a -> ModifiedLayout AvoidStruts l a
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).
avoidStrutsOn :: LayoutClass l a =>
                 [Direction2D]
              -> l a
              -> ModifiedLayout AvoidStruts l a
avoidStrutsOn :: [Direction2D] -> l a -> ModifiedLayout AvoidStruts l a
avoidStrutsOn [Direction2D]
ss = AvoidStruts a -> l a -> ModifiedLayout AvoidStruts l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (AvoidStruts a -> l a -> ModifiedLayout AvoidStruts l a)
-> AvoidStruts a -> l a -> ModifiedLayout AvoidStruts l a
forall a b. (a -> b) -> a -> b
$ Set Direction2D -> AvoidStruts a
forall a. Set Direction2D -> AvoidStruts a
AvoidStruts ([Direction2D] -> Set Direction2D
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)
Int -> ReadS (AvoidStruts a)
ReadS [AvoidStruts a]
(Int -> ReadS (AvoidStruts a))
-> ReadS [AvoidStruts a]
-> ReadPrec (AvoidStruts a)
-> ReadPrec [AvoidStruts a]
-> Read (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
[AvoidStruts a] -> ShowS
AvoidStruts a -> String
(Int -> AvoidStruts a -> ShowS)
-> (AvoidStruts a -> String)
-> ([AvoidStruts a] -> ShowS)
-> Show (AvoidStruts a)
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]
(Int -> ReadS ToggleStruts)
-> ReadS [ToggleStruts]
-> ReadPrec ToggleStruts
-> ReadPrec [ToggleStruts]
-> Read 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
(Int -> ToggleStruts -> ShowS)
-> (ToggleStruts -> String)
-> ([ToggleStruts] -> ShowS)
-> Show ToggleStruts
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]
(Int -> ReadS SetStruts)
-> ReadS [SetStruts]
-> ReadPrec SetStruts
-> ReadPrec [SetStruts]
-> Read 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
(Int -> SetStruts -> ShowS)
-> (SetStruts -> String)
-> ([SetStruts] -> ShowS)
-> Show SetStruts
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 :: 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 <- ((Rectangle -> Rectangle) -> Rectangle)
-> X (Rectangle -> Rectangle) -> X Rectangle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Rectangle -> Rectangle) -> Rectangle -> Rectangle
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
        Workspace String (l a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (l a))
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    <- SomeMessage -> Maybe ToggleStruts
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = AvoidStruts a -> Maybe (AvoidStruts a)
forall a. a -> Maybe a
Just (AvoidStruts a -> Maybe (AvoidStruts a))
-> AvoidStruts a -> Maybe (AvoidStruts a)
forall a b. (a -> b) -> a -> b
$ Set Direction2D -> AvoidStruts a
forall a. Set Direction2D -> AvoidStruts a
AvoidStruts (Set Direction2D -> Set Direction2D
forall a a. (Ord a, Bounded a, Enum a) => Set a -> Set a
toggleAll Set Direction2D
ss)
        | Just (ToggleStrut Direction2D
s) <- SomeMessage -> Maybe ToggleStruts
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = AvoidStruts a -> Maybe (AvoidStruts a)
forall a. a -> Maybe a
Just (AvoidStruts a -> Maybe (AvoidStruts a))
-> AvoidStruts a -> Maybe (AvoidStruts a)
forall a b. (a -> b) -> a -> b
$ Set Direction2D -> AvoidStruts a
forall a. Set Direction2D -> AvoidStruts a
AvoidStruts (Direction2D -> Set Direction2D -> Set Direction2D
forall a. Ord a => a -> Set a -> Set a
toggleOne Direction2D
s Set Direction2D
ss)
        | Just (SetStruts [Direction2D]
n [Direction2D]
k) <- SomeMessage -> Maybe SetStruts
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m
        , let newSS :: Set Direction2D
newSS = [Direction2D] -> Set Direction2D
forall a. Ord a => [a] -> Set a
S.fromList [Direction2D]
n Set Direction2D -> Set Direction2D -> Set Direction2D
forall a. Ord a => Set a -> Set a -> Set a
`S.union` (Set Direction2D
ss Set Direction2D -> Set Direction2D -> Set Direction2D
forall a. Ord a => Set a -> Set a -> Set a
S.\\ [Direction2D] -> Set Direction2D
forall a. Ord a => [a] -> Set a
S.fromList [Direction2D]
k)
        , Set Direction2D
newSS Set Direction2D -> Set Direction2D -> Bool
forall a. Eq a => a -> a -> Bool
/= Set Direction2D
ss = AvoidStruts a -> Maybe (AvoidStruts a)
forall a. a -> Maybe a
Just (AvoidStruts a -> Maybe (AvoidStruts a))
-> AvoidStruts a -> Maybe (AvoidStruts a)
forall a b. (a -> b) -> a -> b
$ Set Direction2D -> AvoidStruts a
forall a. Set Direction2D -> AvoidStruts a
AvoidStruts Set Direction2D
newSS
        | Just UpdateDocks
UpdateDocks <- SomeMessage -> Maybe UpdateDocks
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = AvoidStruts a -> Maybe (AvoidStruts a)
forall a. a -> Maybe a
Just AvoidStruts a
as
        | Bool
otherwise = Maybe (AvoidStruts a)
forall a. Maybe a
Nothing
      where toggleAll :: Set a -> Set a
toggleAll Set a
x | Set a -> Bool
forall a. Set a -> Bool
S.null Set a
x = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound]
                        | Bool
otherwise = Set a
forall a. Set a
S.empty
            toggleOne :: a -> Set a -> Set a
toggleOne a
x Set a
xs | a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
xs = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
x Set a
xs
                           | Bool
otherwise   = a
x a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
`S.insert` Set a
xs

rmWorkarea :: X ()
rmWorkarea :: X ()
rmWorkarea = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    Window
a <- String -> X Window
getAtom String
"_NET_WORKAREA"
    Window
r <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> Window -> Window -> IO ()
deleteProperty Display
dpy Window
r Window
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
(RectC -> RectC -> Bool) -> (RectC -> RectC -> Bool) -> Eq RectC
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
(Int -> RectC -> ShowS)
-> (RectC -> String) -> ([RectC] -> ShowS) -> Show RectC
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 (Position -> CLong
forall a b. (Integral a, Num b) => a -> b
fi Position
x, Position -> CLong
forall a b. (Integral a, Num b) => a -> b
fi Position
y, Position -> CLong
forall a b. (Integral a, Num b) => a -> b
fi Position
x CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
+ Dimension -> CLong
forall a b. (Integral a, Num b) => a -> b
fi Dimension
w CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
- CLong
1, Position -> CLong
forall a b. (Integral a, Num b) => a -> b
fi Position
y CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
+ Dimension -> CLong
forall a b. (Integral a, Num b) => a -> b
fi Dimension
h CLong -> CLong -> CLong
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 (CLong -> Position
forall a b. (Integral a, Num b) => a -> b
fi CLong
x1) (CLong -> Position
forall a b. (Integral a, Num b) => a -> b
fi CLong
y1) (CLong -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (CLong -> Dimension) -> CLong -> Dimension
forall a b. (a -> b) -> a -> b
$ CLong
x2 CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
- CLong
x1 CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
+ CLong
1) (CLong -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (CLong -> Dimension) -> CLong -> Dimension
forall a b. (a -> b) -> a -> b
$ CLong
y2 CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
- CLong
y1 CLong -> CLong -> CLong
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 ((CLong, CLong, CLong, CLong) -> RectC)
-> (CLong, CLong, CLong, CLong) -> 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 = CLong -> CLong -> CLong
forall a. Ord a => a -> a -> a
max CLong
a (CLong
b CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
+ CLong
n)
    mn :: CLong -> CLong -> CLong
mn CLong
a CLong
b = CLong -> CLong -> CLong
forall a. Ord a => a -> a -> a
min CLong
a (CLong
b CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
- CLong
n)
    p :: (CLong, CLong) -> Bool
p (CLong, CLong)
r = (CLong, CLong)
r (CLong, CLong) -> (CLong, CLong) -> Bool
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 CLong -> CLong -> Bool
forall a. Ord a => a -> a -> Bool
<= CLong
d1
    qv :: CLong -> CLong -> Bool
qv CLong
sd1 CLong
d0 = CLong
sd1 CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
- CLong
n CLong -> CLong -> Bool
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 :: (a, a) -> (a, a) -> Bool
`overlaps` (a
x, a
y) =
  (a, a) -> a -> Bool
forall a. Ord a => (a, a) -> a -> Bool
inRange (a
a, a
b) a
x Bool -> Bool -> Bool
|| (a, a) -> a -> Bool
forall a. Ord a => (a, a) -> a -> Bool
inRange (a
a, a
b) a
y Bool -> Bool -> Bool
|| (a, a) -> a -> 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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
k Bool -> Bool -> Bool
&& a
k a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
j