path: root/XMonad/Layout/LayoutHints.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
{-# LANGUAGE ParallelListComp, PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module       : XMonad.Layout.LayoutHints
-- 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
    )  where

import XMonad(LayoutClass(runLayout), mkAdjust, Window,
              Dimension, Position, Rectangle(Rectangle), D,
              X, refresh, Event(..), propertyNotify, wM_NORMAL_HINTS,
              (<&&>), io, applySizeHints, whenX, isClient, withDisplay,
              getWindowAttributes, getWMNormalHints, WindowAttributes(..))
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.Applicative((<$>))
import Control.Arrow(Arrow((***), first, second))
import Control.Monad(join)
import Data.Function(on)
import Data.List(sortBy)
import Data.Monoid(All(..))

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

-- $usage
-- You can use this module with the following in your @~\/.xmonad\/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:
--
-- "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 = ModifiedLayout (LayoutHints (0, 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 rs = ModifiedLayout (LayoutHints 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 = ModifiedLayout LayoutHintsToCenter

data LayoutHints a = LayoutHints (Double, Double)
                     deriving (Read, Show)

instance LayoutModifier LayoutHints Window where
    modifierDescription _ = "Hinted"
    redoLayout _ _ Nothing  xs = return (xs, Nothing)
    redoLayout (LayoutHints al) _ (Just s) xs
        = do xs' <- mapM (\x@(_, r) -> second (placeRectangle al r) <$> applyHint x) xs
             return (xs', Nothing)
     where
        applyHint (w,r@(Rectangle a b c d)) = do
            adj <- mkAdjust w
            let (c',d') = adj (c,d)
            return (w, if isInStack s w then Rectangle a b c' d' else 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 (rx, ry) (Rectangle x0 y0 w h) (Rectangle _ _ dx dy)
    = Rectangle (align x0 dx w rx) (align y0 dy h ry) dx dy
    where align :: RealFrac r => Position -> Dimension -> Dimension -> r -> Position
          align z0 dz d r = z0 + truncate (fromIntegral (d - dz) * r)

fitting :: [Rectangle] -> Int
fitting rects = sum $ do
    r <- rects
    return $ length $ filter (touching r) rects

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

data LayoutHintsToCenter a = LayoutHintsToCenter deriving (Read, Show)

instance LayoutModifier LayoutHintsToCenter Window where
    modifyLayout _ ws@(W.Workspace _ _ Nothing) r = runLayout ws r
    modifyLayout _ ws@(W.Workspace _ _ (Just st)) r = do
        (arrs,ol) <- runLayout ws r
        flip (,) ol
            . head . reverse . sortBy (compare `on` (fitting . map snd))
            . map (applyHints st r) . applyOrder r
            <$> mapM (\x -> fmap ((,) x) $ mkAdjust (fst x)) arrs

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

            ds = (fromIntegral c - fromIntegral c',fromIntegral d - fromIntegral d')
            growOther' r = growOther ds lrect (freeDirs root lrect) r
            mapSnd f = map (first $ second f)
            next = applyHints s root $ mapSnd growOther' xs
        in (w,redr):next

growOther :: (Position, Position) -> Rectangle -> Set Direction2D -> Rectangle -> Rectangle
growOther ds lrect fds r
    | dirs <- flipDir <$> Set.toList (Set.intersection adj fds)
    , not $ any (uncurry opposite) $ cross dirs =
        foldr (flip grow ds) r dirs
    | otherwise = r
    where
        adj = adjacent lrect  r
        cross xs = [ (a,b) | a <- xs, b <- xs ]

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

        opposite :: Direction2D -> Direction2D -> Bool
        opposite x y = flipDir x == y

-- | Leave the opposite edges where they were
grow :: Direction2D -> (Position,Position) -> Rectangle -> Rectangle
grow L (px,_ ) (Rectangle x y w h) = Rectangle (x-px) y (w+fromIntegral px) h
grow U (_ ,py) (Rectangle x y w h) = Rectangle x (y-py) w (h+fromIntegral py)
grow R (px,_ ) (Rectangle x y w h) = Rectangle x y (w+fromIntegral px) h
grow D (_ ,py) (Rectangle x y w h) = Rectangle x y w (h+fromIntegral py)

comparingEdges :: ([Position] -> [Position] -> Bool) -> Rectangle -> Rectangle -> Set Direction2D
comparingEdges surrounds r1 r2 = Set.fromList $ map fst $ filter snd [ (\k -> (dir,k)) $
            any and [[dir `elem` [R,L], allEq [a,c,w,y], [b,d] `surrounds` [x,z]]
                    ,[dir `elem` [U,D], allEq [b,d,x,z], [a,c] `surrounds` [w,y]]]
    | ((a,b),(c,d)) <- edge $ corners r1
    | ((w,x),(y,z)) <- edge $ delay 2 $ corners r2
    | dir <- [U,R,D,L]]
        where edge (x:xs) = zip (x:xs) (xs ++ [x])
              edge [] = []
              delay n xs = drop n xs ++ take n xs
              allEq = all (uncurry (==)) . 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 = comparingEdges (all . onClosedInterval)

-- | True whenever two edges touch. not (Set.null $ adjacent x y) ==> touching x y
touching :: Rectangle -> Rectangle -> Bool
touching a b = not . Set.null $ comparingEdges c a b
    where c x y = any (onClosedInterval x) y || any (onClosedInterval y) x

onClosedInterval :: Ord a => [a] -> a -> Bool
onClosedInterval bds x = minimum bds <= x && maximum bds >= x

-- | starting top left going clockwise
corners :: Rectangle -> [(Position, Position)]
corners (Rectangle x y w h) = [(x,y)
                              ,(x+fromIntegral w, y)
                              ,(x+fromIntegral w, y+fromIntegral h)
                              ,(x, y+fromIntegral h)]

center :: Rectangle -> (Position, Position)
center (Rectangle x y w h) = (avg x w, avg y h)
    where avg a b = a + fromIntegral b `div` 2

centerPlacement :: RealFrac r => Rectangle -> Rectangle -> (r, r)
centerPlacement = centerPlacement' clamp
    where clamp n = case signum n of
                            0 -> 0.5
                            1 -> 1
                            _ -> 0

freeDirs :: Rectangle -> Rectangle -> Set Direction2D
freeDirs root = Set.fromList . uncurry (++) . (lr *** ud)
              . centerPlacement' signum root
    where
        lr 1 = [L]
        lr (-1) = [R]
        lr _ = [L,R]
        ud 1 = [U]
        ud (-1) = [D]
        ud _ = [U,D]

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

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

-- | True if the window's current size does not satisfy its size hints.
hintsMismatch :: Window -> X Bool
hintsMismatch w = withDisplay $ \d -> io $ do
    wa <- getWindowAttributes d w
    sh <- getWMNormalHints d w
    let dim = (fromIntegral $ wa_width wa, fromIntegral $ wa_height wa)
    return $ dim /= applySizeHints 0 sh dim