{-# LANGUAGE PatternGuards, FlexibleInstances, MultiParamTypeClasses, CPP, LambdaCase #-}
module XMonad.Hooks.ManageDocks (
docks, manageDocks, checkDock, AvoidStruts(..), avoidStruts, avoidStrutsOn,
ToggleStruts(..),
SetStruts(..),
module XMonad.Util.Types,
#ifdef TESTING
r2c,
c2r,
RectC(..),
#endif
calcGap,
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
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
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
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
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
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"
{-# 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
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]
_ = []
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
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
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]
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 )
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
data SetStruts = SetStruts { SetStruts -> [Direction2D]
addedStruts :: [Direction2D]
, SetStruts -> [Direction2D]
removedStruts :: [Direction2D]
}
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)
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)
type Strut = (Direction2D, CLong, CLong, CLong)
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)
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)
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)
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
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