{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ParallelListComp, PatternGuards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module       : XMonad.Layout.LayoutHints
-- Description :  Make layouts respect size hints.
-- Copyright    : (c) David Roundy <droundy@darcs.net>
-- License      : BSD
--
-- Maintainer   : none
-- Stability    : unstable
-- Portability  : unportable
--
-- Make layouts respect size hints.
-----------------------------------------------------------------------------

module XMonad.Layout.LayoutHints
    ( -- * usage
      -- $usage
      layoutHints
    , layoutHintsWithPlacement
    , layoutHintsToCenter
    , LayoutHints
    , LayoutHintsToCenter
    , hintsEventHook
    -- * For developers
    , placeRectangle
    )  where

import XMonad(LayoutClass(runLayout), mkAdjust, Window,
              Dimension, Position, Rectangle(Rectangle), D,
              X, refresh, Event(..), propertyNotify, wM_NORMAL_HINTS,
              (<&&>), io, applySizeHints, whenX, isClient, withDisplay,
              getWMNormalHints, WindowAttributes(..))
import XMonad.Prelude
import qualified XMonad.StackSet as W

import XMonad.Layout.Decoration(isInStack)
import XMonad.Layout.LayoutModifier(ModifiedLayout(..),
                                    LayoutModifier(modifyLayout, redoLayout, modifierDescription))
import XMonad.Util.Types(Direction2D(..))
import Control.Arrow(Arrow((***), first, second))

import Data.Set (Set)
import qualified Data.Set as Set

-- $usage
-- You can use this module with the following in your @xmonad.hs@:
--
-- > import XMonad.Layout.LayoutHints
--
-- Then edit your @layoutHook@ by adding the 'layoutHints' layout modifier
-- to some layout:
--
-- > myLayout = layoutHints (Tall 1 (3/100) (1/2))  ||| Full ||| etc..
-- > main = xmonad def { layoutHook = myLayout }
--
-- Or, to center the adapted window in its available area:
--
-- > myLayout = layoutHintsWithPlacement (0.5, 0.5) (Tall 1 (3/100) (1/2))
-- >                   ||| Full ||| etc..
--
-- Or, to make a reasonable attempt to eliminate gaps between windows:
--
-- > myLayout = layoutHintsToCenter (Tall 1 (3/100) (1/2))
--
-- For more detailed instructions on editing the layoutHook see
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and
-- "XMonad.Doc.Extending#Editing_the_layout_hook".
--
-- To make XMonad reflect changes in window hints immediately, add
-- 'hintsEventHook' to your 'handleEventHook'.
--
-- > myHandleEventHook = hintsEventHook <> ...
-- >
-- > main = xmonad def { handleEventHook = myHandleEventHook
-- >                   , ... }

layoutHints :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHints l a
layoutHints :: forall (l :: * -> *) a.
LayoutClass l a =>
l a -> ModifiedLayout LayoutHints l a
layoutHints = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall a. (Double, Double) -> LayoutHints a
LayoutHints (Double
0, Double
0))

-- | @layoutHintsWithPlacement (rx, ry) layout@ will adapt the sizes of a layout's
-- windows according to their size hints, and position them inside their
-- originally assigned area according to the @rx@ and @ry@ parameters.
-- (0, 0) places the window at the top left, (1, 0) at the top right, (0.5, 0.5)
-- at the center, etc.
layoutHintsWithPlacement :: (LayoutClass l a) => (Double, Double)
                         -> l a -> ModifiedLayout LayoutHints l a
layoutHintsWithPlacement :: forall (l :: * -> *) a.
LayoutClass l a =>
(Double, Double) -> l a -> ModifiedLayout LayoutHints l a
layoutHintsWithPlacement (Double, Double)
rs = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall a. (Double, Double) -> LayoutHints a
LayoutHints (Double, Double)
rs)

-- | @layoutHintsToCenter layout@ applies hints, sliding the window to the
-- center of the screen and expanding its neighbors to fill the gaps. Windows
-- are never expanded in a way that increases overlap.
--
-- @layoutHintsToCenter@ only makes one pass at resizing the neighbors of
-- hinted windows, so with some layouts (ex. the arrangement with two 'Mirror'
-- 'Tall' stacked vertically), @layoutHintsToCenter@ may leave some gaps.
-- Simple layouts like 'Tall' are unaffected.
layoutHintsToCenter :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHintsToCenter l a
layoutHintsToCenter :: forall (l :: * -> *) a.
LayoutClass l a =>
l a -> ModifiedLayout LayoutHintsToCenter l a
layoutHintsToCenter = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout forall a. LayoutHintsToCenter a
LayoutHintsToCenter

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

