Merge pull request #896 from Rogach/pr/window-navigation

X.A.WindowNavigation: better handling of floating windows and Full layout

CHANGES.md

@@ -92,6 +92,11 @@
     - Added screen edge support with `SCTop`, `SCBottom`, `SCLeft` and
       `SCRight`. Now both corners and edges are supported.
 
+  * `XMonad.Actions.WindowNavigation`
+
+    - Improve navigation in presence of floating windows.
+    - Handle window switching when in `Full` layout.
+
 ### Other changes
 
 ## 0.18.0 (February 3, 2024)

XMonad/Actions/WindowNavigation.hs

@@ -1,10 +1,12 @@
+{-# LANGUAGE TupleSections #-} -- I didn't want this, it's hlint's "suggestion" and it's apparently non-negotiable
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Actions.WindowNavigation
 -- Description :  Experimental rewrite of "XMonad.Layout.WindowNavigation".
 -- Copyright   :  (c) 2007  David Roundy <droundy@darcs.net>,
 --                          Devin Mullins <me@twifkak.com>
--- Maintainer  :  Devin Mullins <me@twifkak.com>
+-- Maintainer  :  Devin Mullins <me@twifkak.com>,
+--                Platon Pronko <platon7pronko@gmail.com>
 -- License     :  BSD3-style (see LICENSE)
 -- Stability   :  unstable
 -- Portability :  unportable
@@ -37,17 +39,19 @@ module XMonad.Actions.WindowNavigation (
                                        withWindowNavigationKeys,
                                        WNAction(..),
                                        go, swap,
+                                       goPure, swapPure,
                                        Direction2D(..), WNState,
                                        ) where
 
-import XMonad
+import XMonad hiding (state)
-import XMonad.Prelude (catMaybes, fromMaybe, listToMaybe, sortOn)
+import XMonad.Prelude (catMaybes, fromMaybe, sortOn)
 import XMonad.Util.Types (Direction2D(..))
 import qualified XMonad.StackSet as W
 
 import Control.Arrow (second)
 import Data.IORef
 import Data.Map (Map())
+import Data.List (partition, find)
 import qualified Data.Map as M
 import qualified Data.Set as S
 
@@ -101,27 +105,60 @@ withWindowNavigation (u,l,d,r) conf@XConfig{modMask=modm} =
 
 withWindowNavigationKeys :: [((KeyMask, KeySym), WNAction)] -> XConfig l -> IO (XConfig l)
 withWindowNavigationKeys wnKeys conf = do
-    posRef <- newIORef M.empty
+    stateRef <- newIORef M.empty
-    return conf { keys = \cnf -> M.fromList (map (second (fromWNAction posRef)) wnKeys)
+    return conf { keys = \cnf -> M.fromList (map (second (fromWNAction stateRef)) wnKeys)
                                  `M.union` keys conf cnf,
-                  logHook = logHook conf >> trackMovement posRef }
+                  logHook = logHook conf >> trackMovement stateRef }
-  where fromWNAction posRef (WNGo dir)   = go   posRef dir
+  where fromWNAction stateRef (WNGo dir)   = go   stateRef dir
-        fromWNAction posRef (WNSwap dir) = swap posRef dir
+        fromWNAction stateRef (WNSwap dir) = swap stateRef dir
 
 data WNAction = WNGo Direction2D | WNSwap Direction2D
 
 type WNState = Map WorkspaceId Point
 
--- go:
+-- | Focus window in the given direction.
--- 1. get current position, verifying it matches the current window
--- 2. get target windowrect
--- 3. focus window
--- 4. set new position
 go :: IORef WNState -> Direction2D -> X ()
-go = withTargetWindow W.focusWindow
+go stateRef dir = runPureAction stateRef (goPure dir)
 
+-- | Swap current window with the window in the given direction.
+-- Note: doesn't work with floating windows (don't think it makes much sense to swap floating windows).
 swap :: IORef WNState -> Direction2D -> X ()
