{-# 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\/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 :: forall (a :: * -> *). XConfig a -> XConfig a
docks XConfig a
c = XConfig a
c { startupHook :: X ()
startupHook     = X ()
docksStartupHook X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> 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 a. Semigroup a => a -> a -> a
<> 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 a. Semigroup a => a -> a -> a
<> 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 :: EventMask -> X Bool
updateStrutCache EventMask
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
$ EventMask -> WindowStruts -> X WindowStruts
updateStrut EventMask
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 :: EventMask -> X Bool
deleteFromStrutCache EventMask
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 (EventMask -> WindowStruts -> WindowStruts
forall k a. Ord k => k -> Map k a -> Map k a
M.delete EventMask
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 [EventMask]
queryDocks X [EventMask] -> ([EventMask] -> X WindowStruts) -> X WindowStruts
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (WindowStruts -> EventMask -> X WindowStruts)
-> WindowStruts -> [EventMask] -> X WindowStruts
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ((EventMask -> WindowStruts -> X WindowStruts)
-> WindowStruts -> EventMask -> X WindowStruts
forall a b c. (a -> b -> c) -> b -> a -> c
flip EventMask -> 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 [EventMask]
queryDocks = (Display -> X [EventMask]) -> X [EventMask]
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X [EventMask]) -> X [EventMask])
-> (Display -> X [EventMask]) -> X [EventMask]
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
        (EventMask
_, EventMask
_, [EventMask]
wins) <- IO (EventMask, EventMask, [EventMask])
-> X (EventMask, EventMask, [EventMask])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (EventMask, EventMask, [EventMask])
 -> X (EventMask, EventMask, [EventMask]))
-> (EventMask -> IO (EventMask, EventMask, [EventMask]))
-> EventMask
-> X (EventMask, EventMask, [EventMask])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> EventMask -> IO (EventMask, EventMask, [EventMask])
queryTree Display
dpy (EventMask -> X (EventMask, EventMask, [EventMask]))
-> X EventMask -> X (EventMask, EventMask, [EventMask])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XConf -> EventMask) -> X EventMask
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> EventMask
theRoot
        (EventMask -> X Bool) -> [EventMask] -> X [EventMask]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Query Bool -> EventMask -> X Bool
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
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventMask
w EventMask -> 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
$ EventMask -> X ()
requestDockEvents EventMask
w
    [Strut]
strut <- EventMask -> X [Strut]
getStrut EventMask
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
$ EventMask -> [Strut] -> WindowStruts -> WindowStruts
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 :: 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 a. Semigroup a => a -> a -> a
<> ManageHook
doRequestDockEvents)
  where
    doRequestDockEvents :: ManageHook
doRequestDockEvents = Query EventMask
forall r (m :: * -> *). MonadReader r m => m r
ask Query EventMask -> (EventMask -> 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 ()) -> (EventMask -> X ()) -> EventMask -> Query ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventMask -> 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 :: EventMask -> X ()
requestDockEvents EventMask
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
<$> EventMask -> X Bool
isClient EventMask
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 -> EventMask -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes Display
dpy EventMask
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 -> EventMask -> EventMask -> IO ()
selectInput Display
dpy EventMask
w (EventMask -> IO ()) -> EventMask -> IO ()
forall a b. (a -> b) -> a -> b
$
        WindowAttributes -> EventMask
wa_your_event_mask WindowAttributes
attrs EventMask -> EventMask -> EventMask
forall a. Bits a => a -> a -> a
.|. EventMask
propertyChangeMask EventMask -> EventMask -> EventMask
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 Query Bool -> Query Bool -> Query Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> (Bool -> Bool
not (Bool -> Bool) -> Query Bool -> Query Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query Bool
isXMonad)
  where
    isDockOrDesktop :: Query Bool
isDockOrDesktop = Query EventMask
forall r (m :: * -> *). MonadReader r m => m r
ask Query EventMask -> (EventMask -> Query Bool) -> Query Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EventMask
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
        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 -> 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 ((EventMask -> [EventMask] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EventMask
dock,EventMask
desk]) (EventMask -> Bool) -> (CLong -> EventMask) -> CLong -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> EventMask
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
    isXMonad :: Query Bool
isXMonad = Query String
className Query String -> String -> Query Bool
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 (Query Bool -> EventMask -> X Bool
forall a. Query a -> EventMask -> X a
runQuery Query Bool
checkDock EventMask
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
<$> EventMask -> X Bool
isClient EventMask
w)) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
        X Bool -> X () -> X ()
whenX (EventMask -> X Bool
updateStrutCache EventMask
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 -> 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"
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventMask
a EventMask -> EventMask -> Bool
forall a. Eq a => a -> a -> Bool
== EventMask
nws Bool -> Bool -> Bool
|| EventMask
a EventMask -> EventMask -> Bool
forall a. Eq a => a -> a -> Bool
== EventMask
nwsp) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
        X Bool -> X () -> X ()
whenX (EventMask -> X Bool
updateStrutCache EventMask
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 -> EventMask
ev_window = EventMask
w } = do
    X Bool -> X () -> X ()
whenX (EventMask -> X Bool
deleteFromStrutCache EventMask
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 :: 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 -> [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 -> 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
_] = [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 = do
    EventMask
rootw <- (XConf -> EventMask) -> X EventMask
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> EventMask
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

    -- 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 X (Maybe WindowAttributes)
-> (Maybe WindowAttributes -> X RectC) -> X RectC
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe WindowAttributes
Nothing -> (XState -> RectC) -> X RectC
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> RectC) -> X RectC) -> (XState -> RectC) -> X RectC
forall a b. (a -> b) -> a -> b
$ Rectangle -> RectC
r2c (Rectangle -> RectC) -> (XState -> Rectangle) -> XState -> RectC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (XState -> ScreenDetail) -> XState -> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout EventMask) EventMask ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail (Screen String (Layout EventMask) EventMask ScreenId ScreenDetail
 -> ScreenDetail)
-> (XState
    -> Screen
         String (Layout EventMask) EventMask ScreenId ScreenDetail)
-> XState
-> ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen String (Layout EventMask) EventMask ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (WindowSet
 -> Screen
      String (Layout EventMask) EventMask ScreenId ScreenDetail)
-> (XState -> WindowSet)
-> XState
-> Screen String (Layout EventMask) EventMask ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
        Just WindowAttributes
wa -> RectC -> X RectC
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RectC -> X RectC) -> (Rectangle -> RectC) -> Rectangle -> X RectC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> RectC
r2c (Rectangle -> X RectC) -> Rectangle -> X 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.
--
--   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 = [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). 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 = 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 :: 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 <- ((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
    EventMask
a <- String -> X EventMask
getAtom String
"_NET_WORKAREA"
    EventMask
r <- (XConf -> EventMask) -> X EventMask
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> EventMask
theRoot
    IO () -> X ()
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
(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 :: forall a. Ord a => (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