instance LayoutModifier LayoutHints Window where
    modifierDescription :: LayoutHints Window -> String
modifierDescription LayoutHints Window
_ = String
"Hinted"
    redoLayout :: LayoutHints Window
-> Rectangle
-> Maybe (Stack Window)
-> [(Window, Rectangle)]
-> X ([(Window, Rectangle)], Maybe (LayoutHints Window))
redoLayout LayoutHints Window
_ Rectangle
_ Maybe (Stack Window)
Nothing  [(Window, Rectangle)]
xs = forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
xs, forall a. Maybe a
Nothing)
    redoLayout (LayoutHints (Double, Double)
al) Rectangle
_ (Just Stack Window
s) [(Window, Rectangle)]
xs
        = do [(Window, Rectangle)]
xs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\x :: (Window, Rectangle)
x@(Window
_, Rectangle
r) -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall r.
RealFrac r =>
(r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle (Double, Double)
al Rectangle
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Window, Rectangle) -> X (Window, Rectangle)
applyHint (Window, Rectangle)
x) [(Window, Rectangle)]
xs
             forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
xs', forall a. Maybe a
Nothing)
     where
        applyHint :: (Window, Rectangle) -> X (Window, Rectangle)
applyHint (Window
w,r :: Rectangle
r@(Rectangle Position
a Position
b Dimension
c Dimension
d)) = do
            (Dimension, Dimension) -> (Dimension, Dimension)
adj <- Window -> X ((Dimension, Dimension) -> (Dimension, Dimension))
mkAdjust Window
w
            let (Dimension
c',Dimension
d') = (Dimension, Dimension) -> (Dimension, Dimension)
adj (Dimension
c,Dimension
d)
            forall (m :: * -> *) a. Monad m => a -> m a
return (Window
w, if forall a. Eq a => Stack a -> a -> Bool
isInStack Stack Window
s Window
w then Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
a Position
b Dimension
c' Dimension
d' else Rectangle
r)

-- | @placeRectangle (rx, ry) r0 r@ will return a new rectangle with the same dimensions
-- as @r@, but positioned inside of @r0@ as specified by the (rx, ry) parameters (see
-- 'layoutHintsWithPlacement').
placeRectangle :: RealFrac r => (r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle :: forall r.
RealFrac r =>
(r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle (r
rx, r
ry) (Rectangle Position
x0 Position
y0 Dimension
w Dimension
h) (Rectangle Position
_ Position
_ Dimension
dx Dimension
dy)
    = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (forall r.
RealFrac r =>
Position -> Dimension -> Dimension -> r -> Position
align Position
x0 Dimension
dx Dimension
w r
rx) (forall r.
RealFrac r =>
Position -> Dimension -> Dimension -> r -> Position
align Position
y0 Dimension
dy Dimension
h r
ry) Dimension
dx Dimension
dy
    where align :: RealFrac r => Position -> Dimension -> Dimension -> r -> Position
          align :: forall r.
RealFrac r =>
Position -> Dimension -> Dimension -> r -> Position
align Position
z0 Dimension
dz Dimension
d r
r = Position
z0 forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
truncate (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dimension
d forall a. Num a => a -> a -> a
- Dimension
dz) forall a. Num a => a -> a -> a
* r
r)

fitting :: [Rectangle] -> Int
fitting :: [Rectangle] -> Int
fitting [Rectangle]
rects = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ do
    Rectangle
r <- [Rectangle]
rects
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Rectangle -> Rectangle -> Bool
touching Rectangle
r) [Rectangle]
rects

applyOrder :: Rectangle -> [((Window, Rectangle),t)] -> [[((Window, Rectangle),t)]]
applyOrder :: forall t.
Rectangle
-> [((Window, Rectangle), t)] -> [[((Window, Rectangle), t)]]
applyOrder Rectangle
root [((Window, Rectangle), t)]
wrs = do
    -- perhaps it would just be better to take all permutations, or apply the
    -- resizing multiple times
    [Position] -> Position
f <- [forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum, forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum, forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum, forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Position -> Position
sq]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Position] -> Position
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. ((a, Rectangle), b) -> [Position]
distance)) [((Window, Rectangle), t)]
wrs
    where distFC :: (Position, Position) -> Position