-swap = withTargetWindow swapWithFocused
+swap stateRef dir = runPureAction stateRef (swapPure dir)
+
+type WindowRectFn x = (Window -> x (Maybe Rectangle))
+-- | (state, oldWindowSet, mappedWindows, windowRect)
+type WNInput x = (WNState, WindowSet, S.Set Window, WindowRectFn x)
+type WNOutput = (WNState, WindowSet)
+
+-- | Run the pure action inside X monad.
+runPureAction :: IORef WNState -> (WNInput X -> X WNOutput) -> X ()
+runPureAction stateRef action = do
+  oldState <- io (readIORef stateRef)
+  oldWindowSet <- gets windowset
+  mappedWindows <- gets mapped
+  (newState, newWindowSet) <- action (oldState, oldWindowSet, mappedWindows, windowRectX)
+  windows (const newWindowSet)
+  io $ writeIORef stateRef newState
+
+-- | Version of `go` not dependent on X monad (needed for testing).
+goPure :: Monad x => Direction2D -> WNInput x -> x WNOutput
+goPure dir input@(oldState, oldWindowSet, mappedWindows, _) =
+  if length (filter (`S.member` mappedWindows) $ W.integrate' $ W.stack $ W.workspace $ W.current oldWindowSet) == 1
+  then
+    -- Handle the special case of Full layout, when there's only one mapped window on a screen.
+    return ( oldState
+           , case dir of
+               U -> W.focusUp oldWindowSet
+               L -> W.focusDown oldWindowSet
+               D -> W.focusDown oldWindowSet
+               R -> W.focusUp oldWindowSet
+           )
+  else
+    withTargetWindow W.focusWindow dir input
+
+-- | Version of `swap` not dependent on X monad (needed for testing).
+swapPure :: Monad x => Direction2D -> WNInput x -> x WNOutput
+swapPure = withTargetWindow swapWithFocused
   where swapWithFocused targetWin winSet =
             case W.peek winSet of
                 Just currentWin -> W.focusWindow currentWin $
@@ -135,87 +172,249 @@ swap = withTargetWindow swapWithFocused
           | win == win2 = win1
           | otherwise = win
 
-withTargetWindow :: (Window -> WindowSet -> WindowSet) -> IORef WNState -> Direction2D -> X ()
+-- | Select a target window in the given direction and modify the WindowSet.
-withTargetWindow adj posRef dir = fromCurrentPoint posRef $ \win pos -> do
+-- 1. Get current position, verifying it matches the current window (exit if no focused window).
-    targets <- filter ((/= win) . fst) <$> navigableTargets pos dir
+-- 2. Get the target window.
-    whenJust (listToMaybe targets) $ \(targetWin, targetRect) -> do
+-- 3. Execute an action on the target window and windowset.
-      windows (adj targetWin)
+-- 4. Set the new position.
-      setPosition posRef pos targetRect
+withTargetWindow :: Monad x => (Window -> WindowSet -> WindowSet) -> Direction2D -> WNInput x -> x WNOutput
+withTargetWindow adj dir input@(oldState, oldWindowSet, _, _) = do
+  whenJust' (getCurrentWindow input) (oldState, oldWindowSet) $ \(win, winRect, pos) -> do
+    targetMaybe <- find ((/= win) . fst) <$> navigableTargets input dir winRect pos
+    whenJust' (pure targetMaybe) (oldState, oldWindowSet) $ \(targetWin, newPos) ->
+      let newWindowSet = adj targetWin oldWindowSet
+      in return (modifyState newWindowSet newPos oldState, newWindowSet)
 
+-- | Update position on outside changes in windows.
 trackMovement :: IORef WNState -> X ()
-trackMovement posRef = fromCurrentPoint posRef $ \win pos ->
+trackMovement stateRef = do
-                           windowRect win >>= flip whenJust (setPosition posRef pos . snd)
+  oldState <- io (readIORef stateRef)
+  oldWindowSet <- gets windowset
+  mappedWindows <- gets mapped
+  whenJust' (getCurrentWindow (oldState, oldWindowSet, mappedWindows, windowRectX)) () $ \(_, _, pos) -> do
+      io $ writeIORef stateRef $ modifyState oldWindowSet pos oldState
 
-fromCurrentPoint :: IORef WNState -> (Window -> Point -> X ()) -> X ()
+-- | Get focused window and current position.
-fromCurrentPoint posRef f = withFocused $ \win ->
+getCurrentWindow :: Monad x => WNInput x -> x (Maybe (Window, Rectangle, Point))
-                                currentPosition posRef >>= f win
+getCurrentWindow input@(_, oldWindowSet, _, _) =
+  whenJust' (pure $ W.peek oldWindowSet) Nothing $ \window -> do
+    (pos, rect) <- currentPosition input
+    return $ Just (window, rect, pos)
 
--- Gets the current position from the IORef passed in, or if nothing (say, from
+-- | Gets the current position from the state passed in, or if nothing
--- a restart), derives the current position from the current window. Also,
+-- (say, from a restart), derives the current position from the current window.
--- verifies that the position is congruent with the current window (say, if you
+-- Also, verifies that the position is congruent with the current window
--- used mod-j/k or mouse or something).
+-- (say, if you moved focus using mouse or something).
-currentPosition :: IORef WNState -> X Point
+-- Returns the window rectangle for convenience, since we'll need it later anyway.
-currentPosition posRef = do
+currentPosition :: Monad x => WNInput x -> x (Point, Rectangle)
-    root <- asks theRoot
+currentPosition (state, oldWindowSet, _, windowRect) = do
-    currentWindow <- gets (W.peek . windowset)
+  currentRect <- fromMaybe (Rectangle 0 0 0 0) <$> maybe (pure Nothing) windowRect (W.peek oldWindowSet)
-    currentRect <- maybe (Rectangle 0 0 0 0) snd <$> windowRect (fromMaybe root currentWindow)
+  let posMaybe = M.lookup (W.currentTag oldWindowSet) state
+      middleOf (Rectangle x y w h) = Point (midPoint x w) (midPoint y h)
+  return $ case posMaybe of
+    Nothing -> (middleOf currentRect, currentRect)
+    Just pos -> (centerPosition currentRect pos, currentRect)
 
-    wsid <- gets (W.currentTag . windowset)
+-- | Inserts new position into the state.
-    mp <- M.lookup wsid <$> io (readIORef posRef)
+modifyState :: WindowSet -> Point -> WNState -> WNState
+modifyState oldWindowSet =
+  M.insert (W.currentTag oldWindowSet)
 
-    return $ maybe (middleOf currentRect) (`inside` currentRect) mp
+-- | "Jumps" the current position into the middle of target rectangle.
-
+-- (keeps the position as-is if it is already inside the target rectangle)
-  where middleOf (Rectangle x y w h) = Point (midPoint x w) (midPoint y h)
+centerPosition :: Rectangle -> Point -> Point
-
+centerPosition r@(Rectangle rx ry rw rh) pos@(Point x y) = do
-setPosition :: IORef WNState -> Point -> Rectangle -> X ()
+  if pointWithin x y r
-setPosition posRef oldPos newRect = do
-    wsid <- gets (W.currentTag . windowset)
-    io $ modifyIORef posRef $ M.insert wsid (oldPos `inside` newRect)
-
-inside :: Point -> Rectangle -> Point
-Point x y `inside` Rectangle rx ry rw rh =
-    Point (x `within` (rx, rw)) (y `within` (ry, rh))
-  where pos `within` (lower, dim) = if pos >= lower && pos < lower + fromIntegral dim
   then pos
-                                    else midPoint lower dim
+  else Point (midPoint rx rw) (midPoint ry rh)
 
 midPoint :: Position -> Dimension -> Position
 midPoint pos dim = pos + fromIntegral dim `div` 2
 
-navigableTargets :: Point -> Direction2D -> X [(Window, Rectangle)]
+-- | Make a list of target windows we can navigate to,
-navigableTargets point dir = navigable dir point <$> windowRects
+-- sorted by desirability of navigation.
+navigableTargets :: Monad x => WNInput x -> Direction2D -> Rectangle -> Point -> x [(Window, Point)]
+navigableTargets input@(_, oldWindowSet, _, _) dir currentRect currentPos = do
+  allScreensWindowsAndRectangles <- mapSnd (rectTransform dir) <$> windowRects input
+  let
+    screenWindows = S.fromList $ W.integrate' $ W.stack $ W.workspace $ W.current oldWindowSet
+    (thisScreenWindowsAndRectangles, otherScreensWindowsAndRectangles) = partition (\(w, _) -> S.member w screenWindows) allScreensWindowsAndRectangles
 
--- Filters and sorts the windows in terms of what is closest from the Point in
+    pos = pointTransform dir currentPos
--- the Direction2D.
+    wr = rectTransform dir currentRect
-navigable :: Direction2D -> Point -> [(Window, Rectangle)] -> [(Window, Rectangle)]
-navigable d pt = sortby d . filter (inr d pt . snd)
 
--- Produces a list of normal-state windows, on any screen. Rectangles are
+    rectInside r = (rect_p1 r >= rect_p1 wr && rect_p1 r < rect_p2 wr && rect_p2 r > rect_p1 wr && rect_p2 r <= rect_p2 wr) &&
--- adjusted based on screen position relative to the current screen, because I'm
+                   ((rect_o1 r >= rect_o1 wr && rect_o1 r < rect_o2 wr && rect_o2 r > rect_o1 wr && rect_o2 r <= rect_o2 wr) ||
--- bad like that.
+                    (rect_o1 r <= rect_o1 wr && rect_o2 r >= rect_o2 wr)) -- include windows that fully overlaps current on the orthogonal axis
-windowRects :: X [(Window, Rectangle)]
+    sortByP2 = sortOn (rect_p2 . snd)
-windowRects = fmap catMaybes . mapM windowRect . S.toList =<< gets mapped
+    posBeforeEdge r = point_p pos < rect_p2 r
 
-windowRect :: Window -> X (Maybe (Window, Rectangle))
+    rectOverlapsEdge r = rect_p1 r <= rect_p2 wr && rect_p2 r > rect_p2 wr &&
-windowRect win = withDisplay $ \dpy -> do
+                         rect_o1 r < rect_o2 wr && rect_o2 r > rect_o1 wr
+    rectOverlapsOneEdge r = rectOverlapsEdge r && rect_p1 r > rect_p1 wr
+    rectOverlapsBothEdges r = rectOverlapsEdge r &&
+                              rect_o1 r > rect_o1 wr && rect_o2 r < rect_o2 wr && point_o pos >= rect_o1 r && point_o pos < rect_o2 r
+    distanceToRectEdge r = max (max 0 (rect_o1 r - point_o pos)) (max 0 (point_o pos + 1 - rect_o2 r))
+    distanceToRectCenter r =
+      let distance = (rect_o1 r + rect_o2 r) `div` 2 - point_o pos
+      in if distance <= 0
+         then distance + 1
+         else distance
+    sortByPosDistance = sortOn ((\r -> (rect_p1 r, distanceToRectEdge r, distanceToRectCenter r)) . snd)
+
+    rectOutside r = rect_p1 r < rect_p1 wr && rect_p2 r > rect_p2 wr &&
+                    rect_o1 r < rect_o1 wr && rect_o2 r > rect_o2 wr
+    sortByLength = sortOn (rect_psize . snd)
+
+    rectAfterEdge r = rect_p1 r > rect_p2 wr
+
+    -- Modified from David Roundy and Devin Mullins original implementation of WindowNavigation:
+    inr r = point_p pos < rect_p2 r && point_o pos >= rect_o1 r && point_o pos < rect_o2 r
+
+    clamp v v1 v2 | v < v1 = v1
+                  | v >= v2 = v2 - 1
+                  | otherwise = v
+    dragPos r = DirPoint (max (point_p pos) (rect_p1 r)) (clamp (point_o pos) (rect_o1 r) (rect_o2 r))
+
+  return $ mapSnd (inversePointTransform dir) $ concat
+    [
+      -- First, navigate to windows that are fully inside current window
+      -- and have higher coordinate bigger than current position.
+      -- ┌──────────────────┐
+      -- │   current        │  (all examples assume direction=R)
+      -- │    ┌──────────┐  │
+      -- │  ──┼─► inside │  │
+      -- │    └──────────┘  │
+      -- └──────────────────┘
+      -- Also include windows fully overlapping current on the orthogonal axis:
+      --             ┌──────────────┐
+      --             │ overlapping  │
+      -- ┌───────────┤              ├────┐
+      -- │ current ──┼─►            │    │
+      -- └───────────┤              ├────┘
+      --             └──────────────┘
+      mapSnd dragPos $ sortByP2 $ filterSnd posBeforeEdge $ filterSnd rectInside thisScreenWindowsAndRectangles
+
+      -- Then navigate to windows that touch or overlap the edge of current window in the chosen direction.
+      -- ┌──────────────┬─────────────┐   ┌───────────┐                   ┌─────────────┐
+      -- │ current      │ adjacent    │   │ current   │                   │ current     │
+      -- │            ──┼─►           │   │       ┌───┴───────────────┐   │         ┌───┴─────────────┐
+      -- │              │             │   │     ──┼─► │   overlapping │   │       ──┼─►               │
+      -- │              ├─────────────┘   │       └───┬───────────────┘   └─────────┤     overlapping │
+      -- │              │                 │           │                             │                 │
+      -- └──────────────┘                 └───────────┘                             └─────────────────┘
+    , mapSnd dragPos $ sortByPosDistance $ filterSnd rectOverlapsOneEdge thisScreenWindowsAndRectangles
+
+      -- Windows fully overlapping current window "in the middle" on the parallel axis are also included,
+      -- if position is inside them:
+      --     ┌───────────┐
+      --     │  current  │
+      -- ┌───┤-----------├────────────────┐
+      -- │   │     *   ──┼─►  overlapping │
+      -- └───┤-----------├────────────────┘
+      --     └───────────┘
+    , mapSnd (\_ -> DirPoint (rect_p2 wr) (point_o pos)) $ sortByPosDistance $ filterSnd rectOverlapsBothEdges thisScreenWindowsAndRectangles
+
+      -- Then navigate to windows that fully encompass the current window.
+      -- ┌─────────────────────┐
+      -- │    outer            │
+      -- │  ┌─────────────┐    │
+      -- │  │  current  ──┼─►  │
+      -- │  └─────────────┘    │
+      -- └─────────────────────┘
+    , mapSnd (\_ -> DirPoint (rect_p2 wr) (point_o pos)) $ sortByLength $ filterSnd rectOutside thisScreenWindowsAndRectangles
+
+      -- Then navigate to windows that are fully after current window in the chosen direction.
+      -- ┌──────────────┐
+      -- │ current      │  ┌────────────────┐
+      -- │              │  │                │
+      -- │            ──┼──┼─► not adjacent │
+      -- │              │  │                │
+      -- │              │  └────────────────┘
+      -- └──────────────┘
+    , mapSnd dragPos $ sortByPosDistance $ filterSnd rectAfterEdge thisScreenWindowsAndRectangles
+
+      -- Cast a ray from the current position, jump to the first window (on another screen) that intersects this ray.
+    , mapSnd dragPos $ sortByPosDistance $ filterSnd inr otherScreensWindowsAndRectangles
+
+      -- If everything else fails, then navigate to the window that is fully inside current window,
+      -- but is before the current position.
+      -- This can happen when we are at the last window on a screen, and attempt to navigate even further.
+      -- In this case it seems okay to jump to the remaining inner windows, since we don't have any other choice anyway,
+      -- and user is probably not so fully aware of the precise position anyway.
+    , mapSnd (\r -> DirPoint (rect_p2 r - 1) (clamp (point_o pos) (rect_o1 r) (rect_o2 r))) $
+      sortByP2 $ filterSnd (not . posBeforeEdge) $ filterSnd rectInside thisScreenWindowsAndRectangles
+    ]
+
+-- Structs for direction-independent space - equivalent to rotating points and rectangles such that
+-- navigation direction points to the right.
+-- Allows us to abstract over direction in the navigation functions.
+data DirPoint = DirPoint
+  { point_p :: Position -- coordinate parallel to the direction
+  , point_o :: Position -- coordinate orthogonal to the direction
+  }
+data DirRectangle = DirRectangle
+  { rect_p1 :: Position -- lower rectangle coordinate parallel to the direction
+  , rect_p2 :: Position -- higher rectangle coordinate parallel to the direction
+  , rect_o1 :: Position -- lower rectangle coordinate orthogonal to the direction
+  , rect_o2 :: Position -- higher rectangle coordinate orthogonal to the direction
+  }
+{- HLINT ignore "Use camelCase" -}
+rect_psize :: DirRectangle -> Dimension
+rect_psize r = fromIntegral (rect_p2 r - rect_p1 r)
+
+-- | Transform a point from screen space into direction-independent space.
+pointTransform :: Direction2D -> Point -> DirPoint
+pointTransform dir (Point x y) = case dir of
+  U -> DirPoint (negate y - 1) x
+  L -> DirPoint (negate x - 1) (negate y - 1)
+  D -> DirPoint y (negate x - 1)
+  R -> DirPoint x y
+
+-- | Transform a point from direction-independent space back into screen space.
+inversePointTransform :: Direction2D -> DirPoint -> Point
+inversePointTransform dir p = case dir of
+  U -> Point (point_o p) (negate $ point_p p + 1)
+  L -> Point (negate $ point_p p + 1) (negate $ point_o p + 1)
+  D -> Point (negate $ point_o p + 1) (point_p p)
+  R -> Point (point_p p) (point_o p)
+
+-- | Transform a rectangle from screen space into direction-independent space.
+rectTransform :: Direction2D -> Rectangle -> DirRectangle
+rectTransform dir (Rectangle x y w h) = case dir of
+  U -> DirRectangle (negate $ y + fromIntegral h) (negate y) x (x + fromIntegral w)
+  L -> DirRectangle (negate $ x + fromIntegral w) (negate x) (negate $ y + fromIntegral h) (negate y)
+  D -> DirRectangle y (y + fromIntegral h) (negate $ x + fromIntegral w) (negate x)
+  R -> DirRectangle x (x + fromIntegral w) y (y + fromIntegral h)
+
+-- | Produces a list of normal-state windows on all screens, excluding currently focused window.
+windowRects :: Monad x => WNInput x -> x [(Window, Rectangle)]
+windowRects (_, oldWindowSet, mappedWindows, windowRect) =
+  let
+    allWindows = filter (\w -> w `notElem` W.peek oldWindowSet) $ S.toList mappedWindows
+    windowRect2 w = fmap (w,) <$> windowRect w
+  in catMaybes <$> mapM windowRect2 allWindows
+
+windowRectX :: Window -> X (Maybe Rectangle)
+windowRectX win = withDisplay $ \dpy -> do
     (_, x, y, w, h, bw, _) <- io $ getGeometry dpy win
-    return $ Just (win, Rectangle x y (w + 2 * bw) (h + 2 * bw))
+    return $ Just $ Rectangle x y (w + 2 * bw) (h + 2 * bw)
     `catchX` return Nothing
 
--- Modified from droundy's implementation of WindowNavigation:
+-- Maybe below functions can be replaced with some standard helper functions?
 
-inr :: Direction2D -> Point -> Rectangle -> Bool
+-- | Execute a monadic action on the contents if Just, otherwise wrap default value and return it.
-inr D (Point px py) (Rectangle rx ry w h) = px >= rx && px < rx + fromIntegral w &&
+whenJust' :: Monad x => x (Maybe a) -> b -> (a -> x b) -> x b
-                                                        py < ry + fromIntegral h
+whenJust' monadMaybeValue deflt f = do
-inr U (Point px py) (Rectangle rx ry w _) = px >= rx && px < rx + fromIntegral w &&
+  maybeValue <- monadMaybeValue
-                                            py >  ry
+  case maybeValue of
-inr R (Point px py) (Rectangle rx ry w h) =             px < rx + fromIntegral w &&
+    Nothing -> return deflt
-                                            py >= ry && py < ry + fromIntegral h
+    Just value -> f value
-inr L (Point px py) (Rectangle rx ry _ h) = px >  rx &&
-                                            py >= ry && py < ry + fromIntegral h
 
-sortby :: Direction2D -> [(a,Rectangle)] -> [(a,Rectangle)]
+-- | Filter a list of tuples on the second tuple member.
-sortby D = sortOn (rect_y . snd)
+filterSnd :: (b -> Bool) -> [(a, b)] -> [(a, b)]
-sortby R = sortOn (rect_x . snd)
+filterSnd f = filter (f . snd)
-sortby U = reverse . sortby D
+
-sortby L = reverse . sortby R
+-- | Map a second tuple member in a list of tuples.
+mapSnd :: (b -> b') -> [(a, b)] -> [(a, b')]
+mapSnd f = map (second f)

