{-# LANGUAGE DeriveDataTypeable, PatternGuards, FlexibleInstances, MultiParamTypeClasses, CPP #-}
module XMonad.Hooks.ManageDocks (
docks, manageDocks, checkDock, AvoidStruts, avoidStruts, avoidStrutsOn,
docksEventHook, docksStartupHook,
ToggleStruts(..),
SetStruts(..),
module XMonad.Util.Types,
#ifdef TESTING
r2c,
c2r,
RectC(..),
#endif
calcGap
) where
import XMonad
import Foreign.C.Types (CLong)
import XMonad.Layout.LayoutModifier
import XMonad.Util.Types
import XMonad.Util.WindowProperties (getProp32s)
import XMonad.Util.XUtils (fi)
import qualified XMonad.Util.ExtensibleState as XS
import Data.Monoid (All(..), mempty)
import Data.Functor((<$>))
import qualified Data.Set as S
import qualified Data.Map as M
import Control.Monad (when, forM_, filterM)
docks :: XConfig a -> XConfig a
docks :: XConfig a -> XConfig a
docks c :: 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 }
newtype StrutCache = StrutCache { StrutCache -> Map Window [Strut]
fromStrutCache :: M.Map Window [Strut] }
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, Typeable)
data UpdateDocks = UpdateDocks deriving Typeable
instance Message UpdateDocks
refreshDocks :: X ()
refreshDocks :: X ()
refreshDocks = UpdateDocks -> X ()
forall a. Message a => a -> X ()
sendMessage UpdateDocks
UpdateDocks
instance ExtensionClass StrutCache where
initialValue :: StrutCache
initialValue = Map Window [Strut] -> StrutCache
StrutCache Map Window [Strut]
forall k a. Map k a
M.empty
updateStrutCache :: Window -> [Strut] -> X Bool
updateStrutCache :: Window -> [Strut] -> X Bool
updateStrutCache w :: Window
w strut :: [Strut]
strut = do
(StrutCache -> StrutCache) -> X Bool
forall a (m :: * -> *).
(ExtensionClass a, Eq a, XLike m) =>
(a -> a) -> m Bool
XS.modified ((StrutCache -> StrutCache) -> X Bool)
-> (StrutCache -> StrutCache) -> X Bool
forall a b. (a -> b) -> a -> b
$ Map Window [Strut] -> StrutCache
StrutCache (Map Window [Strut] -> StrutCache)
-> (StrutCache -> Map Window [Strut]) -> StrutCache -> StrutCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> [Strut] -> Map Window [Strut] -> Map Window [Strut]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Window
w [Strut]
strut (Map Window [Strut] -> Map Window [Strut])
-> (StrutCache -> Map Window [Strut])
-> StrutCache
-> Map Window [Strut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrutCache -> Map Window [Strut]
fromStrutCache
deleteFromStructCache :: Window -> X Bool
deleteFromStructCache :: Window -> X Bool
deleteFromStructCache w :: Window
w = do
(StrutCache -> StrutCache) -> X Bool
forall a (m :: * -> *).
(ExtensionClass a, Eq a, XLike m) =>
(a -> a) -> m Bool
XS.modified ((StrutCache -> StrutCache) -> X Bool)
-> (StrutCache -> StrutCache) -> X Bool
forall a b. (a -> b) -> a -> b
$ Map Window [Strut] -> StrutCache
StrutCache (Map Window [Strut] -> StrutCache)
-> (StrutCache -> Map Window [Strut]) -> StrutCache -> StrutCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> Map Window [Strut] -> Map Window [Strut]
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Window
w (Map Window [Strut] -> Map Window [Strut])
-> (StrutCache -> Map Window [Strut])
-> StrutCache
-> Map Window [Strut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrutCache -> Map Window [Strut]
fromStrutCache
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
setDocksMask)
where setDocksMask :: ManageHook
setDocksMask = do
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
>>= \win :: Window
win -> X () -> Query ()
forall a. X a -> Query a
liftX (X () -> Query ()) -> X () -> Query ()
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
$ \dpy :: Display
dpy -> do
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
win (Window
propertyChangeMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
structureNotifyMask)
ManageHook
forall a. Monoid a => a
mempty
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
>>= \w :: 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 "_NET_WM_WINDOW_TYPE_DOCK"
Window
desk <- String -> X Window
getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
Maybe [CLong]
mbr <- String -> Window -> X (Maybe [CLong])
getProp32s "_NET_WM_WINDOW_TYPE" Window
w
case Maybe [CLong]
mbr of
Just rs :: [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
$ (Window -> Bool) -> [Window] -> 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]) ((CLong -> Window) -> [CLong] -> [Window]
forall a b. (a -> b) -> [a] -> [b]
map CLong -> Window
forall a b. (Integral a, Num b) => a -> b
fromIntegral [CLong]
rs)
_ -> Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
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
$ do
[Strut]
strut <- Window -> X [Strut]
getStrut Window
w
X Bool -> X () -> X ()
whenX (Window -> [Strut] -> X Bool
updateStrutCache Window
w [Strut]
strut) 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 "_NET_WM_STRUT"
Window
nwsp <- String -> X Window
getAtom "_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
$ do
[Strut]
strut <- Window -> X [Strut]
getStrut Window
w
X Bool -> X () -> X ()
whenX (Window -> [Strut] -> X Bool
updateStrutCache Window
w [Strut]
strut) 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
deleteFromStructCache Window
w) X ()
refreshDocks
All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
docksEventHook _ = All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
docksStartupHook :: X ()
docksStartupHook :: X ()
docksStartupHook = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \dpy :: Display
dpy -> do
Window
rootw <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
(_,_,wins :: [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]))
-> IO (Window, Window, [Window]) -> X (Window, Window, [Window])
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO (Window, Window, [Window])
queryTree Display
dpy Window
rootw
[Window]
docks <- (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
[Window] -> (Window -> X Bool) -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Window]
docks ((Window -> X Bool) -> X ()) -> (Window -> X Bool) -> X ()
forall a b. (a -> b) -> a -> b
$ \win :: Window
win -> do
[Strut]
strut <- Window -> X [Strut]
getStrut Window
win
Window -> [Strut] -> X Bool
updateStrutCache Window
win [Strut]
strut
X ()
refreshDocks
getStrut :: Window -> X [Strut]
getStrut :: Window -> X [Strut]
getStrut w :: Window
w = do
Maybe [CLong]
msp <- String -> Window -> X (Maybe [CLong])
getProp32s "_NET_WM_STRUT_PARTIAL" Window
w
case Maybe [CLong]
msp of
Just sp :: [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
Nothing -> (Maybe [CLong] -> [Strut]) -> X (Maybe [CLong]) -> X [Strut]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([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) (X (Maybe [CLong]) -> X [Strut]) -> X (Maybe [CLong]) -> X [Strut]
forall a b. (a -> b) -> a -> b
$ String -> Window -> X (Maybe [CLong])
getProp32s "_NET_WM_STRUT" Window
w
where
parseStrut :: [d] -> [(Direction2D, d, d, d)]
parseStrut xs :: [d]
xs@[_, _, _, _] = [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 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 _ = []
parseStrutPartial :: [d] -> [(Direction2D, d, d, d)]
parseStrutPartial [l :: d
l, r :: d
r, t :: d
t, b :: d
b, ly1 :: d
ly1, ly2 :: d
ly2, ry1 :: d
ry1, ry2 :: d
ry2, tx1 :: d
tx1, tx2 :: d
tx2, bx1 :: d
bx1, bx2 :: d
bx2]
= ((Direction2D, d, d, d) -> Bool)
-> [(Direction2D, d, d, d)] -> [(Direction2D, d, d, d)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(_, n :: d
n, _, _) -> d
n d -> d -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 _ = []
calcGap :: S.Set Direction2D -> X (Rectangle -> Rectangle)
calcGap :: Set Direction2D -> X (Rectangle -> Rectangle)
calcGap ss :: 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
$ \dpy :: 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])
-> ([[Strut]] -> [Strut]) -> [[Strut]] -> [Strut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Strut]] -> [Strut]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ([[Strut]] -> [Strut]) -> X [[Strut]] -> X [Strut]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (StrutCache -> [[Strut]]) -> X [[Strut]]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets (Map Window [Strut] -> [[Strut]]
forall k a. Map k a -> [a]
M.elems (Map Window [Strut] -> [[Strut]])
-> (StrutCache -> Map Window [Strut]) -> StrutCache -> [[Strut]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrutCache -> Map Window [Strut]
fromStrutCache)
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
$ \r :: 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 (s :: Direction2D
s,_,_,_) = Direction2D
s Direction2D -> Set Direction2D -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Direction2D
ss
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]
avoidStrutsOn :: LayoutClass l a =>
[Direction2D]
-> l a
-> ModifiedLayout AvoidStruts l a
avoidStrutsOn :: [Direction2D] -> l a -> ModifiedLayout AvoidStruts l a
avoidStrutsOn ss :: [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)
data 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 )
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,Typeable)
instance Message ToggleStruts
data SetStruts = SetStruts { SetStruts -> [Direction2D]
addedStruts :: [Direction2D]
, SetStruts -> [Direction2D]
removedStruts :: [Direction2D]
}
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,Typeable)
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 ss :: Set Direction2D
ss) w :: Workspace String (l a) a
w r :: 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)
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 ss :: Set Direction2D
ss) m :: SomeMessage
m
| Just 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 s :: 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 n :: [Direction2D]
n k :: [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 <- 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 x :: 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 x :: a
x xs :: 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
$ \dpy :: Display
dpy -> do
Window
a <- String -> X Window
getAtom "_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)
type Strut = (Direction2D, CLong, CLong, CLong)
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)
r2c :: Rectangle -> RectC
r2c :: Rectangle -> RectC
r2c (Rectangle x :: Position
x y :: Position
y w :: Dimension
w h :: 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
- 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
- 1)
c2r :: RectC -> Rectangle
c2r :: RectC -> Rectangle
c2r (RectC (x1 :: CLong
x1, y1 :: CLong
y1, x2 :: CLong
x2, y2 :: 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
+ 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
+ 1)
reduce :: RectC -> Strut -> RectC -> RectC
reduce :: RectC -> Strut -> RectC -> RectC
reduce (RectC (sx0 :: CLong
sx0, sy0 :: CLong
sy0, sx1 :: CLong
sx1, sy1 :: CLong
sy1)) (s :: Direction2D
s, n :: CLong
n, l :: CLong
l, h :: CLong
h) (RectC (x0 :: CLong
x0, y0 :: CLong
y0, x1 :: CLong
x1, y1 :: 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
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 )
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 )
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 )
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)
_ -> (CLong
x0 , CLong
y0 , CLong
x1 , CLong
y1 )
where
mx :: CLong -> CLong -> CLong
mx a :: CLong
a b :: 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 a :: CLong
a b :: 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 r :: (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)
qh :: CLong -> Bool
qh d1 :: CLong
d1 = CLong
n CLong -> CLong -> Bool
forall a. Ord a => a -> a -> Bool
<= CLong
d1
qv :: CLong -> CLong -> Bool
qv sd1 :: CLong
sd1 d0 :: 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
overlaps :: Ord a => (a, a) -> (a, a) -> Bool
(a :: a
a, b :: a
b) overlaps :: (a, a) -> (a, a) -> Bool
`overlaps` (x :: a
x, y :: 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 (i :: a
i, j :: a
j) k :: 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