distFC = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a. Num a => a -> a -> a
(+) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Position -> Position
sq) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {t} {b}. (t -> t -> b) -> (t, t) -> (t, t) -> (b, b)
pairWise (-) (Rectangle -> (Position, Position)
center Rectangle
root)
          distance :: ((a, Rectangle), b) -> [Position]
distance = forall a b. (a -> b) -> [a] -> [b]
map (Position, Position) -> Position
distFC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> [(Position, Position)]
corners forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
          pairWise :: (t -> t -> b) -> (t, t) -> (t, t) -> (b, b)
pairWise t -> t -> b
f (t
a,t
b) (t
c,t
d) = (t -> t -> b
f t
a t
c, t -> t -> b
f t
b t
d)
          sq :: Position -> Position
sq = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a. Num a => a -> a -> a
(*)

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

instance LayoutModifier LayoutHintsToCenter Window where
    modifyLayout :: forall (l :: * -> *).
LayoutClass l Window =>
LayoutHintsToCenter Window
-> Workspace String (l Window) Window
-> Rectangle
-> X ([(Window, Rectangle)], Maybe (l Window))
modifyLayout LayoutHintsToCenter Window
_ ws :: Workspace String (l Window) Window
ws@(W.Workspace String
_ l Window
_ Maybe (Stack Window)
Nothing) Rectangle
r = forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
ws Rectangle
r
    modifyLayout LayoutHintsToCenter Window
_ ws :: Workspace String (l Window) Window
ws@(W.Workspace String
_ l Window
_ (Just Stack Window
st)) Rectangle
r = do
        ([(Window, Rectangle)]
arrs,Maybe (l Window)
ol) <- forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
ws Rectangle
r
        (, Maybe (l Window)
ol) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
changeOrder (forall a. Stack a -> a
W.focus Stack Window
st forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= forall a. Stack a -> a
W.focus Stack Window
st) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Window, Rectangle)]
arrs))
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Rectangle] -> Int
fitting forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd))
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Stack Window
-> Rectangle
-> [((Window, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Window, Rectangle)]
applyHints Stack Window
st Rectangle
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t.
Rectangle
-> [((Window, Rectangle), t)] -> [[((Window, Rectangle), t)]]
applyOrder Rectangle
r
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Window, Rectangle)
x -> ((Window, Rectangle)
x,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Window -> X ((Dimension, Dimension) -> (Dimension, Dimension))
mkAdjust (forall a b. (a, b) -> a
fst (Window, Rectangle)
x)) [(Window, Rectangle)]
arrs

changeOrder :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
changeOrder :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
changeOrder [Window]
w [(Window, Rectangle)]
wr = forall a b. [a] -> [b] -> [(a, b)]
zip [Window]
w' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(Window, Rectangle)]
wr) [Window]
w'
    where w' :: [Window]
w' = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Window, Rectangle)]
wr) [Window]
w