tests/Main.hs

@@ -14,6 +14,7 @@ import qualified CycleRecentWS
 import qualified OrgMode
 import qualified GridSelect
 import qualified EZConfig
+import qualified WindowNavigation
 
 main :: IO ()
 main = hspec $ do
@@ -53,3 +54,4 @@ main = hspec $ do
     context "OrgMode"        OrgMode.spec
     context "GridSelect"     GridSelect.spec
     context "EZConfig"       EZConfig.spec
+    context "WindowNavigation" WindowNavigation.spec

tests/WindowNavigation.hs

@@ -0,0 +1,635 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module WindowNavigation where
+
+import Test.Hspec
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Functor.Identity
+
+import XMonad
+import XMonad.Util.Types (Direction2D(..))
+import XMonad.Actions.WindowNavigation (goPure, swapPure, WNState)
+import qualified XMonad.StackSet as W
+
+spec :: Spec
+spec = do
+  it "two-window adjacent go right (empty state)" $ do
+    -- Simplest case - just move the focus once.
+    -- ┌─────┬──────┐
+    -- │ 1 ──┼─►  2 │
+    -- └─────┴──────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 1280)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2], windowRect)
+    runNav R M.empty (mkws 1 [] [2])
+      `shouldBe` (mkstate 960 640, mkws 2 [1] [])
+
+  it "two-window adjacent go right (populated state)" $ do
+    -- Like the previous test, but this time internal stat is already populated with a position.
+    -- ┌─────┬──────┐
+    -- │ 1 ──┼─►  2 │
+    -- └─────┴──────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 1280)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2], windowRect)
+    runNav R (mkstate 100 100) (mkws 1 [] [2])
+      `shouldBe` (mkstate 960 100, mkws 2 [1] [])
+
+  it "two-window adjacent go right (incorrectly-populated state)" $ do
+    -- This time we set the position incorrectly, testing if it will be reset to the center of focused window.
+    -- ┌─────┬──────┐
+    -- │ 1 ──┼─►  2 │
+    -- └─────┴──────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 1280)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2], windowRect)
+    runNav R (mkstate 1000 100) (mkws 1 [] [2])
+      `shouldBe` (mkstate 960 640, mkws 2 [1] [])
+
+  it "swap windows" $ do
+    -- Swap windows around.
+    -- ┌─────┬──────┐
+    -- │ 1 ◄─┼─►  2 │
+    -- └─────┴──────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 1280)
+          ]
+    runIdentity (swapPure R (M.empty, mkws 1 [] [2], S.fromList [1, 2], windowRect))
+      `shouldBe` (mkstate 960 640, mkws 1 [2] [])
+
+  it "tall layout, go up" $ do
+    -- ┌─────┬─────┐
+    -- │     │ 2 ▲ │
+    -- │  1  ├───┼─┤
+    -- │     │ 3 │ │
+    -- └─────┴─────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 640)
+          , (3, Rectangle 960 640 960 640)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2, 3], windowRect)
+    runNav U M.empty (mkws 3 [] [1, 2])
+      `shouldBe` (mkstate 1440 639, mkws 2 [1, 3] [])
+
+  it "tall layout, go down" $ do
+    -- ┌─────┬─────┐
+    -- │     │ 2   │
+    -- │     ├─────┤
+    -- │  1  │ 3 │ │
+    -- │     ├───┼─┤
+    -- │     │ 4 ▼ │
+    -- └─────┴─────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 400)
+          , (3, Rectangle 960 400 960 400)
+          , (4, Rectangle 960 800 960 480)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)
+    runNav D M.empty (mkws 3 [] [1, 2, 4])
+      `shouldBe` (mkstate 1440 800, mkws 4 [2, 1, 3] [])
+
+  it "tall layout, go left" $ do
+    -- ┌─────┬─────┐
+    -- │   ◄─┼── 2 │
+    -- │     ├─────┤
+    -- │ 1   │   3 │
+    -- │     ├─────┤
+    -- │     │   4 │
+    -- └─────┴─────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 400)
+          , (3, Rectangle 960 400 960 400)
+          , (4, Rectangle 960 800 960 480)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)
+    runNav L M.empty (mkws 2 [] [1, 3, 4])
+      `shouldBe` (mkstate 959 200, mkws 1 [2] [3, 4])
+
+  it "tall layout, go left and then right (window 2)" $ do
+    -- ┌─────┬─────┐
+    -- │   ◄─┼── 2 │
+    -- │   ──┼─►   │
+    -- │     ├─────┤
+    -- │ 1   │   3 │
+    -- │     ├─────┤
+    -- │     │   4 │
+    -- └─────┴─────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 400)
+          , (3, Rectangle 960 400 960 400)
+          , (4, Rectangle 960 800 960 480)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)
+    let (st2, ws2) = runNav L M.empty (mkws 2 [] [1, 3, 4])
+    (st2, ws2) `shouldBe` (mkstate 959 200, mkws 1 [2] [3, 4])
+    let (st3, ws3) = runNav R st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 960 200, mkws 2 [] [1, 3, 4])
+
+  it "tall layout, go left and then right (window 3)" $ do
+    -- ┌─────┬─────┐
+    -- │     │   2 │
+    -- │     ├─────┤
+    -- │ 1 ◄─┼── 3 │
+    -- │   ──┼─►   │
+    -- │     ├─────┤
+    -- │     │   4 │
+    -- └─────┴─────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 400)
+          , (3, Rectangle 960 400 960 400)
+          , (4, Rectangle 960 800 960 480)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)
+    let (st2, ws2) = runNav L M.empty (mkws 3 [] [1, 2, 4])
+    (st2, ws2) `shouldBe` (mkstate 959 600, mkws 1 [3] [2, 4])
+    let (st3, ws3) = runNav R st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 960 600, mkws 3 [] [1, 2, 4])
+
+  it "tall layout, go left and then right (window 4)" $ do
+    -- ┌─────┬─────┐
+    -- │     │   2 │
+    -- │     ├─────┤
+    -- │ 1   │   3 │
+    -- │     ├─────┤
+    -- │   ◄─┼── 4 │
+    -- │   ──┼─►   │
+    -- └─────┴─────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 400)
+          , (3, Rectangle 960 400 960 400)
+          , (4, Rectangle 960 800 960 480)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)
+    let (st2, ws2) = runNav L M.empty (mkws 4 [] [1, 2, 3])
+    (st2, ws2) `shouldBe` (mkstate 959 1040, mkws 1 [4] [2, 3])
+    let (st3, ws3) = runNav R st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 960 1040, mkws 4 [] [1, 2, 3])
+
+  it "grid layout, go in a circle" $ do
+    -- ┌─────┬─────┐
+    -- │ 1 ──┼─► 2 │
+    -- │     │     │
+    -- │ ▲   │   │ │
+    -- ├─┼───┼───┼─┤
+    -- │ │   │   ▼ │
+    -- │     │     │
+    -- │ 3 ◄─┼── 4 │
+    -- └─────┴─────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 640)
+          , (2, Rectangle 960 0 960 640)
+          , (3, Rectangle 0 640 960 640)
+          , (4, Rectangle 960 640 960 640)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)
+    let (st2, ws2) = runNav R M.empty (mkws 1 [] [2, 3, 4])
+    (st2, ws2) `shouldBe` (mkstate 960 320, mkws 2 [1] [3, 4])
+    let (st3, ws3) = runNav D st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 960 640, mkws 4 [3, 2, 1] [])
+    let (st4, ws4) = runNav L st3 ws3
+    (st4, ws4) `shouldBe` (mkstate 959 640, mkws 3 [2, 1] [4])
+    let (st5, ws5) = runNav U st4 ws4
+    (st5, ws5) `shouldBe` (mkstate 959 639, mkws 1 [] [2, 3, 4])
+
+  it "ignore window that fully overlaps the current window in parallel direction when pos is outside it" $ do
+    -- ┌─────┬──────┬──────┐
+    -- │ ┌───┴──────┴────┐ │
+    -- │ │   |  4   |    │ │
+    -- │ └───┬──────┬────┘ │
+    -- │  1  │  2 ──┼─► 3  │
+    -- └─────┴──────┴──────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 600 1280)
+          , (2, Rectangle 600 0 600 1280)
+          , (3, Rectangle 1200 0 720 1280)
+          , (4, Rectangle 200 200 1520 400)
+          ]
+    runIdentity (goPure R (mkstate 900 900, mkws 2 [] [1, 3, 4], S.fromList [1..4], windowRect))
+      `shouldBe` (mkstate 1200 900, mkws 3 [1,2] [4])
+
+  it "go to window that fully overlaps the current window in parallel direction when pos is inside it" $ do
+    -- ┌─────────────────┐
+    -- │     ┌──────┐    │
+    -- │  1  │      │    │
+    -- ├─────┤------├────┤
+    -- │     │      │    │
+    -- │  2  │  4 ──┼─►  │
+    -- │     │      │    │
+    -- ├─────┤------├────┤
+    -- │  3  │      │    │
+    -- │     └──────┘    │
+    -- └─────────────────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 1920 400)
+          , (2, Rectangle 0 400 1920 400)
+          , (3, Rectangle 0 800 1920 480)
+          , (4, Rectangle 800 200 400 880)
+          ]
+    runIdentity (goPure R (mkstate 1000 600, mkws 4 [] [1, 2, 3], S.fromList [1..4], windowRect))
+      `shouldBe` (mkstate 1200 600, mkws 2 [1,4] [3])
+
+  it "go from inner window to outer" $ do
+    -- ┌───────────────┐
+    -- │      ┌──────┐ │
+    -- │  1 ◄─┼── 2  │ │
+    -- │      └──────┘ │
+    -- └───────────────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 1920 1280)
+          , (2, Rectangle 600 600 600 600)
+          ]
+    runIdentity (goPure L (M.empty, mkws 2 [] [1], S.fromList [1, 2], windowRect))
+      `shouldBe` (mkstate 599 900, mkws 1 [2] [])
+
+  it "if there are multiple outer windows, go to the smaller one" $ do
+    -- ┌────────────────────────┐
+    -- │  ┌───────────────┐     │
+    -- │  │      ┌──────┐ │     │
+    -- │  │  2 ◄─┼── 3  │ │  1  │
+    -- │  │      └──────┘ │     │
+    -- │  └───────────────┘     │
+    -- └────────────────────────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 1920 1280)
+          , (2, Rectangle 200 200 1520 880)
+          , (3, Rectangle 400 400 400 400)
+          ]
+    runIdentity (goPure L (M.empty, mkws 3 [] [1, 2], S.fromList [1..3], windowRect))
+      `shouldBe` (mkstate 399 600, mkws 2 [1, 3] [])
+
+  it "two tiled and one floating, floating fully inside" $ do
+    -- ┌───────────────────┬─────┐
+    -- │   ┌───────┐       │     │
+    -- │ ──┼─►   ──┼─►   ──┼─►   │
+    -- │   │   3   │   1   │   2 │
+    -- │   │     ◄─┼──   ◄─┼──   │
+    -- │   └───────┘       │     │
+    -- └───────────────────┴─────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 1280)
+          , (3, Rectangle 400 400 400 400)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..3], windowRect)
+    let (st2, ws2) = runNav R (mkstate 100 100) (mkws 1 [] [2, 3])
+    (st2, ws2) `shouldBe` (mkstate 400 400, mkws 3 [2, 1] [])
+    let (st3, ws3) = runNav R st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 800 400, mkws 1 [] [2, 3])
+    let (st4, ws4) = runNav R st3 ws3
+    (st4, ws4) `shouldBe` (mkstate 960 400, mkws 2 [1] [3])
+    let (st5, ws5) = runNav L st4 ws4
+    (st5, ws5) `shouldBe` (mkstate 959 400, mkws 1 [] [2, 3])
+    let (st6, ws6) = runNav L st5 ws5
+    (st6, ws6) `shouldBe` (mkstate 799 400, mkws 3 [2, 1] [])
+
+  it "two floating windows inside one big tiled one" $ do
+    -- ┌─────────┐
+    -- │    │    │
+    -- │ ┌──┼──┐ │
+    -- │ │  ▼  │ │
+    -- │ │  3  │ │
+    -- │ └──┼──┘ │
+    -- │    ▼    │
+    -- │    1    │
+    -- │ ┌──┼──┐ │
+    -- │ │  ▼  │ │
+    -- │ │  4  │ │
+    -- │ └──┼──┘ │
+    -- │    ▼    │
+    -- ├────┼────┤
+    -- │    ▼    │
+    -- │    2    │
+    -- └─────────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 1920 640)
+          , (2, Rectangle 0 640 1920 640)
+          , (3, Rectangle 200 200 100 100)
+          , (4, Rectangle 1000 400 100 100)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)
+    let (st2, ws2) = runNav D (mkstate 1000 250) (mkws 1 [] [2, 3, 4])
+    (st2, ws2) `shouldBe` (mkstate 299 250, mkws 3 [2, 1] [4])
+    let (st3, ws3) = runNav D st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 299 300, mkws 1 [] [2, 3, 4])
+    let (st4, ws4) = runNav D st3 ws3
+    (st4, ws4) `shouldBe` (mkstate 1000 400, mkws 4 [3, 2, 1] [])
+    let (st5, ws5) = runNav D st4 ws4
+    (st5, ws5) `shouldBe` (mkstate 1000 500, mkws 1 [] [2, 3, 4])
+    let (st6, ws6) = runNav D st5 ws5
+    (st6, ws6) `shouldBe` (mkstate 1000 640, mkws 2 [1] [3, 4])
+
+  it "floating window between two tiled ones" $ do
+    -- ┌───────┬────────┐
+    -- │ 1 ┌───┴───┐  2 │
+    -- │ ──┼─► 3 ──┼─►  │
+    -- │   └───┬───┘    │
+    -- └───────┴────────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 1280)
+          , (3, Rectangle 860 540 200 200)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..3], windowRect)
+    let (st2, ws2) = runNav R M.empty (mkws 1 [] [2, 3])
+    (st2, ws2) `shouldBe` (mkstate 860 640, mkws 3 [2, 1] [])
+    let (st3, ws3) = runNav R st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 960 640, mkws 2 [1] [3])
+
+  it "floating window overlapping four tiled ones" $ do
+    -- ┌───────┬───────┐
+    -- │   ┌───┴───┐   │
+    -- │ 1 │       │ 2 │
+    -- ├───┤       ├───┤
+    -- │ ──┼─► 5 ──┼─► │
+    -- │ 3 └───┬───┘ 4 │
+    -- └───────┴───────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 640)
+          , (2, Rectangle 960 0 960 640)
+          , (3, Rectangle 0 640 960 640)
+          , (4, Rectangle 960 640 960 640)
+          , (5, Rectangle 760 440 400 400)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..5], windowRect)
+    let (st2, ws2) = runNav R (mkstate 480 640) (mkws 3 [] [1, 2, 4, 5])
+    (st2, ws2) `shouldBe` (mkstate 760 640, mkws 5 [4, 2, 1, 3] [])
+    let (st3, ws3) = runNav R st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 960 640, mkws 4 [2, 1, 3] [5])
+
+  it "sequential inner floating windows" $ do
+    -- ┌───────────────────────────────────┬──────┐
+    -- │   ┌───────┐                       │      │
+    -- │   │       │       ┌───────┐       │      │
+    -- │ ──┼─► 3 ──┼─► 1 ──┼─► 4 ──┼─►   ──┼─► 2  │
+    -- │ ◄─┼──   ◄─┼──   ◄─┼──   ◄─┼──   ◄─┼──    │
+    -- │   └───────┘       │       │       │      │
+    -- │                   └───────┘       │      │
+    -- └───────────────────────────────────┴──────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 1280)
+          , (3, Rectangle 200 200 200 200)
+          , (4, Rectangle 600 600 200 200)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)
+    let (st2, ws2) = runNav R (mkstate 100 100) (mkws 1 [] [2, 3, 4])
+    (st2, ws2) `shouldBe` (mkstate 200 200, mkws 3 [2,1] [4])
+    let (st3, ws3) = runNav R st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 400 200, mkws 1 [] [2, 3, 4])
+    let (st4, ws4) = runNav R st3 ws3
+    (st4, ws4) `shouldBe` (mkstate 600 600, mkws 4 [3, 2, 1] [])
+    let (st5, ws5) = runNav R st4 ws4
+    (st5, ws5) `shouldBe` (mkstate 800 600, mkws 1 [] [2, 3, 4])
+    let (st6, ws6) = runNav R st5 ws5
+    (st6, ws6) `shouldBe` (mkstate 960 600, mkws 2 [1] [3, 4])
+    let (st7, ws7) = runNav L st6 ws6
+    (st7, ws7) `shouldBe` (mkstate 959 600, mkws 1 [] [2, 3, 4])
+    let (st8, ws8) = runNav L st7 ws7
+    (st8, ws8) `shouldBe` (mkstate 799 600, mkws 4 [3, 2, 1] [])
+    let (st9, ws9) = runNav L st8 ws8
+    (st9, ws9) `shouldBe` (mkstate 599 600, mkws 1 [] [2, 3, 4])
+    let (st10, ws10) = runNav L st9 ws9
+    (st10, ws10) `shouldBe` (mkstate 399 399, mkws 3 [2, 1] [4])
+    let (st11, ws11) = runNav L st10 ws10
+    (st11, ws11) `shouldBe` (mkstate 199 399, mkws 1 [] [2, 3, 4])
+
+  it "overlapping inner floating windows" $ do
+    -- ┌─────────────────────┬──────┐
+    -- │ ┌─────────┐         │      │
+    -- │ │  3 ┌────┴─┐       │      │
+    -- │ │  ──┼─►  ──┼─► 1 ──┼─►  2 │
+    -- │ │  ◄─┼──  ◄─┼──   ◄─┼──    │
+    -- │ │    │  4   │       │      │
+    -- │ └────┤      │       │      │
+    -- │      └──────┘       │      │
+    -- └─────────────────────┴──────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 1280)
+          , (3, Rectangle 200 200 400 400)
+          , (4, Rectangle 300 300 400 400)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)
+    let (st2, ws2) = runNav R M.empty (mkws 3 [] [1, 2, 4])
+    (st2, ws2) `shouldBe` (mkstate 400 400, mkws 4 [2, 1, 3] [])
+    let (st3, ws3) = runNav R st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 700 400, mkws 1 [3] [2, 4])
+    let (st4, ws4) = runNav R st3 ws3
+    (st4, ws4) `shouldBe` (mkstate 960 400, mkws 2 [1, 3] [4])
+    let (st5, ws5) = runNav L st4 ws4
+    (st5, ws5) `shouldBe` (mkstate 959 400, mkws 1 [3] [2, 4])
+    let (st6, ws6) = runNav L st5 ws5
+    (st6, ws6) `shouldBe` (mkstate 699 400, mkws 4 [2, 1, 3] [])
+    let (st7, ws7) = runNav L st6 ws6
+    (st7, ws7) `shouldBe` (mkstate 599 400, mkws 3 [] [1, 2, 4])
+
+  it "bounce back from the wall to the floating window" $ do
+    -- ┌────────────────┬─────┐
+    -- │  1   ┌──────┐  │     │
+    -- │  ┌───┼─►  3 │  │  2  │
+    -- │  └── │      │  │     │
+    -- │      └──────┘  │     │
+    -- └────────────────┴─────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 1280)
+          , (3, Rectangle 400 400 200 200)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..3], windowRect)
+    runNav L (mkstate 100 640) (mkws 1 [] [2, 3])
+      `shouldBe` (mkstate 400 599, mkws 3 [2, 1] [])
+
+  it "jump between screens" $ do
+    -- ┌─────┬──────┐  ┌────────┐
+    -- │     │  2   │  │    5   │
+    -- │     ├──────┤  ├────────┤
+    -- │  1  │  3 ──┼──┼─►  6   │
+    -- │     ├──────┤  └────────┘
+    -- │     │  4   │
+    -- └─────┴──────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 400)
+          , (3, Rectangle 960 400 960 400)
+          , (4, Rectangle 960 800 960 480)
+          , (5, Rectangle 1920 0 1280 384)
+          , (6, Rectangle 1920 384 1280 384)
+          ]
+        initWindowSet =
+          W.StackSet
+          { W.current =
+              W.Screen
+              { W.workspace =
+                  W.Workspace
+                  { W.tag = "A"
+                  , W.layout = Layout NullLayout
+                  , W.stack = Just $ W.Stack { W.focus = 3, W.up = [], W.down = [1, 2, 4] }
+                  }
+              , W.screen = 1
+              , W.screenDetail = SD { screenRect = Rectangle 0 0 1920 1280 }
+              }
+          , W.visible =
+              [ W.Screen
+                { W.workspace =
+                    W.Workspace
+                    { W.tag = "B"
+                    , W.layout = Layout NullLayout
+                    , W.stack = Just $ W.Stack { W.focus = 5, W.up = [], W.down = [6] }
+                    }
+                , W.screen = 2
+                , W.screenDetail = SD { screenRect = Rectangle 1920 0 1280 768 }
+                }
+              ]
+          , W.hidden = []
+          , W.floating = M.empty
+          }
+        expectedWindowSet =
+          W.StackSet
+          { W.current =
+              W.Screen
+              { W.workspace =
+                  W.Workspace
+                  { W.tag = "B"
+                  , W.layout = Layout NullLayout
+                  , W.stack = Just $ W.Stack { W.focus = 6, W.up = [5], W.down = [] }
+                  }
+              , W.screen = 2
+              , W.screenDetail = SD { screenRect = Rectangle 1920 0 1280 768 }
+              }
+          , W.visible =
+              [ W.Screen
+                { W.workspace =
+                    W.Workspace
+                    { W.tag = "A"
+                    , W.layout = Layout NullLayout
+                    , W.stack = Just $ W.Stack { W.focus = 3, W.up = [], W.down = [1, 2, 4] }
+                    }
+                , W.screen = 1
+                , W.screenDetail = SD { screenRect = Rectangle 0 0 1920 1280 }
+                }
+              ]
+          , W.hidden = []
+          , W.floating = M.empty
+          }
+
+    runIdentity (goPure R (M.empty, initWindowSet, S.fromList [1..6], windowRect))
+      `shouldBe` (M.fromList [("B", Point 1920 600)], expectedWindowSet)
+
+  it "floating window overlapping fully in the orthogonal direction" $ do
+    -- ┌─────┬──────────────────┐
+    -- │     │      ┌───────┐   │
+    -- │     │    2 │       │   │
+    -- │     ├──────┤-------├───┤
+    -- │  1  │    3 │       │ 3 │
+    -- │   ◄─┼──  ◄─┼── 5 ◄─┼── │
+    -- │     ├──────┤-------├───┤
+    -- │     │    4 │       │   │
+    -- │     │      └───────┘   │
+    -- └─────┴──────────────────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 960 0 960 400)
+          , (3, Rectangle 960 400 960 400)
+          , (4, Rectangle 960 800 960 480)
+          , (5, Rectangle 1360 200 200 800)
+          ]
+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..5], windowRect)
+    let (st2, ws2) = runNav L (mkstate 1800 600) (mkws 3 [] [1, 2, 4, 5])
+    (st2, ws2) `shouldBe` (mkstate 1559 600, mkws 5 [4, 2, 1, 3] [])
+    let (st3, ws3) = runNav L st2 ws2
+    (st3, ws3) `shouldBe` (mkstate 1359 600, mkws 3 [] [1, 2, 4, 5])
+    let (st4, ws4) = runNav L st3 ws3
+    (st4, ws4) `shouldBe` (mkstate 959 600, mkws 1 [3] [2, 4, 5])
+
+  it "navigation to free-floating windows on the same screen" $ do
+    -- ┌──────┐
+    -- │      │  ┌──────┐
+    -- │      │  │      │
+    -- │    ──┼──┼─►  2 │
+    -- │      │  │      │
+    -- │   1  │  └──────┘
+    -- │      │
+    -- │      │
+    -- └──────┘
+    let windowRect w =
+          Identity $ M.lookup w $ M.fromList
+          [ (1, Rectangle 0 0 960 1280)
+          , (2, Rectangle 1200 400 400 400)
+          ]
+    runIdentity (goPure R (M.empty, mkws 1 [] [2], S.fromList [1, 2], windowRect))
+      `shouldBe` (mkstate 1200 640, mkws 2 [1] [])
+
+  it "switch between windows in Full layout" $ do
+    let windowRect w = Identity $ M.lookup w $ M.fromList [(1, Rectangle 0 0 1920 1280)]
+    runIdentity (goPure D (M.empty, mkws 1 [] [2, 3], S.fromList [1], windowRect))
+      `shouldBe` (M.empty, mkws 2 [1] [3])
+
+data NullLayout a = NullLayout deriving (Show, Read, Eq)
+instance LayoutClass NullLayout a
+
+-- to make WindowSets comparable
+instance Eq (Layout w) where
+  (==) a b = show a == show b
+  (/=) a b = show a /= show b
+
+-- make a state with a position for a single workspace
+mkstate :: Position -> Position -> WNState
+mkstate px py = M.fromList [("A", Point px py)]
+
+-- make a single-workspace WindowSet
+mkws :: Window -> [Window] -> [Window] -> WindowSet
+mkws focusedWindow upWindows downWindows = W.StackSet
+  { W.current = W.Screen
+    { W.workspace = W.Workspace
+      { W.tag = "A"
+      , W.layout = Layout NullLayout
+      , W.stack = Just $ W.Stack { W.focus = focusedWindow, W.up = upWindows, W.down = downWindows }
+      }
+    , W.screen = 1
+    , W.screenDetail = SD { screenRect = Rectangle 0 0 1920 1280 }
+    }
+  , W.visible = []
+  , W.hidden = []
+  , W.floating = M.empty
+  }

xmonad-contrib.cabal

@@ -429,6 +429,7 @@ test-suite tests
                   RotateSome
                   Selective
                   SwapWorkspaces
+                  WindowNavigation
                   Utils
                   XMonad.Actions.CopyWindow
                   XMonad.Actions.CycleRecentWS
@@ -443,6 +444,7 @@ test-suite tests
                   XMonad.Actions.TagWindows
                   XMonad.Actions.WindowBringer
                   XMonad.Actions.WindowGo
+                  XMonad.Actions.WindowNavigation
                   XMonad.Hooks.ManageDocks
                   XMonad.Hooks.ManageHelpers
                   XMonad.Hooks.UrgencyHook