X.L.AvoidFloats, like avoidStruts but for floats

Ignore-this: 3722d7787dd2429313f92f85f3ae1251
Checks for floating windows within the layout area and finds a maximum area
rectangle within that does not overlap with any of the floating windows.
This rectangle is used for all non-floating windows.

This new functionality introduced problems with the recommended configuration
of one of my other modules (X.A.FloatSnap.) A new and more reliable method of
distinguishing between clicks and drags where therefore introduced in the new
module X.A.AfterDrag.

This does not break any prior use of FloatSnap, but will require changes in
configuration if used together with AvoidFloats. (This is mentioned in the
docs for AvoidFloats and I recommend using the new configuration method even if
AvoidFloats is not in use.)

darcs-hash:20150306171702-3948e-a8b8c75ba49306a33d87c9414117f8a49c536dbf.gz

4 files changed, 329 insertions, 9 deletions

diff --git a/XMonad/Actions/AfterDrag.hs b/XMonad/Actions/AfterDrag.hs
new file mode 100644
index 0000000..261ea91
--- /dev/null
+++ b/XMonad/Actions/AfterDrag.hs
@@ -0,0 +1,71 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Actions.AfterDrag
+-- Copyright   :  (c) 2014 Anders Engstrom <ankaan@gmail.com>
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  Anders Engstrom <ankaan@gmail.com>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Perform an action after the current mouse drag is completed.
+-----------------------------------------------------------------------------
+
+module XMonad.Actions.AfterDrag (
+                -- * Usage
+                -- $usage
+                afterDrag,
+                ifClick,
+                ifClick') where
+
+import XMonad
+import System.Time
+
+-- $usage
+-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
+--
+-- >    import XMonad.Actions.AfterDrag
+--
+-- Then add appropriate mouse bindings, for example:
+--
+-- >        , ((modm, button3), (\w -> focus w >> mouseResizeWindow w >> ifClick (windows $ W.float w $ W.RationalRect 0 0 1 1)))
+--
+-- This will allow you to resize windows as usual, but if you instead of
+-- draging click the mouse button the window will be automatically resized to
+-- fill the whole screen.
+--
+-- For detailed instructions on editing your mouse bindings, see
+-- "XMonad.Doc.Extending#Editing_mouse_bindings".
+--
+-- More practical examples are available in "XMonad.Actions.FloatSnap".
+
+-- | Schedule a task to take place after the current dragging is completed.
+afterDrag
+    :: X () -- ^ The task to schedule.
+    -> X ()
+afterDrag task = do drag <- gets dragging
+                    case drag of
+                        Nothing -> return () -- Not dragging
+                        Just (motion, cleanup) -> modify $ \s -> s { dragging = Just(motion, cleanup >> task) }
+
+-- | Take an action if the current dragging can be considered a click,
+--   supposing the drag just started before this function is called.
+--   A drag is considered a click if it is completed within 300 ms.
+ifClick
+  :: X ()   -- ^ The action to take if the dragging turned out to be a click.
+  -> X () 
+ifClick action = ifClick' 300 action (return ())
+
+-- | Take an action if the current dragging is completed within a certain time (in milliseconds.)
+ifClick'
+  :: Int    -- ^ Maximum time of dragging for it to be considered a click (in milliseconds.)
+  -> X ()   -- ^ The action to take if the dragging turned out to be a click.
+  -> X ()   -- ^ The action to take if the dragging turned out to not be a click.
+  -> X () 
+ifClick' ms click drag = do
+  start <- io $ getClockTime
+  afterDrag $ do 
+    stop <- io $ getClockTime
+    if diffClockTimes stop start <= noTimeDiff { tdPicosec = fromIntegral ms * 10^(9 :: Integer) }
+      then click
+      else drag
diff --git a/XMonad/Actions/FloatSnap.hs b/XMonad/Actions/FloatSnap.hs
index 3597254..baf511f 100644
--- a/XMonad/Actions/FloatSnap.hs
+++ b/XMonad/Actions/FloatSnap.hs
@@ -21,18 +21,21 @@ module XMonad.Actions.FloatSnap (
                 snapShrink,
                 snapMagicMove,
                 snapMagicResize,
-                snapMagicMouseResize) where
+                snapMagicMouseResize,
+                afterDrag,
+                ifClick,
+                ifClick') where
 
 import XMonad
 import Control.Applicative((<$>))
 import Data.List (sort)
 import Data.Maybe (listToMaybe,fromJust,isNothing)
 import qualified XMonad.StackSet as W
+import qualified Data.Set as S
 
 import XMonad.Hooks.ManageDocks (calcGap)
 import XMonad.Util.Types (Direction2D(..))
-
-import qualified Data.Set as S
+import XMonad.Actions.AfterDrag
 
 -- $usage
 -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
@@ -53,17 +56,24 @@ import qualified Data.Set as S
 -- For detailed instructions on editing your key bindings, see
 -- "XMonad.Doc.Extending#Editing_key_bindings".
 --
--- And possibly add an appropriate mouse binding, for example:
+-- And possibly add appropriate mouse bindings, for example:
 --
--- >        , ((modm,               button1), (\w -> focus w >> mouseMoveWindow w >> snapMagicMove (Just 50) (Just 50) w))
--- >        , ((modm .|. shiftMask, button1), (\w -> focus w >> mouseMoveWindow w >> snapMagicResize [L,R,U,D] (Just 50) (Just 50) w))
--- >        , ((modm,               button3), (\w -> focus w >> mouseResizeWindow w >> snapMagicResize [R,D] (Just 50) (Just 50) w))
+-- >        , ((modm,               button1), (\w -> focus w >> mouseMoveWindow w >> ifClick (snapMagicMove (Just 50) (Just 50) w)))
+-- >        , ((modm .|. shiftMask, button1), (\w -> focus w >> mouseMoveWindow w >> ifClick (snapMagicResize [L,R,U,D] (Just 50) (Just 50) w)))
+-- >        , ((modm,               button3), (\w -> focus w >> mouseResizeWindow w >> ifClick (snapMagicResize [R,D] (Just 50) (Just 50) w)))
 --
 -- For detailed instructions on editing your mouse bindings, see
 -- "XMonad.Doc.Extending#Editing_mouse_bindings".
 --
 -- Using these mouse bindings, it will not snap while moving, but allow you to click the window once after it has been moved or resized to snap it into place.
--- Note that the order in which the commands are applied in the mouse bindings are important.
+-- Note that the order in which the commands are applied in the mouse bindings are important. Snapping can also be used together with other window resizing
+-- functions, such as those from "XMonad.Actions.FlexibleResize"
+--
+-- An alternative set of mouse bindings that will always snap after the drag is:
+--
+-- >        , ((modm,               button1), (\w -> focus w >> mouseMoveWindow w >> afterDrag (snapMagicMove (Just 50) (Just 50) w)))
+-- >        , ((modm .|. shiftMask, button1), (\w -> focus w >> mouseMoveWindow w >> afterDrag (snapMagicResize [L,R,U,D] (Just 50) (Just 50) w)))
+-- >        , ((modm,               button3), (\w -> focus w >> mouseResizeWindow w >> afterDrag (snapMagicResize [R,D] (Just 50) (Just 50) w)))
 --
 -- Interesting values for the distance to look for window in the orthogonal axis are Nothing (to snap against every window), Just 0 (to only snap
 -- against windows that we should collide with geometrically while moving) and Just 1 (to also snap against windows we brush against).
diff --git a/XMonad/Layout/AvoidFloats.hs b/XMonad/Layout/AvoidFloats.hs
new file mode 100644
index 0000000..2451580
--- /dev/null
+++ b/XMonad/Layout/AvoidFloats.hs
@@ -0,0 +1,239 @@
+{-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, ParallelListComp, DeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.AvoidFloats
+-- Copyright   :  (c) 2014 Anders Engstrom <ankaan@gmail.com>
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  (c) Anders Engstrom <ankaan@gmail.com>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Find a maximum empty rectangle around floating windows and use that area
+-- to display non-floating windows.
+--
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.AvoidFloats (
+                                   -- * Usage
+                                   -- $usage
+                                   avoidFloats,
+                                   avoidFloats',
+                                   AvoidFloatMsg(..),
+                                   AvoidFloatItemMsg(..),
+                                 ) where
+
+import XMonad
+import XMonad.Layout.LayoutModifier
+import qualified XMonad.StackSet as W
+
+import Data.List
+import Data.Ord
+import Data.Maybe
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+-- $usage
+-- You can use this module with the following in your ~\/.xmonad\/xmonad.hs file:
+--
+-- > import XMonad.Layout.AvoidFloats
+--
+-- and modify the layouts to call avoidFloats on the layouts where you want the
+-- non-floating windows to not be behind floating windows.
+--
+-- > layoutHook = ... ||| avoidFloats True Full ||| ...
+--
+-- For more detailed instructions on editing the layoutHook see:
+-- "XMonad.Doc.Extending#Editing_the_layout_hook"
+--
+-- Then optionally add appropriate key bindings, for example:
+--
+-- > ,((modm .|. shiftMask, xK_b), sendMessage AvoidFloatToggle)
+-- > ,((modm .|. controlMask, xK_b), withFocused $ sendMessage . AvoidFloatToggleItem)
+-- > ,((modm .|. shiftMask .|. controlMask, xK_b), sendMessage (AvoidFloatSet False) >> sendMessage AvoidFloatClearItems)
+--
+-- For detailed instructions on editing your key bindings, see
+-- "XMonad.Doc.Extending#Editing_key_bindings".
+--
+-- Note that this module is incompatible with an old way of configuring
+-- "XMonad.Actions.FloatSnap". If you are having problems, please update your
+-- configuration.
+
+-- | Avoid floating windows unless the resulting area for windows would be too small.
+--   In that case, use the whole screen as if this layout modifier wasn't there.
+avoidFloats
+    :: Bool -- ^ If floating windows should be avoided by default.
+    -> l a  -- ^ Layout to modify.
+    -> ModifiedLayout AvoidFloats l a
+avoidFloats act = avoidFloats' 100 100 act
+
+-- | Avoid floating windows unless the resulting area for windows would be too small.
+--   In that case, use the whole screen as if this layout modifier wasn't used.
+avoidFloats'
+    :: Int  -- ^ Minimum width of the area used for non-floating windows.
+    -> Int  -- ^ Minimum height of the area used for non-floating windows.
+    -> Bool -- ^ If floating windows should be avoided by default.
+    -> l a  -- ^ Layout to modify.
+    -> ModifiedLayout AvoidFloats l a
+avoidFloats' w h act = ModifiedLayout (AvoidFloats Nothing S.empty w h act)
+
+data AvoidFloats a = AvoidFloats
+    { cache :: Maybe ((M.Map a W.RationalRect, Rectangle), Rectangle)
+    , chosen :: S.Set a
+    , minw :: Int
+    , minh :: Int
+    , avoidAll :: Bool
+    } deriving (Read, Show)
+
+-- | Change the state of the whole avoid float layout modifier.
+data AvoidFloatMsg
+    = AvoidFloatToggle        -- ^ Toggle between avoiding all or only selected.
+    | AvoidFloatSet Bool      -- ^ Set if all all floating windows should be avoided.
+    | AvoidFloatClearItems    -- ^ Clear the set of windows to specifically avoid.
+    deriving (Typeable)
+
+
+-- | Change the state of the avoid float layout modifier conserning a specific window.
+data AvoidFloatItemMsg a
+    = AvoidFloatAddItem a     -- ^ Add a window to always avoid.
+    | AvoidFloatRemoveItem a  -- ^ Stop always avoiding selected window.
+    | AvoidFloatToggleItem a  -- ^ Toggle between always avoiding selected window.
+    deriving (Typeable)
+
+instance Message AvoidFloatMsg
+instance Typeable a => Message (AvoidFloatItemMsg a)
+
+instance LayoutModifier AvoidFloats Window where
+    modifyLayoutWithUpdate lm w r = withDisplay $ \d -> do
+        floating <- gets $ W.floating . windowset
+        case cache lm of
+            Just (key, mer) | key == (floating,r) -> flip (,) Nothing `fmap` runLayout w mer
+            _ -> do rs <- io $ map toRect `fmap` mapM (getWindowAttributes d) (filter shouldAvoid $ M.keys floating)
+                    let mer = maximumBy (comparing area) $ filter bigEnough $ maxEmptyRectangles r rs
+                    flip (,) (Just $ pruneWindows $ lm { cache = Just ((floating,r),mer) }) `fmap` runLayout w mer
+        where
+            toRect :: WindowAttributes -> Rectangle
+            toRect wa = let b = fi $ wa_border_width wa
+                        in Rectangle (fi $ wa_x wa) (fi $ wa_y wa) (fi $ wa_width wa + 2*b) (fi $ wa_height wa + 2*b)
+            
+            bigEnough :: Rectangle -> Bool
+            bigEnough rect = rect_width rect >= fi (minw lm) && rect_height rect >= fi (minh lm)
+
+            shouldAvoid a = avoidAll lm || a `S.member` chosen lm
+
+    pureMess lm m
+        | Just (AvoidFloatToggle) <- fromMessage m =                               Just $ lm { avoidAll = not (avoidAll lm), cache = Nothing }
+        | Just (AvoidFloatSet s) <- fromMessage m, s /= avoidAll lm =              Just $ lm { avoidAll = s, cache = Nothing }
+        | Just (AvoidFloatClearItems) <- fromMessage m =                           Just $ lm { chosen = S.empty, cache = Nothing }
+        | Just (AvoidFloatAddItem a) <- fromMessage m, a `S.notMember` chosen lm = Just $ lm { chosen = S.insert a (chosen lm), cache = Nothing }
+        | Just (AvoidFloatRemoveItem a) <- fromMessage m, a `S.member` chosen lm = Just $ lm { chosen = S.delete a (chosen lm), cache = Nothing }
+        | Just (AvoidFloatToggleItem a) <- fromMessage m =                         let op = if a `S.member` chosen lm then S.delete else S.insert
+                                                                                   in Just $ lm { chosen = op a (chosen lm), cache = Nothing }
+        | otherwise =                                                              Nothing
+
+pruneWindows :: AvoidFloats Window -> AvoidFloats Window
+pruneWindows lm = case cache lm of
+    Nothing -> lm
+    Just ((floating,_),_) -> lm { chosen = S.filter (flip M.member floating) (chosen lm) }
+
+-- | Find all maximum empty rectangles (MERs) that are axis aligned. This is
+--   done in O(n^2) time using a modified version of the algoprithm MERAlg 1
+--   described in \"On the maximum empty rectangle problem\" by A. Naamad, D.T.
+--   Lee and W.-L HSU. Published in Discrete Applied Mathematics 8 (1984.)
+maxEmptyRectangles :: Rectangle -> [Rectangle] -> [Rectangle]
+maxEmptyRectangles br rectangles = filter (\a -> area a > 0) $ upAndDownEdge ++ noneOrUpEdge ++ downEdge
+    where
+        upAndDownEdge = findGaps br rectangles
+        noneOrUpEdge = concat $ map (everyLower br bottoms) bottoms
+        downEdge = concat $ map maybeToList $ map (bottomEdge br bottoms) bottoms
+        bottoms = sortBy (comparing bottom) $ splitContainers rectangles
+
+everyLower :: Rectangle -> [Rectangle] -> Rectangle -> [Rectangle]
+everyLower br bottoms r = let (rs, boundLeft, boundRight, boundRects) = foldr (everyUpper r) ([], left br, right br, reverse bottoms) bottoms
+                              (boundLeft', boundRight', _) = shrinkBounds boundLeft boundRight boundRects r (top br)
+                          in mkRect boundLeft' boundRight' (top br) (top r) ?: rs
+
+everyUpper
+    :: Rectangle                         -- ^ The current rectangle where the top edge is used.
+    -> Rectangle                         -- ^ The current rectangle where the bottom edge is used.
+    -> ([Rectangle],Int,Int,[Rectangle]) -- ^ List of MERs found so far, left bound, right bound and list of rectangles used for bounds.
+    -> ([Rectangle],Int,Int,[Rectangle])
+everyUpper lower upper (rs, boundLeft, boundRight, boundRects) = (r?:rs, boundLeft', boundRight', boundRects')
+    where
+        r = mkRect boundLeft' boundRight' (bottom upper) (top lower)
+        (boundLeft', boundRight', boundRects') = shrinkBounds boundLeft boundRight boundRects lower (bottom upper)
+
+shrinkBounds :: Int -> Int -> [Rectangle] -> Rectangle -> Int -> (Int, Int, [Rectangle])
+shrinkBounds boundLeft boundRight boundRects lower upperLimit = (boundLeft', boundRight', boundRects')
+    where
+        (shrinkers, boundRects') = span (\a -> bottom a > upperLimit) boundRects
+        (boundLeft', boundRight') = foldr (shrinkBounds' lower) (boundLeft, boundRight) $ filter (\a -> top a < top lower) shrinkers
+
+shrinkBounds' :: Rectangle -> Rectangle -> (Int, Int) -> (Int, Int)
+shrinkBounds' mr r (boundLeft, boundRight)
+    | right r < right mr = (max boundLeft $ right r, boundRight)
+    | left r > left mr = (boundLeft, min boundRight $ left r)
+    | otherwise = (right r, left r) -- r is horizontally covering all of mr; make sure the area of this rectangle will always be 0.
+
+bottomEdge :: Rectangle -> [Rectangle] -> Rectangle -> Maybe Rectangle
+bottomEdge br bottoms r = let rs = filter (\a -> bottom r < bottom a && top a < bottom br) bottoms
+                              boundLeft = maximum $ left br : (filter (< right r) $ map right rs)
+                              boundRight = minimum $ right br : (filter (> left r) $ map left rs)
+                          in if any (\a -> left a <= left r && right r <= right a) rs
+                             then Nothing
+                             else mkRect boundLeft boundRight (bottom r) (bottom br)
+
+-- | Split rectangles that horizontally fully contains another rectangle
+--   without sharing either the left or right side.
+splitContainers :: [Rectangle] -> [Rectangle]
+splitContainers rects = splitContainers' [] $ sortBy (comparing rect_width) rects
+    where
+        splitContainers' :: [Rectangle] -> [Rectangle] -> [Rectangle]
+        splitContainers' res [] = res
+        splitContainers' res (r:rs) = splitContainers' (r:res) $ concat $ map (doSplit r) rs
+
+        doSplit :: Rectangle -> Rectangle -> [Rectangle]
+        doSplit guide r
+            | left guide <= left r || right r <= right guide = [r]
+            | otherwise = let w0 = fi (rect_x guide - rect_x r) + (rect_width guide `div` 2)
+                              w1 = rect_width r - w0
+                          in  [ Rectangle (rect_x r)          (rect_y r) w0 (rect_height r)
+                              , Rectangle (rect_x r + fi w0)  (rect_y r) w1 (rect_height r)
+                              ]
+
+-- | Find all horizontal gaps that are left empty from top to bottom of screen.
+findGaps
+    :: Rectangle    -- ^ Bounding rectangle.
+    -> [Rectangle]  -- ^ List of all rectangles that can cover areas in the bounding rectangle.
+    -> [Rectangle]
+findGaps br rs = let (gaps,end) = foldr findGaps' ([], left br) $ sortBy (flip $ comparing left) $ filter inBounds rs
+                     lastgap = mkRect end (right br) (top br) (bottom br)
+                 in lastgap?:gaps
+    where
+        findGaps' :: Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int)
+        findGaps' r (gaps, end) = let gap = mkRect end (left r) (top br) (bottom br)
+                                  in (gap?:gaps, max end (right r))
+
+        inBounds :: Rectangle -> Bool
+        inBounds r = left r < right br && left br < right r
+
+fi :: (Integral a, Num b) => a -> b
+fi x = fromIntegral x
+
+(?:) :: Maybe a -> [a] -> [a]
+Just x ?: xs = x:xs
+_ ?: xs = xs
+
+left, right, top, bottom, area :: Rectangle -> Int
+left r = fi (rect_x r)
+right r = fi (rect_x r) + fi (rect_width r)
+top r = fi (rect_y r)
+bottom r = fi (rect_y r) + fi (rect_height r)
+area r = fi (rect_width r * rect_height r)
+
+mkRect :: Int -> Int -> Int -> Int -> Maybe Rectangle
+mkRect l r t b = let rect = Rectangle (fi l) (fi t) (fi $ max 0 $ r-l) (fi $ max 0 $ b-t)
+                 in if area rect > 0
+                    then Just rect
+                    else Nothing
diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal
index 320b400..e7d4462 100644
--- a/xmonad-contrib.cabal
+++ b/xmonad-contrib.cabal
@@ -88,6 +88,7 @@ library
                         XMonad.Doc.Configuring
                         XMonad.Doc.Extending
                         XMonad.Doc.Developing
+                        XMonad.Actions.AfterDrag
                         XMonad.Actions.BluetileCommands
                         XMonad.Actions.Commands
                         XMonad.Actions.ConstrainedResize
@@ -189,7 +190,6 @@ library
                         XMonad.Hooks.XPropManage
                         XMonad.Layout.Accordion
                         XMonad.Layout.AutoMaster
-                        XMonad.Layout.BinarySpacePartition
                         XMonad.Layout.BorderResize
                         XMonad.Layout.BoringWindows
                         XMonad.Layout.ButtonDecoration