-- apply hints to first, grow adjacent windows
applyHints :: W.Stack Window -> Rectangle -> [((Window, Rectangle),D -> D)] -> [(Window, Rectangle)]
applyHints :: Stack Window
-> Rectangle
-> [((Window, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Window, Rectangle)]
applyHints Stack Window
_ Rectangle
_ [] = []
applyHints Stack Window
s Rectangle
root (((Window
w,lrect :: Rectangle
lrect@(Rectangle Position
a Position
b Dimension
c Dimension
d)),(Dimension, Dimension) -> (Dimension, Dimension)
adj):[((Window, Rectangle),
  (Dimension, Dimension) -> (Dimension, Dimension))]
xs) =
        let (Dimension
c',Dimension
d') = (Dimension, Dimension) -> (Dimension, Dimension)
adj (Dimension
c,Dimension
d)
            redr :: Rectangle
redr = forall r.
RealFrac r =>
(r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle (forall r. RealFrac r => Rectangle -> Rectangle -> (r, r)
centerPlacement Rectangle
root Rectangle
lrect :: (Double,Double)) Rectangle
lrect
                    forall a b. (a -> b) -> a -> b
$ if forall a. Eq a => Stack a -> a -> Bool
isInStack Stack Window
s Window
w then Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
a Position
b Dimension
c' Dimension
d' else Rectangle
lrect

            ds :: (Position, Position)
ds = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
c forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
c',forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
d forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
d')
            growOther' :: Rectangle -> Rectangle
growOther' = (Position, Position)
-> Rectangle -> Set Direction2D -> Rectangle -> Rectangle
growOther (Position, Position)
ds Rectangle
lrect (Rectangle -> Rectangle -> Set Direction2D
freeDirs Rectangle
root Rectangle
lrect)
            mapSnd :: (b -> c) -> [((d, b), d)] -> [((d, c), d)]
mapSnd b -> c
f = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second b -> c
f)
            next :: [(Window, Rectangle)]
next = Stack Window
-> Rectangle
-> [((Window, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Window, Rectangle)]
applyHints Stack Window
s Rectangle
root forall a b. (a -> b) -> a -> b
$ forall {b} {c} {d} {d}. (b -> c) -> [((d, b), d)] -> [((d, c), d)]
mapSnd Rectangle -> Rectangle
growOther' [((Window, Rectangle),
  (Dimension, Dimension) -> (Dimension, Dimension))]
xs
        in (Window
w,Rectangle
redr)forall a. a -> [a] -> [a]
:[(Window, Rectangle)]
next

growOther :: (Position, Position) -> Rectangle -> Set Direction2D -> Rectangle -> Rectangle
growOther :: (Position, Position)
-> Rectangle -> Set Direction2D -> Rectangle -> Rectangle
growOther (Position, Position)
ds Rectangle
lrect Set Direction2D
fds Rectangle
r
    | [Direction2D]
dirs <- Direction2D -> Direction2D
flipDir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList (forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Direction2D
adj Set Direction2D
fds)
    , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Direction2D -> Direction2D -> Bool
opposite) forall a b. (a -> b) -> a -> b
$ forall {b}. [b] -> [(b, b)]
cross [Direction2D]
dirs =
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Direction2D -> (Position, Position) -> Rectangle -> Rectangle
`grow` (Position, Position)
ds) Rectangle
r [Direction2D]
dirs
    | Bool
otherwise = Rectangle
r
    where
        adj :: Set Direction2D
adj = Rectangle -> Rectangle -> Set Direction2D
adjacent Rectangle
lrect  Rectangle
r
        cross :: [b] -> [(b, b)]
cross [b]
xs = [ (b
a,b
b) | b
a <- [b]
xs, b
b <- [b]
xs ]

        flipDir :: Direction2D -> Direction2D
        flipDir :: Direction2D -> Direction2D
flipDir Direction2D
d = case Direction2D
d of { Direction2D
L -> Direction2D
R; Direction2D
U -> Direction2D
D; Direction2D
R -> Direction2D
L; Direction2D
D -> Direction2D
U }

        opposite :: Direction2D -> Direction2D -> Bool
        opposite :: Direction2D -> Direction2D -> Bool
opposite Direction2D
x Direction2D
y = Direction2D -> Direction2D
flipDir Direction2D
x forall a. Eq a => a -> a -> Bool
== Direction2D
y

-- | Leave the opposite edges where they were
grow :: Direction2D -> (Position,Position) -> Rectangle -> Rectangle
grow :: Direction2D -> (Position, Position) -> Rectangle -> Rectangle
grow Direction2D
L (Position
px,Position
_ ) (Rectangle Position
x Position
y Dimension
w Dimension
h) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position
xforall a. Num a => a -> a -> a
-Position
px) Position
y (Dimension
wforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
px) Dimension
h
grow Direction2D
U (Position
_ ,Position
py) (Rectangle Position
x Position
y Dimension
w Dimension
h) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x (Position
yforall a. Num a => a -> a -> a
-Position
py) Dimension
w (Dimension
hforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
py)
grow Direction2D
R (Position
px,Position
_ ) (Rectangle Position
x Position
y Dimension
w Dimension
h) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x Position
y (Dimension
wforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
px) Dimension
h
grow Direction2D
D (Position
_ ,Position
py) (Rectangle Position
x Position
y Dimension
w Dimension
h) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x Position
y Dimension
w (Dimension
hforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
py)

comparingEdges :: ([Position] -> [Position] -> Bool) -> Rectangle -> Rectangle -> Set Direction2D
comparingEdges :: ([Position] -> [Position] -> Bool)
-> Rectangle -> Rectangle -> Set Direction2D
comparingEdges [Position] -> [Position] -> Bool
surrounds Rectangle
r1 Rectangle
r2 = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd [ (Direction2D
dir,) forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (t :: * -> *). Foldable t => t Bool -> Bool
and [[Direction2D
dir forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Direction2D
R,Direction2D
L], [Position] -> Bool
allEq [Position
a,Position
c,Position
w,Position
y], [Position
b,Position
d] [Position] -> [Position] -> Bool
`surrounds` [Position
x,Position
z]]
                    ,[Direction2D
dir forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Direction2D
U,Direction2D
D], [Position] -> Bool
allEq [Position
b,Position
d,Position
x,Position
z], [Position
a,Position
c] [Position] -> [Position] -> Bool
`surrounds` [Position
w,Position
y]]]
    | ((Position
a,Position
b),(Position
c,Position
d)) <- forall {b}. [b] -> [(b, b)]
edge forall a b. (a -> b) -> a -> b
$ Rectangle -> [(Position, Position)]
corners Rectangle
r1
    | ((Position
w,Position
x),(Position
y,Position
z)) <- forall {b}. [b] -> [(b, b)]
edge forall a b. (a -> b) -> a -> b
$ forall {a}. Int -> [a] -> [a]
delay Int
2 forall a b. (a -> b) -> a -> b
$ Rectangle -> [(Position, Position)]
corners Rectangle
r2
    | Direction2D
dir <- [Direction2D
U,Direction2D
R,Direction2D
D,Direction2D
L]]
        where edge :: [b] -> [(b, b)]
edge (b
x:[b]
xs) = forall a b. [a] -> [b] -> [(a, b)]
zip (b
xforall a. a -> [a] -> [a]
:[b]
xs) ([b]
xs forall a. [a] -> [a] -> [a]
++ [b
x])
              edge [] = []
              delay :: Int -> [a] -> [a]
delay Int
n [a]
xs = forall {a}. Int -> [a] -> [a]
drop Int
n [a]
xs forall a. [a] -> [a] -> [a]
++ forall {a}. Int -> [a] -> [a]
take Int
n [a]
xs
              allEq :: [Position] -> Bool
allEq = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. [b] -> [(b, b)]
edge

-- | in what direction is the second window from the first that can expand if the
-- first is shrunk, assuming that the root window is fully covered:
--  one direction for a common edge
--  two directions for a common corner
adjacent :: Rectangle -> Rectangle -> Set Direction2D
adjacent :: Rectangle -> Rectangle -> Set Direction2D
adjacent = ([Position] -> [Position] -> Bool)
-> Rectangle -> Rectangle -> Set Direction2D
comparingEdges (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> a -> Bool
onClosedInterval)

-- | True whenever two edges touch. not (Set.null $ adjacent x y) ==> touching x y
touching :: Rectangle -> Rectangle -> Bool
touching :: Rectangle -> Rectangle -> Bool
touching Rectangle
a Rectangle
b = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ ([Position] -> [Position] -> Bool)
-> Rectangle -> Rectangle -> Set Direction2D
comparingEdges forall {a}. Ord a => [a] -> [a] -> Bool
c Rectangle
a Rectangle
b
    where c :: [a] -> [a] -> Bool
c [a]
x [a]
y = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => [a] -> a -> Bool
onClosedInterval [a]
x) [a]
y Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => [a] -> a -> Bool
onClosedInterval [a]
y) [a]
x

onClosedInterval :: Ord a => [a] -> a -> Bool
onClosedInterval :: forall a. Ord a => [a] -> a -> Bool
onClosedInterval [a]
bds a
x = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [a]
bds forall a. Ord a => a -> a -> Bool
<= a
x Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
bds forall a. Ord a => a -> a -> Bool
>= a
x

-- | starting top left going clockwise
corners :: Rectangle -> [(Position, Position)]
corners :: Rectangle -> [(Position, Position)]
corners (Rectangle Position
x Position
y Dimension
w Dimension
h) = [(Position
x,Position
y)
                              ,(Position
xforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
w, Position
y)
                              ,(Position
xforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
w, Position
yforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
h)
                              ,(Position
x, Position
yforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
h)]

center :: Rectangle -> (Position, Position)
center :: Rectangle -> (Position, Position)
center (Rectangle Position
x Position
y Dimension
w Dimension
h) = (forall {a} {a}. (Integral a, Integral a) => a -> a -> a
avg Position
x Dimension
w, forall {a} {a}. (Integral a, Integral a) => a -> a -> a
avg Position
y Dimension
h)
    where avg :: a -> a -> a
avg a
a a
b = a
a forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b forall a. Integral a => a -> a -> a
`div` a
2

centerPlacement :: RealFrac r => Rectangle -> Rectangle -> (r, r)
centerPlacement :: forall r. RealFrac r => Rectangle -> Rectangle -> (r, r)
centerPlacement = forall r. (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' forall {a} {a}. (Eq a, Fractional a, Num a) => a -> a
clamp
    where clamp :: a -> a
clamp a
n = case forall a. Num a => a -> a
signum a
n of
                            a
0 -> a
0.5
                            a
1 -> a
1
                            a
_ -> a
0

freeDirs :: Rectangle -> Rectangle -> Set Direction2D
freeDirs :: Rectangle -> Rectangle -> Set Direction2D
freeDirs Rectangle
root = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {a}. (Eq a, Num a) => a -> [Direction2D]
lr forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall {a}. (Eq a, Num a) => a -> [Direction2D]
ud)
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' forall a. Num a => a -> a
signum Rectangle
root
    where
        lr :: a -> [Direction2D]
lr a
1 = [Direction2D
L]
        lr (-1) = [Direction2D
R]
        lr a
_ = [Direction2D
L,Direction2D
R]
        ud :: a -> [Direction2D]
ud a
1 = [Direction2D
U]
        ud (-1) = [Direction2D
D]
        ud a
_ = [Direction2D
U,Direction2D
D]

centerPlacement' :: (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' :: forall r. (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' Position -> r
cf Rectangle
root Rectangle
assigned
    = (Position -> r
cf forall a b. (a -> b) -> a -> b
$ Position
cx forall a. Num a => a -> a -> a
- Position
cwx, Position -> r
cf forall a b. (a -> b) -> a -> b
$ Position
cy forall a. Num a => a -> a -> a
- Position
cwy)
    where (Position
cx,Position
cy) = Rectangle -> (Position, Position)
center Rectangle
root
          (Position
cwx,Position
cwy) = Rectangle -> (Position, Position)
center Rectangle
assigned

-- | Event hook that refreshes the layout whenever a window changes its hints.
hintsEventHook :: Event -> X All
hintsEventHook :: Event -> X All
hintsEventHook PropertyEvent{ ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_atom :: Event -> Window
ev_atom = Window
a, ev_window :: Event -> Window
ev_window = Window
w }
    | Dimension
t forall a. Eq a => a -> a -> Bool
== Dimension
propertyNotify Bool -> Bool -> Bool
&& Window
a forall a. Eq a => a -> a -> Bool
== Window
wM_NORMAL_HINTS = do
        X Bool -> X () -> X ()
whenX (Window -> X Bool
isClient Window
w forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> Window -> X Bool
hintsMismatch Window
w) X ()
refresh
        forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
hintsEventHook Event
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

-- | True if the window's current size does not satisfy its size hints.
hintsMismatch :: Window -> X Bool
hintsMismatch :: Window -> X Bool
hintsMismatch Window
w = Window -> X (Maybe WindowAttributes)
safeGetWindowAttributes Window
w forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe WindowAttributes
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just WindowAttributes
wa -> do
        SizeHints
sh <- forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> Window -> IO SizeHints
getWMNormalHints Display
d Window
w)
        let dim :: (Dimension, Dimension)
dim = (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_width WindowAttributes
wa, forall a b. (Integral a, Num b) => a -> b
fromIntegral 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
$ (Dimension, Dimension)
dim forall a. Eq a => a -> a -> Bool
/= forall a.
Integral a =>
Dimension -> SizeHints -> (a, a) -> (Dimension, Dimension)
applySizeHints Dimension
0 SizeHints
sh (Dimension, Dimension)
dim