cabal: Update DXMONAD_CONTRIB_VERSION_PATCH

This was forgotten when the module was renamed.

.github/workflows/haskell-ci-hackage.patch

@@ -38,13 +38,13 @@ set in GitHub repository secrets.
    linux:
      name: Haskell-CI - Linux - ${{ matrix.compiler }}
 @@ -33,6 +40,7 @@
-             compilerVersion: 9.8.1
+             compilerVersion: 9.8.2
              setup-method: ghcup
              allow-failure: false
 +            upload: true
-           - compiler: ghc-9.6.4
+           - compiler: ghc-9.6.6
              compilerKind: ghc
-             compilerVersion: 9.6.4
+             compilerVersion: 9.6.6
 @@ -257,6 +265,10 @@
        - name: haddock
          run: |
@@ -56,19 +56,24 @@ set in GitHub repository secrets.
        - name: unconstrained build
          run: |
            rm -f cabal.project.local
-@@ -267,3 +279,75 @@
+@@ -267,3 +279,80 @@
          with:
            key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
            path: ~/.cabal/store
-+      - name: upload artifacts (sdist)
++      # must be separate artifacts because GitHub Actions are still broken:
++      # https://github.com/actions/upload-artifact/issues/441
++      # https://github.com/actions/upload-artifact/issues/457
++      - name: upload artifact (sdist)
 +        if: matrix.upload
-+        uses: actions/upload-artifact@v3
++        uses: actions/upload-artifact@v4
 +        with:
++          name: sdist
 +          path: ${{ github.workspace }}/sdist/*.tar.gz
-+      - name: upload artifacts (haddock)
++      - name: upload artifact (haddock)
 +        if: matrix.upload
-+        uses: actions/upload-artifact@v3
++        uses: actions/upload-artifact@v4
 +        with:
++          name: haddock
 +          path: ${{ github.workspace }}/haddock/*-docs.tar.gz
 +      - name: hackage upload (candidate)
 +        if: matrix.upload && github.event_name == 'workflow_dispatch' && github.event.inputs.version != ''

.github/workflows/haskell-ci.yml

@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.17.20240109
+# version: 0.19.20240708
 #
-# REGENDATA ("0.17.20240109",["github","cabal.project"])
+# REGENDATA ("0.19.20240708",["github","cabal.project"])
 #
 name: Haskell-CI
 on:
@@ -30,20 +30,25 @@ jobs:
     timeout-minutes:
       60
     container:
-      image: buildpack-deps:bionic
+      image: buildpack-deps:jammy
     continue-on-error: ${{ matrix.allow-failure }}
     strategy:
       matrix:
         include:
-          - compiler: ghc-9.8.1
+          - compiler: ghc-9.10.1
             compilerKind: ghc
-            compilerVersion: 9.8.1
+            compilerVersion: 9.10.1
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.8.2
+            compilerKind: ghc
+            compilerVersion: 9.8.2
             setup-method: ghcup
             allow-failure: false
             upload: true
-          - compiler: ghc-9.6.4
+          - compiler: ghc-9.6.6
             compilerKind: ghc
-            compilerVersion: 9.6.4
+            compilerVersion: 9.6.6
             setup-method: ghcup
             allow-failure: false
           - compiler: ghc-9.4.8
@@ -69,12 +74,12 @@ jobs:
           - compiler: ghc-8.8.4
             compilerKind: ghc
             compilerVersion: 8.8.4
-            setup-method: hvr-ppa
+            setup-method: ghcup
             allow-failure: false
           - compiler: ghc-8.6.5
             compilerKind: ghc
             compilerVersion: 8.6.5
-            setup-method: hvr-ppa
+            setup-method: ghcup
             allow-failure: false
       fail-fast: false
     steps:
@@ -82,23 +87,13 @@ jobs:
         run: |
           apt-get update
           apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
-          if [ "${{ matrix.setup-method }}" = ghcup ]; then
           mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
+          curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup"
           chmod a+x "$HOME/.ghcup/bin/ghcup"
           "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+          "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
           apt-get update
           apt-get install -y libx11-dev libxext-dev libxft-dev libxinerama-dev libxrandr-dev libxss-dev
-          else
-            apt-add-repository -y 'ppa:hvr/ghc'
-            apt-get update
-            apt-get install -y "$HCNAME" libx11-dev libxext-dev libxft-dev libxinerama-dev libxrandr-dev libxss-dev
-            mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
-            chmod a+x "$HOME/.ghcup/bin/ghcup"
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
-          fi
         env:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
@@ -110,22 +105,13 @@ jobs:
           echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
           echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
           HCDIR=/opt/$HCKIND/$HCVER
-          if [ "${{ matrix.setup-method }}" = ghcup ]; then
           HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
           HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
           HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
           echo "HC=$HC" >> "$GITHUB_ENV"
           echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
           echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
-          else
-            HC=$HCDIR/bin/$HCKIND
-            echo "HC=$HC" >> "$GITHUB_ENV"
-            echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
-            echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
-          fi
-
           HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
           echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
@@ -182,7 +168,7 @@ jobs:
           chmod a+x $HOME/.cabal/bin/cabal-plan
           cabal-plan --version
       - name: checkout
-        uses: actions/checkout@v3
+        uses: actions/checkout@v4
         with:
           path: source
       - name: initial cabal.project for sdist
@@ -220,7 +206,7 @@ jobs:
             flags:       +pedantic
             ghc-options: -j
           EOF
-          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(xmonad-contrib)$/; }' >> cabal.project.local
+          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(xmonad-contrib)$/; }' >> cabal.project.local
           cat cabal.project
           cat cabal.project.local
       - name: dump install plan
@@ -228,7 +214,7 @@ jobs:
           $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
           cabal-plan
       - name: restore cache
-        uses: actions/cache/restore@v3
+        uses: actions/cache/restore@v4
         with:
           key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
           path: ~/.cabal/store
@@ -262,20 +248,25 @@ jobs:
           rm -f cabal.project.local
           $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
       - name: save cache
-        uses: actions/cache/save@v3
+        uses: actions/cache/save@v4
         if: always()
         with:
           key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
           path: ~/.cabal/store
-      - name: upload artifacts (sdist)
+      # must be separate artifacts because GitHub Actions are still broken:
+      # https://github.com/actions/upload-artifact/issues/441
+      # https://github.com/actions/upload-artifact/issues/457
+      - name: upload artifact (sdist)
         if: matrix.upload
-        uses: actions/upload-artifact@v3
+        uses: actions/upload-artifact@v4
         with:
+          name: sdist
           path: ${{ github.workspace }}/sdist/*.tar.gz
-      - name: upload artifacts (haddock)
+      - name: upload artifact (haddock)
         if: matrix.upload
-        uses: actions/upload-artifact@v3
+        uses: actions/upload-artifact@v4
         with:
+          name: haddock
           path: ${{ github.workspace }}/haddock/*-docs.tar.gz
       - name: hackage upload (candidate)
         if: matrix.upload && github.event_name == 'workflow_dispatch' && github.event.inputs.version != ''

.github/workflows/nix.yml

@@ -12,7 +12,7 @@ jobs:
       contents: read
     steps:
       - name: Install Nix
-        uses: cachix/install-nix-action@v25
+        uses: cachix/install-nix-action@V27
         with:
           install_url: https://nixos-nix-install-tests.cachix.org/serve/i6laym9jw3wg9mw6ncyrk6gjx4l34vvx/install
           install_options: '--tarball-url-prefix https://nixos-nix-install-tests.cachix.org/serve'
@@ -25,4 +25,6 @@ jobs:
         # "nix build" builds with full optimization and includes a profiling
         # build, so just the build of xmonad-contrib itself takes 3 minutes.
         # As a workaround, we invoke cabal manually here.
-        run: nix develop -c cabal v2-build -O0 -j
+        run: |
+          nix develop -c cabal v2-update -O0 -j
+          nix develop -c cabal v2-build -O0 -j

.github/workflows/packdeps.yml

@@ -42,10 +42,9 @@ jobs:
             *.cabal
 
   workflow-keepalive:
+    if: github.event_name == 'schedule'
     runs-on: ubuntu-latest
+    permissions:
+      actions: write
     steps:
-      - name: Re-enable workflow
+      - uses: liskin/gh-workflow-keepalive@v1
-        env:
-          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-        run: |
-          gh api -X PUT repos/${{ github.repository }}/actions/workflows/packdeps.yml/enable

.github/workflows/stack.yml

@@ -25,8 +25,10 @@ jobs:
           - resolver: lts-20  # GHC 9.2
             yaml: stack-master.yaml
           - resolver: lts-21  # GHC 9.4
+            yaml: stack-master.yaml
+          - resolver: lts-22  # GHC 9.6
             yaml: stack.yaml
-          - resolver: lts-21  # GHC 9.4
+          - resolver: lts-22  # GHC 9.6
             yaml: stack-master.yaml
 
     steps:

.mailmap

@@ -103,6 +103,7 @@ hexago.nl <xmonad-contrib@hexago.nl>
 lithis <xmonad@selg.hethrael.org>
 lithis <xmonad@selg.hethrael.org> <xmonad@s001.hethrael.com>
 sam-barr <mail@samf.bar> <samfbarr@outlook.com>
-slotThe <soliditsallgood@mailbox.org> <50166980+slotThe@users.noreply.github.com>
+Tony Zorman <soliditsallgood@mailbox.org> <50166980+slotThe@users.noreply.github.com>
-slotThe <soliditsallgood@mailbox.org> <soliditsallgood@tuta.io>
+Tony Zorman <soliditsallgood@mailbox.org> <soliditsallgood@tuta.io>
+Tony Zorman <soliditsallgood@mailbox.org>
 spoonm <spoonm@spoonm.org>

CHANGES.md

@@ -1,5 +1,106 @@
 # Change Log / Release Notes
 
+## _unreleased_
+
+## 0.18.1 (August 20, 2024)
+
+### Breaking Changes
+
+  * `XMonad.Hooks.StatusBars`
+
+    - Move status bar functions from the `IO` to the `X` monad to
+      allow them to look up information from `X`, like the screen
+      width. Existing configurations may need to use `io` from
+      `XMonad.Core` or `liftIO` from `Control.Monad.IO.Class` in
+      order to lift any existing `IO StatusBarConfig` values into
+      `X StatusBarConfig` values.
+
+  * `XMonad.Prompt`
+
+    - Added an additional `XPConfig` argument to `historyCompletion` and
+      `historyCompletionP`. Calls along the lines of `historyCompletionP
+      myFunc` should be changed to `historyCompletionP myConf myFunc`.
+      If not `myConf` is lying around, `def` can be used instead.
+
+  * `XMonad.Actions.GridSelect`
+
+    - Added the `gs_cancelOnEmptyClick` field to `GSConfig`, which makes
+      mouse clicks into "empty space" cancel the current grid-select.
+      Users explicitly defining their own `GSConfig` record will have to
+      add this to their definitions. Additionally, the field defaults to
+      `True`—to retain the old behaviour, set it to `False`.
+
+### New Modules
+
+  * `XMonad.Actions.Profiles`
+
+    - Group workspaces by similarity. Useful when one has lots
+      of workspaces and uses only a couple per unit of work.
+
+  * `XMonad.Hooks.FloatConfigureReq`
+
+    - Customize handling of floating windows' move/resize/restack requests
+      (ConfigureRequest). Useful as a workaround for some misbehaving client
+      applications (Steam, rxvt-unicode, anything that tries to restore
+      absolute position of floats).
+
+  * `XMonad.Layout.Columns`
+
+    - Organize windows in columns. This layout allows to move/resize windows in
+      every directions.
+
+  * `XMonad.Prompt.WindowBringer`
+
+    - Added `copyMenu`, a convenient way to copy a window to the current workspace.
+
+### Bug Fixes and Minor Changes
+
+  * Fix build-with-cabal.sh when XDG_CONFIG_HOME is defined.
+
+  * `XMonad.Util.EZConfig`
+
+    - Fixed `checkKeymap` warning that all keybindings are duplicates.
+
+  * `XMonad.Hooks.ManageHelpers`
+
+    - Added `isNotification` predicate to check for windows with
+      `_NET_WM_WINDOW_TYPE` property of `_NET_WM_WINDOW_TYPE_NOTIFICATION`.
+
+  * `XMonad.Prompt.OrgMode`
+
+    - Added `HH:MM-HH:MM` and `HH:MM+HH` syntax to specify time spans.
+
+  * `XMonad.Prompt`
+
+    - The history file is not extraneously read and written anymore if
+      the `historySize` is set to 0.
+
+  * `XMonad.Hooks.EwmhDesktops`
+
+    - Requests for unmanaged windows no longer cause a refresh. This avoids
+      flicker and also fixes disappearing menus in the Steam client and
+      possibly a few other client applications.
+
+      (See also `XMonad.Hooks.FloatConfigureReq` and/or `XMonad.Util.Hacks`
+      for additional Steam client workarounds.)
+
+  * `XMonad.Actions.Submap`
+
+    - Added `visualSubmapSorted` to enable sorting of the keymap
+      descriptions.
+
+  * `XMonad.Hooks.ScreenCorners`
+
+    - 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)
 
 ### Breaking Changes
@@ -307,8 +408,6 @@
     - Added `zipperFocusedAtFirstOf` to differentiate two lists into a
       zipper.
 
-### Other changes
-
 ## 0.17.1 (September 3, 2022)
 
 ### Breaking Changes

XMonad/Actions/GridSelect.hs

@@ -203,10 +203,13 @@ data GSConfig a = GSConfig {
       gs_colorizer :: a -> Bool -> X (String, String),
       gs_font :: String,
       gs_navigate :: TwoD a (Maybe a),
+      -- ^ Customize key bindings for a GridSelect
       gs_rearranger :: Rearranger a,
       gs_originFractX :: Double,
       gs_originFractY :: Double,
-      gs_bordercolor :: String
+      gs_bordercolor :: String,
+      gs_cancelOnEmptyClick :: Bool
+      -- ^ When True, click on empty space will cancel GridSelect
 }
 
 -- | That is 'fromClassName' if you are selecting a 'Window', or
@@ -386,13 +389,20 @@ updateElementsWithColorizer colorizer elementmap = do
 stdHandle :: Event -> TwoD a (Maybe a) -> TwoD a (Maybe a)
 stdHandle ButtonEvent{ ev_event_type = t, ev_x = x, ev_y = y } contEventloop
     | t == buttonRelease = do
-        s@TwoDState { td_paneX = px, td_paneY = py,
+        s@TwoDState{ td_paneX = px
-                         td_gsconfig = (GSConfig ch cw _ _ _ _ _ _ _ _) } <- get
+                   , td_paneY = py
+                   , td_gsconfig = GSConfig{ gs_cellheight = ch
+                                           , gs_cellwidth = cw
+                                           , gs_cancelOnEmptyClick = cancelOnEmptyClick
+                                           }
+                   } <- get
         let gridX = (fi x - (px - cw) `div` 2) `div` cw
             gridY = (fi y - (py - ch) `div` 2) `div` ch
         case lookup (gridX,gridY) (td_elementmap s) of
              Just (_,el) -> return (Just el)
-             Nothing -> contEventloop
+             Nothing     -> if cancelOnEmptyClick
+                            then return Nothing
+                            else contEventloop
     | otherwise = contEventloop
 
 stdHandle ExposeEvent{} contEventloop = updateAllElements >> contEventloop
@@ -648,7 +658,7 @@ gridselect gsconfig elements =
     liftIO $ mapWindow dpy win
     liftIO $ selectInput dpy win (exposureMask .|. keyPressMask .|. buttonReleaseMask)
     status <- io $ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime
-    io $ grabPointer dpy win True buttonReleaseMask grabModeAsync grabModeAsync none none currentTime
+    void $ io $ grabPointer dpy win True buttonReleaseMask grabModeAsync grabModeAsync none none currentTime
     font <- initXMF (gs_font gsconfig)
     let screenWidth = toInteger $ rect_width scr
         screenHeight = toInteger $ rect_height scr
@@ -706,7 +716,7 @@ decorateName' w = do
 
 -- | Builds a default gs config from a colorizer function.
 buildDefaultGSConfig :: (a -> Bool -> X (String,String)) -> GSConfig a
-buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultNavigation noRearranger (1/2) (1/2) "white"
+buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultNavigation noRearranger (1/2) (1/2) "white" True
 
 -- | Brings selected window to the current workspace.
 bringSelected :: GSConfig Window -> X ()

XMonad/Actions/Profiles.hs

@@ -0,0 +1,545 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DerivingVia   #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Actions.Profiles
+-- Description :  Group your workspaces by similarity.
+-- Copyright   :  (c) Mislav Zanic
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  Mislav Zanic <mislavzanic3@gmail.com>
+-- Stability   :  experimental
+-- Portability :  unportable
+--
+--------------------------------------------------------------------------------
+
+module XMonad.Actions.Profiles
+  ( -- * Overview
+    -- $overview
+
+    -- * Usage
+    -- $usage
+
+    -- * Types
+    ProfileId
+  , Profile(..)
+  , ProfileConfig(..)
+
+  -- * Hooks
+  , addProfiles
+  , addProfilesWithHistory
+
+  -- * Switching profiles
+  , switchToProfile
+
+  -- * Workspace navigation and keybindings
+  , wsFilter
+  , bindOn
+
+  -- * Loggers and pretty printers
+  , excludeWSPP
+  , profileLogger
+
+  -- * Prompts
+  , switchProfilePrompt
+  , addWSToProfilePrompt
+  , removeWSFromProfilePrompt
+  , switchProfileWSPrompt
+  , shiftProfileWSPrompt
+
+  -- * Utilities
+  , currentProfile
+  , profileIds
+  , previousProfile
+  , profileHistory
+  , allProfileWindows
+  , profileWorkspaces
+  )where
+
+--------------------------------------------------------------------------------
+import Data.Map.Strict (Map)
+import Data.List
+import qualified Data.Map.Strict as Map
+
+import Control.DeepSeq
+
+import XMonad
+import XMonad.Prelude
+import qualified XMonad.StackSet as W
+
+import XMonad.Actions.CycleWS
+
+import qualified XMonad.Util.ExtensibleState as XS
+import XMonad.Util.Loggers (Logger)
+import XMonad.Prompt.Window (XWindowMap)
+import XMonad.Actions.WindowBringer (WindowBringerConfig(..))
+import XMonad.Actions.OnScreen (greedyViewOnScreen)
+import XMonad.Hooks.Rescreen (addAfterRescreenHook)
+import XMonad.Hooks.DynamicLog (PP(ppRename))
+import XMonad.Prompt 
+
+--------------------------------------------------------------------------------
+-- $overview
+-- This module allows you to group your workspaces into 'Profile's based on certain similarities.
+-- The idea is to expand upon the philosophy set by "XMonad.Actions.TopicSpace"
+-- which states that you can look at a topic/workspace as a
+-- single unit of work instead of multiple related units of work.
+-- This comes in handy if you have lots of workspaces with windows open and need only to
+-- work with a few of them at a time. With 'Profile's, you can focus on those few workspaces that
+-- require your attention by not displaying, or allowing you to switch to the rest of the workspaces.
+-- The best example is having a profile for development and a profile for leisure activities.
+
+--------------------------------------------------------------------------------
+-- $usage
+-- To use @Profiles@ you need to add it to your XMonad configuration
+-- and configure your profiles.
+--  
+-- First you'll need to handle the imports.
+--  
+-- > import XMonad.Actions.Profiles 
+-- > import XMonad.Util.EZConfig -- for keybindings
+-- > import qualified XMonad.StackSet as W
+-- > import qualified XMonad.Actions.DynamicWorkspaceOrder as DO -- for workspace navigation
+--
+-- Next you'll need to define your profiles.
+--
+-- > myStartingProfile :: ProfileId
+-- > myStartingProfile = "Work"
+-- >
+-- > myProfiles :: [Profile]
+-- > myProfiles =
+-- >  [ Profile { profileId = "Home"
+-- >            , profileWS = [ "www"
+-- >                          , "rss"
+-- >                          , "vid"
+-- >                          , "vms"
+-- >                          , "writing"
+-- >                          , "notes"
+-- >                          ]
+-- >            }
+-- >  , Profile { profileId = "Work"
+-- >            , profileWS = [ "www"
+-- >                          , "slack"
+-- >                          , "dev"
+-- >                          , "k8s"
+-- >                          , "notes"
+-- >                          ]
+-- >            }
+-- >  ]
+-- 
+-- So, while using @Home@ 'Profile', you'll only be able to see, navigate to and 
+-- do actions with @["www", "rss", "vid", "vms", "writing", "notes"]@ workspaces.
+--
+-- You may also need to define some keybindings. Since @M-1@ .. @M-9@ are
+-- sensible keybindings for switching workspaces, you'll need to use
+-- 'bindOn' to have different keybindings per profile.
+-- Here, we'll use "XMonad.Util.EZConfig" syntax:
+-- 
+-- > myKeys :: [(String, X())]
+-- > myKeys = 
+-- >   [ ("M-p",  switchProfilePrompt   xpConfig)
+-- >   , ("M-g",  switchProfileWSPrompt xpConfig)
+-- >   , ("M1-j", DO.moveTo Next wsFilter)
+-- >   , ("M1-k", DO.moveTo Prev wsFilter)
+-- >   ]
+-- >   <>
+-- >   [ ("M-" ++ m ++ k, bindOn $ map (\x -> (fst x, f $ snd x)) i)
+-- >   | (i, k) <- map (\(x:xs) -> (map fst (x:xs), snd x)) $ sortGroupBy snd tupleList
+-- >   , (f, m) <- [(mby $ windows . W.greedyView, ""), (mby $ windows . W.shift, "S-")]
+-- >   ]
+-- >   where
+-- >     mby f wid = if wid == "" then return () else f wid
+-- >     sortGroupBy f = groupBy (\ x y -> f x == f y) . sortBy (\x y -> compare (f x) (f y))
+-- >     tupleList = concatMap (\p -> zip (map (\wid -> (profileId p, wid)) (profileWS p <> repeat "")) (map show [1..9 :: Int])) myProfiles
+-- 
+-- After that, you'll need to hook @Profiles@ into your XMonad config:
+-- 
+-- > main = xmonad $ addProfiles def { profiles        = myProfiles
+-- >                                 , startingProfile = myStartingProfile
+-- >                                 }
+-- >               $ def `additionalKeysP` myKeys
+-- 
+
+--------------------------------------------------------------------------------
+type ProfileId  = String
+type ProfileMap = Map ProfileId Profile
+
+--------------------------------------------------------------------------------
+-- | Profile representation.
+data Profile = Profile
+  { profileId :: !ProfileId     -- ^ Profile name.
+  , profileWS :: ![WorkspaceId] -- ^ A list of workspaces contained within a profile.
+  }
+
+--------------------------------------------------------------------------------
+-- | Internal profile state.
+data ProfileState = ProfileState
+  { profilesMap :: !ProfileMap
+  , current     :: !(Maybe Profile)
+  , previous    :: !(Maybe ProfileId)
+  }
+
+--------------------------------------------------------------------------------
+-- | User config for profiles.
+data ProfileConfig = ProfileConfig
+  { workspaceExcludes :: ![WorkspaceId] -- ^ A list of workspaces to exclude from the @profileHistoryHook@.
+  , profiles          :: ![Profile]     -- ^ A list of user-defined profiles.
+  , startingProfile   :: !ProfileId     -- ^ Profile shown on startup.
+  }
+
+--------------------------------------------------------------------------------
+instance Default ProfileConfig where
+  def            = ProfileConfig { workspaceExcludes = []
+                                 , profiles          = []
+                                 , startingProfile   = ""
+                                 }
+
+--------------------------------------------------------------------------------
+instance ExtensionClass ProfileState where
+  initialValue = ProfileState Map.empty Nothing Nothing
+
+--------------------------------------------------------------------------------
+-- Internal type for history tracking.
+-- Main problem with @XMonad.Hooks.HistoryHook@ is that it isn't profile aware.
+-- Because of that, when switching to a previous workspace, you might switch to
+-- a workspace
+newtype ProfileHistory = ProfileHistory
+  { history :: Map ProfileId [(ScreenId, WorkspaceId)]
+  }
+  deriving (Read, Show)
+  deriving NFData via Map ProfileId [(Int, WorkspaceId)]
+
+--------------------------------------------------------------------------------
+instance ExtensionClass ProfileHistory where
+  extensionType = PersistentExtension
+  initialValue = ProfileHistory Map.empty
+
+--------------------------------------------------------------------------------
+newtype ProfilePrompt = ProfilePrompt String
+
+--------------------------------------------------------------------------------
+instance XPrompt ProfilePrompt where
+  showXPrompt (ProfilePrompt x) = x
+
+--------------------------------------------------------------------------------
+defaultProfile :: Profile
+defaultProfile = defaultProfile
+
+--------------------------------------------------------------------------------
+-- | Returns current profile.
+currentProfile :: X ProfileId
+currentProfile = profileId . fromMaybe defaultProfile . current <$> XS.get
+
+--------------------------------------------------------------------------------
+-- | Returns previous profile.
+previousProfile :: X (Maybe ProfileId)
+previousProfile = XS.gets previous
+
+--------------------------------------------------------------------------------
+-- | Returns the history of viewed workspaces per profile.
+profileHistory :: X (Map ProfileId [(ScreenId, WorkspaceId)])
+profileHistory = XS.gets history
+
+--------------------------------------------------------------------------------
+profileMap :: X ProfileMap
+profileMap = XS.gets profilesMap
+
+--------------------------------------------------------------------------------
+-- | Returns ids of all profiles.
+profileIds :: X [ProfileId]
+profileIds = Map.keys <$> XS.gets profilesMap
+
+--------------------------------------------------------------------------------
+currentProfileWorkspaces :: X [WorkspaceId]
+currentProfileWorkspaces = XS.gets current <&> profileWS . fromMaybe defaultProfile
+
+--------------------------------------------------------------------------------
+-- | Hook profiles into XMonad. This function adds a startup hook that
+-- sets up ProfileState. Also adds an afterRescreenHook for viewing correct
+-- workspaces when adding new screens.
+addProfiles :: ProfileConfig -> XConfig a -> XConfig a
+addProfiles profConf conf = addAfterRescreenHook hook $ conf
+  { startupHook = profileStartupHook' <> startupHook conf
+  }
+ where
+   profileStartupHook' :: X()
+   profileStartupHook' = profilesStartupHook (profiles profConf) (startingProfile profConf)
+   hook = currentProfile >>= switchWSOnScreens
+
+--------------------------------------------------------------------------------
+-- | Hooks profiles into XMonad and enables Profile history logging.
+addProfilesWithHistory :: ProfileConfig -> XConfig a -> XConfig a
+addProfilesWithHistory profConf conf = conf'
+  { logHook = profileHistoryHookExclude (workspaceExcludes profConf) <> logHook conf
+  }
+  where
+   conf' = addProfiles profConf conf
+
+--------------------------------------------------------------------------------
+profileHistoryHookExclude :: [WorkspaceId] -> X()
+profileHistoryHookExclude ews = do
+  cur <- gets $ W.current . windowset
+  vis <- gets $ W.visible . windowset
+  pws <- currentProfileWorkspaces
+  p <- currentProfile
+
+  updateHist p $ workspaceScreenPairs $ filterWS pws $ cur:vis
+  where
+    workspaceScreenPairs wins = zip (W.screen <$> wins) (W.tag . W.workspace <$> wins)
+    filterWS pws = filter ((\wid -> (wid `elem` pws) && (wid `notElem` ews)) . W.tag . W.workspace)
+
+--------------------------------------------------------------------------------
+updateHist :: ProfileId -> [(ScreenId, WorkspaceId)] -> X()
+updateHist pid xs = profileWorkspaces pid >>= XS.modify' . update
+  where
+    update pws hs = force $ hs { history = doUpdate pws $ history hs }
+
+    doUpdate pws hist = foldl (\acc (sid, wid) -> Map.alter (f pws sid wid) pid acc) hist xs
+
+    f pws sid wid val = case val of
+      Nothing -> pure [(sid, wid)]
+      Just hs -> pure $ let new = (sid, wid) in new:filterWS pws new hs
+
+    filterWS :: [WorkspaceId] -> (ScreenId, WorkspaceId) -> [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]
+    filterWS pws new = filter (\x -> snd x `elem` pws && x /= new)
+
+--------------------------------------------------------------------------------
+-- | Adds profiles to ProfileState and sets current profile using .
+
+profilesStartupHook :: [Profile] -> ProfileId -> X ()
+profilesStartupHook ps pid = XS.modify go >> switchWSOnScreens pid
+  where
+    go :: ProfileState -> ProfileState
+    go s = s {profilesMap = update $ profilesMap s, current = setCurrentProfile $ Map.fromList $ map entry ps}
+
+    update :: ProfileMap -> ProfileMap
+    update = Map.union (Map.fromList $ map entry ps)
+
+    entry :: Profile -> (ProfileId, Profile)
+    entry p = (profileId p, p)
+
+    setCurrentProfile :: ProfileMap -> Maybe Profile
+    setCurrentProfile s = case Map.lookup pid s of
+      Nothing -> Just $ Profile pid []
+      Just pn -> Just pn
+
+--------------------------------------------------------------------------------
+setPrevious :: ProfileId -> X()
+setPrevious name = XS.modify update
+  where
+    update ps = ps { previous = doUpdate ps }
+    doUpdate ps = case Map.lookup name $ profilesMap ps of
+      Nothing -> previous ps
+      Just p -> Just $ profileId p
+
+--------------------------------------------------------------------------------
+setProfile :: ProfileId -> X ()
+setProfile p = currentProfile >>= setPrevious >> setProfile' p
+
+--------------------------------------------------------------------------------
+setProfile' :: ProfileId -> X ()
+setProfile' name = XS.modify update
+  where
+    update ps = ps { current = doUpdate ps }
+    doUpdate ps = case Map.lookup name $ profilesMap ps of
+      Nothing -> current ps
+      Just p -> Just p
+
+--------------------------------------------------------------------------------
+-- | Switch to a profile.
+switchToProfile :: ProfileId -> X()
+switchToProfile pid = setProfile pid >> switchWSOnScreens pid
+
+--------------------------------------------------------------------------------
+-- | Returns the workspace ids associated with a profile id.
+profileWorkspaces :: ProfileId -> X [WorkspaceId]
+profileWorkspaces pid = profileMap >>= findPWs
+  where
+    findPWs pm = return . profileWS . fromMaybe defaultProfile $ Map.lookup pid pm
+
+--------------------------------------------------------------------------------
+-- | Prompt for adding a workspace id to a profile.
+addWSToProfilePrompt :: XPConfig -> X()
+addWSToProfilePrompt c = do
+  ps <- profileIds
+  mkXPrompt (ProfilePrompt "Add ws to profile:") c (mkComplFunFromList' c ps) f
+  where
+   f :: String -> X()
+   f p = do
+     vis <- gets $ fmap (W.tag . W.workspace) . W.visible . windowset
+     cur <- gets $ W.tag . W.workspace . W.current . windowset
+     hid <- gets $ fmap W.tag . W.hidden . windowset
+     let
+       arr = cur:(vis <> hid)
+       in mkXPrompt (ProfilePrompt "Ws to add to profile:") c (mkComplFunFromList' c arr) (`addWSToProfile` p)
+
+--------------------------------------------------------------------------------
+-- | Prompt for switching profiles.
+switchProfilePrompt :: XPConfig -> X()
+switchProfilePrompt c = do
+  ps <- profileIds
+  mkXPrompt (ProfilePrompt "Profile: ") c (mkComplFunFromList' c ps) switchToProfile
+     
+--------------------------------------------------------------------------------
+-- | Prompt for switching workspaces.
+switchProfileWSPrompt :: XPConfig -> X ()
+switchProfileWSPrompt c = mkPrompt =<< currentProfileWorkspaces
+  where
+    mkPrompt pws = mkXPrompt (ProfilePrompt "Switch to workspace:") c (mkComplFunFromList' c pws) mbygoto 
+    mbygoto wid = do
+      pw <- profileWorkspaces =<< currentProfile
+      unless (wid `notElem` pw) (windows . W.greedyView $ wid)
+
+--------------------------------------------------------------------------------
+-- | Prompt for shifting windows to a different workspace.
+shiftProfileWSPrompt :: XPConfig -> X ()
+shiftProfileWSPrompt c = mkPrompt =<< currentProfileWorkspaces
+  where
+    mkPrompt pws = mkXPrompt (ProfilePrompt "Send window to workspace:") c (mkComplFunFromList' c pws) mbyshift
+    mbyshift wid = do
+      pw <- profileWorkspaces =<< currentProfile
+      unless (wid `notElem` pw) (windows . W.shift $ wid)
+
+--------------------------------------------------------------------------------
+addWSToProfile :: WorkspaceId -> ProfileId -> X()
+addWSToProfile wid pid = XS.modify go
+  where
+   go :: ProfileState -> ProfileState
+   go ps = ps {profilesMap = update $ profilesMap ps, current = update' $ fromMaybe defaultProfile $ current ps}
+
+   update :: ProfileMap -> ProfileMap
+   update mp = case Map.lookup pid mp of
+     Nothing -> mp
+     Just p  -> if wid `elem` profileWS p then mp else Map.adjust f pid mp
+
+   f :: Profile -> Profile
+   f p = Profile pid (wid : profileWS p)
+
+   update' :: Profile -> Maybe Profile
+   update' cp = if profileId cp == pid && wid `notElem` profileWS cp then Just (Profile pid $ wid:profileWS cp) else Just cp
+
+--------------------------------------------------------------------------------
+-- | Prompt for removing a workspace from a profile.
+removeWSFromProfilePrompt :: XPConfig -> X()
+removeWSFromProfilePrompt c = do
+  ps <- profileIds
+  mkXPrompt (ProfilePrompt "Remove ws from profile:") c (mkComplFunFromList' c ps) f
+  where
+   f :: String -> X()
+   f p = do
+     arr <- profileWorkspaces p
+     mkXPrompt (ProfilePrompt "Ws to remove from profile:") c (mkComplFunFromList' c arr) $
+       \ws -> do
+         cp <- currentProfile
+         ws `removeWSFromProfile` p 
+         when (cp == p) $ currentProfile >>= switchWSOnScreens
+
+--------------------------------------------------------------------------------
+removeWSFromProfile :: WorkspaceId -> ProfileId -> X()
+removeWSFromProfile wid pid = XS.modify go
+  where
+   go :: ProfileState -> ProfileState
+   go ps = ps {profilesMap = update $ profilesMap ps, current = update' $ fromMaybe defaultProfile $ current ps}
+
+   update :: ProfileMap -> ProfileMap
+   update mp = case Map.lookup pid mp of
+     Nothing -> mp
+     Just p  -> if wid `elem` profileWS p then Map.adjust f pid mp else mp
+
+   f :: Profile -> Profile
+   f p = Profile pid (delete wid $ profileWS p)
+
+   update' :: Profile -> Maybe Profile
+   update' cp = if profileId cp == pid && wid `elem` profileWS cp then Just (Profile pid $ delete wid $ profileWS cp) else Just cp
+
+--------------------------------------------------------------------------------
+-- | Pretty printer for a bar. Prints workspace ids of current profile.
+excludeWSPP :: PP -> X PP
+excludeWSPP pp = modifyPP <$> currentProfileWorkspaces
+  where
+    modifyPP pws = pp { ppRename = ppRename pp . printTag pws }
+    printTag pws tag = if tag `elem` pws then tag else ""
+
+--------------------------------------------------------------------------------
+-- | For cycling through workspaces associated with the current.
+wsFilter :: WSType
+wsFilter = WSIs $ currentProfileWorkspaces >>= (\ws -> return $ (`elem` ws) . W.tag)
+
+--------------------------------------------------------------------------------
+-- Takes care of placing correct workspaces on their respective screens.
+-- It does this by reducing the history of a Profile until it gets an array of length
+-- equal to the number of screens with pairs that have unique workspace ids.
+switchWSOnScreens :: ProfileId -> X()
+switchWSOnScreens pid = do
+  hist <- profileHistory
+  vis <- gets $ W.visible . windowset
+  cur <- gets $ W.current . windowset
+  pws <- profileMap <&> (profileWS . fromMaybe (Profile pid []) . Map.lookup pid)
+  case Map.lookup pid hist of
+    Nothing -> switchScreens $ zip (W.screen <$> (cur:vis)) pws
+    Just xs -> compareAndSwitch (f (W.screen <$> cur:vis) xs) (cur:vis) pws
+  where
+    f :: [ScreenId] -> [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]
+    f sids = reorderUniq . reorderUniq . reverse . filter ((`elem` sids) . fst)
+
+    reorderUniq :: (Ord k, Ord v) => [(k,v)] -> [(v,k)]
+    reorderUniq = map (\(x,y) -> (y,x)) . uniq
+
+    uniq :: (Ord k, Ord v) => [(k,v)] -> [(k,v)]
+    uniq = Map.toList . Map.fromList
+
+    viewWS fview sid wid = windows $ fview sid wid
+
+    switchScreens = mapM_ (uncurry $ viewWS greedyViewOnScreen)
+
+    compareAndSwitch hist wins pws | length hist < length wins = switchScreens $ hist <> populateScreens hist wins pws
+                                   | otherwise                 = switchScreens hist
+
+    populateScreens hist wins pws = zip (filter (`notElem` map fst hist) $ W.screen <$> wins) (filter (`notElem` map snd hist) pws)
+
+--------------------------------------------------------------------------------
+chooseAction :: (String -> X ()) -> X ()
+chooseAction f = XS.gets current <&> (profileId . fromMaybe defaultProfile) >>= f
+
+--------------------------------------------------------------------------------
+-- | Create keybindings per profile.
+bindOn :: [(String, X ())] -> X ()
+bindOn bindings = chooseAction chooser
+  where
+    chooser profile = case lookup profile bindings of
+        Just action -> action
+        Nothing -> case lookup "" bindings of
+            Just action -> action
+            Nothing -> return ()
+
+--------------------------------------------------------------------------------
+-- | Loggs currentProfile and all profiles with hidden workspaces
+--   (workspaces that aren't shown on a screen but have windows).
+profileLogger :: (String -> String) -> (String -> String) -> Logger
+profileLogger formatFocused formatUnfocused = do
+  hws <- gets $ W.hidden . windowset
+  p <- currentProfile
+  hm <- map fst
+      . filter (\(p', xs) -> any ((`elem` htags hws) . snd) xs || p' == p)
+      . Map.toList <$> profileHistory
+  return $ Just $ foldl (\a b -> a ++ " " ++ b) "" $ format p <$> hm
+  where
+    format p a = if a == p then formatFocused a else formatUnfocused a
+    htags wins = W.tag <$> filter (isJust . W.stack) wins
+
+--------------------------------------------------------------------------------
+-- | @XWindowMap@ of all windows contained in a profile.
+allProfileWindows :: XWindowMap
+allProfileWindows = allProfileWindows' def
+
+--------------------------------------------------------------------------------
+allProfileWindows' :: WindowBringerConfig -> XWindowMap
+allProfileWindows' WindowBringerConfig{ windowTitler = titler, windowFilter = include } = do
+  pws <- currentProfileWorkspaces
+  windowSet <- gets windowset
+  Map.fromList . concat <$> mapM keyValuePairs (filter ((`elem` pws) . W.tag) $ W.workspaces windowSet)
+   where keyValuePairs ws = let wins = W.integrate' (W.stack ws)
+                           in mapM (keyValuePair ws) =<< filterM include wins
+         keyValuePair ws w = (, w) <$> titler ws w

XMonad/Actions/Search.hs

@@ -437,14 +437,14 @@ namedEngine name (SearchEngine _ site) = searchEngineF name site
    browser. -}
 promptSearchBrowser :: XPConfig -> Browser -> SearchEngine -> X ()
 promptSearchBrowser config browser (SearchEngine name site) = do
-    hc <- historyCompletionP ("Search [" `isPrefixOf`)
+    hc <- historyCompletionP config ("Search [" `isPrefixOf`)
     mkXPrompt (Search name) config hc $ search browser site
 
 {- | Like 'promptSearchBrowser', but only suggest previous searches for the
    given 'SearchEngine' in the prompt. -}
 promptSearchBrowser' :: XPConfig -> Browser -> SearchEngine -> X ()
 promptSearchBrowser' config browser (SearchEngine name site) = do
-    hc <- historyCompletionP (searchName `isPrefixOf`)
+    hc <- historyCompletionP config (searchName `isPrefixOf`)
     mkXPrompt (Search name) config hc $ search browser site
   where
     searchName = showXPrompt (Search name)

XMonad/Actions/Submap.hs

@@ -18,6 +18,7 @@ module XMonad.Actions.Submap (
                              -- $usage
                              submap,
                              visualSubmap,
+                             visualSubmapSorted,
                              submapDefault,
                              submapDefaultWithKey,
 
@@ -88,15 +89,32 @@ visualSubmap :: WindowConfig -- ^ The config for the spawned window.
              -> M.Map (KeyMask, KeySym) (String, X ())
                              -- ^ A map @keybinding -> (description, action)@.
              -> X ()
-visualSubmap wc keys =
+visualSubmap = visualSubmapSorted id
+
+-- | Like 'visualSubmap', but is able to sort the descriptions.
+-- For example,
+--
+-- > import Data.Ord (comparing, Down)
+-- >
+-- > visualSubmapSorted (sortBy (comparing Down)) def
+--
+-- would sort the @(key, description)@ pairs by their keys in descending
+-- order.
+visualSubmapSorted :: ([((KeyMask, KeySym), String)] -> [((KeyMask, KeySym), String)])
+                             -- ^ A function to resort the descriptions
+             -> WindowConfig -- ^ The config for the spawned window.
+             -> M.Map (KeyMask, KeySym) (String, X ())
+                             -- ^ A map @keybinding -> (description, action)@.
+             -> X ()
+visualSubmapSorted sorted wc keys =
     withSimpleWindow wc descriptions waitForKeyPress >>= \(m', s) ->
         maybe (pure ()) snd (M.lookup (m', s) keys)
   where
     descriptions :: [String]
     descriptions =
-        zipWith (\key desc -> keyToString key <> ": " <> desc)
+        map (\(key, desc) -> keyToString key <> ": " <> desc)
-                (M.keys keys)
+            . sorted
-                (map fst (M.elems keys))
+            $ zip (M.keys keys) (map fst (M.elems keys))
 
 -- | Give a name to an action.
 subName :: String -> X () -> (String, X ())

XMonad/Actions/WindowBringer.hs

@@ -22,6 +22,7 @@ module XMonad.Actions.WindowBringer (
                     WindowBringerConfig(..),
                     gotoMenu, gotoMenuConfig, gotoMenu', gotoMenuArgs, gotoMenuArgs',
                     bringMenu, bringMenuConfig, bringMenu', bringMenuArgs, bringMenuArgs',
+                    copyMenu, copyMenuConfig, copyMenu', copyMenuArgs, copyMenuArgs',
                     windowMap, windowAppMap, windowMap', bringWindow, actionMenu
                    ) where
 
@@ -33,6 +34,7 @@ import XMonad
 import qualified XMonad as X
 import XMonad.Util.Dmenu (menuMapArgs)
 import XMonad.Util.NamedWindows (getName, getNameWMClass)
+import XMonad.Actions.CopyWindow (copyWindow)
 
 -- $usage
 --
@@ -44,6 +46,7 @@ import XMonad.Util.NamedWindows (getName, getNameWMClass)
 --
 -- > , ((modm .|. shiftMask, xK_g     ), gotoMenu)
 -- > , ((modm .|. shiftMask, xK_b     ), bringMenu)
+-- > , ((modm .|. shiftMask, xK_y     ), copyMenu)
 --
 -- For detailed instructions on editing your key bindings, see
 -- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.
@@ -90,6 +93,37 @@ gotoMenu' cmd = gotoMenuConfig def { menuArgs = [], menuCommand = cmd }
 gotoMenuArgs' :: String -> [String] -> X ()
 gotoMenuArgs' cmd args = gotoMenuConfig def { menuCommand = cmd, menuArgs = args }
 
+-- | Pops open a dmenu with window titles. Choose one, and it will be copied into your current workspace.
+copyMenu :: X ()
+copyMenu = copyMenuArgs def
+
+-- | Pops open a dmenu with window titles. Choose one, and it will be
+--   copied into your current workspace. This version
+--   accepts a configuration object.
+copyMenuConfig :: WindowBringerConfig -> X ()
+copyMenuConfig wbConfig = actionMenu wbConfig copyBringWindow
+
+-- | Pops open a dmenu with window titles. Choose one, and it will be
+--   copied into your current workspace. This version
+--   takes a list of arguments to pass to dmenu.
+copyMenuArgs :: [String] -> X ()
+copyMenuArgs args = copyMenuConfig def { menuArgs = args }
+
+-- | Pops open an application with window titles given over stdin. Choose one,
+--   and it will be copied into your current workspace.
+copyMenu' :: String -> X ()
+copyMenu' cmd = copyMenuConfig def { menuArgs = [], menuCommand = cmd }
+
+-- | Pops open an application with window titles given over stdin. Choose one,
+--   and it will be copied into your current
+--   workspace. This version allows arguments to the chooser to be specified.
+copyMenuArgs' :: String -> [String] -> X ()
+copyMenuArgs' cmd args = copyMenuConfig def { menuArgs = args, menuCommand = cmd }
+
+-- | Brings a copy of the specified window into the current workspace.
+copyBringWindow :: Window -> X.WindowSet -> X.WindowSet
+copyBringWindow w ws = copyWindow w (W.currentTag ws) ws
+
 -- | Pops open a dmenu with window titles. Choose one, and it will be
 --   dragged, kicking and screaming, into your current workspace.
 bringMenu :: X ()
@@ -159,7 +193,7 @@ decorateName ws w = do
   return $ name ++ " [" ++ W.tag ws ++ "]"
 
 -- | Returns the window name as will be listed in dmenu.  This will
--- return the executable name of the window along with it's workspace
+-- return the executable name of the window along with its workspace
 -- ID.
 decorateAppName :: X.WindowSpace -> Window -> X String
 decorateAppName ws w = do

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)

XMonad/Actions/WorkspaceNames.hs

@@ -138,7 +138,7 @@ setCurrentWorkspaceName name = do
 -- | Prompt for a new name for the current workspace and set it.
 renameWorkspace :: XPConfig -> X ()
 renameWorkspace conf = do
-    completion <- historyCompletionP (prompt ==)
+    completion <- historyCompletionP conf (prompt ==)
     mkXPrompt (Wor prompt) conf completion setCurrentWorkspaceName
   where
     prompt = "Workspace name: "

XMonad/Hooks/EwmhDesktops.hs

@@ -459,10 +459,17 @@ ewmhDesktopsEventHook'
         a_aw <- getAtom "_NET_ACTIVE_WINDOW"
         a_cw <- getAtom "_NET_CLOSE_WINDOW"
 
-        if  | mt == a_cd, n : _ <- d, Just ww <- ws !? fi n ->
+        if  | mt == a_cw ->
+                killWindow w
+            | mt == a_cd, n : _ <- d, Just ww <- ws !? fi n ->
                 if W.currentTag s == W.tag ww then mempty else windows $ W.view (W.tag ww)
             | mt == a_cd ->
                 trace $ "Bad _NET_CURRENT_DESKTOP with data=" ++ show d
+            | not (w `W.member` s) ->
+                -- do nothing for unmanaged windows; it'd be just a useless
+                -- refresh which breaks menus/popups of misbehaving apps that
+                -- send _NET_ACTIVE_WINDOW requests for override-redirect wins
+                mempty
             | mt == a_d, n : _ <- d, Just ww <- ws !? fi n ->
                 if W.findTag w s == Just (W.tag ww) then mempty else windows $ W.shiftWin (W.tag ww) w
             | mt == a_d ->
@@ -473,8 +480,6 @@ ewmhDesktopsEventHook'
                 if W.peek s == Just w then mempty else windows $ W.focusWindow w
             | mt == a_aw -> do
                 if W.peek s == Just w then mempty else windows . appEndo =<< runQuery activateHook w
-            | mt == a_cw ->
-                killWindow w
             | otherwise ->
                 -- The Message is unknown to us, but that is ok, not all are meant
                 -- to be handled by the window manager

XMonad/Hooks/FloatConfigureReq.hs

@@ -0,0 +1,126 @@
+{-# LANGUAGE LambdaCase #-}
+-- |
+-- Module      :  XMonad.Hooks.FloatConfigureReq
+-- Description :  Customize handling of floating windows' move\/resize\/restack requests (ConfigureRequest).
+-- Copyright   :  (c) 2024 Tomáš Janoušek <tomi@nomi.cz>
+-- License     :  BSD3
+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>
+--
+-- xmonad normally honours those requests by doing exactly what the client
+-- application asked, and refreshing. There are some misbehaving clients,
+-- however, that:
+--
+-- * try to move their window to the last known absolute position regardless
+--   of the current xrandr/xinerama layout
+--
+-- * move their window to 0, 0 for no particular reason (e.g. rxvt-unicode)
+--
+-- * issue lots of no-op requests causing flickering (e.g. Steam)
+--
+-- This module provides a replacement handler for 'ConfigureRequestEvent' to
+-- work around such misbehaviours.
+--
+module XMonad.Hooks.FloatConfigureReq (
+    -- * Usage
+    -- $usage
+    MaybeMaybeManageHook,
+    floatConfReqHook,
+
+    -- * Known workarounds
+    fixSteamFlicker,
+    fixSteamFlickerMMMH,
+    ) where
+
+import qualified Data.Map.Strict as M
+import XMonad
+import XMonad.Hooks.ManageHelpers
+import XMonad.Prelude
+import qualified XMonad.StackSet as W
+
+-- $usage
+-- To use this, include the following in your @xmonad.hs@:
+--
+-- > import XMonad.Hooks.FloatConfigureReq
+-- > import XMonad.Hooks.ManageHelpers
+--
+-- > myFloatConfReqHook :: MaybeMaybeManageHook
+-- > myFloatConfReqHook = composeAll
+-- >     [ … ]
+--
+-- > myEventHook :: Event -> X All
+-- > myEventHook = mconcat
+-- >     [ …
+-- >     , floatConfReqHook myFloatConfReqHook
+-- >     , … ]
+--
+-- > main = xmonad $ …
+-- >               $ def{ handleEventHook = myEventHook
+-- >                    , … }
+--
+-- Then fill the @myFloatConfReqHook@ with whatever custom rules you need.
+--
+-- As an example, the following will prevent rxvt-unicode from moving its
+-- (floating) window to 0, 0 after a font change but still ensure its size
+-- increment hints are respected:
+--
+-- > className =? "URxvt" -?> pure <$> doFloat
+--
+-- Another example that avoids flickering and xmonad slowdowns caused by the
+-- Steam client (completely ignore all its requests, none of which are
+-- meaningful in the context of a tiling WM):
+--
+-- > map toLower `fmap` className =? "steam" -?> mempty
+--
+-- (this example is also available as 'fixSteamFlickerMMMH' to be added to
+-- one's @myFloatConfReqHook@ and also 'fixSteamFlicker' to be added directly
+-- to one's 'handleEventHook')
+
+-- | A variant of 'MaybeManageHook' that additionally may or may not make
+-- changes to the 'WindowSet'.
+type MaybeMaybeManageHook = Query (Maybe (Maybe (Endo WindowSet)))
+
+-- | Customizable handler for a 'ConfigureRequestEvent'. If the event's
+-- 'ev_window' is a managed floating window, the provided
+-- 'MaybeMaybeManageHook' is consulted and its result interpreted as follows:
+--
+--  * @Nothing@ - no match, fall back to the default handler
+--
+--  * @Just Nothing@ - match but ignore, no refresh, just send ConfigureNotify
+--
+--  * @Just (Just a)@ - match, modify 'WindowSet', refresh, send ConfigureNotify
+floatConfReqHook :: MaybeMaybeManageHook -> Event -> X All
+floatConfReqHook mh ConfigureRequestEvent{ev_window = w} =
+    runQuery (join <$> (isFloatQ -?> mh)) w >>= \case
+        Nothing -> mempty
+        Just e -> do
+            whenJust e (windows . appEndo)
+            sendConfEvent
+            pure (All False)
+  where
+    sendConfEvent = withDisplay $ \dpy ->
+        withWindowAttributes dpy w $ \wa -> do
+            io . allocaXEvent $ \ev -> do
+                -- We may have made no changes to the window size/position
+                -- and thus the X server didn't emit any ConfigureNotify,
+                -- so we need to send the ConfigureNotify ourselves to make
+                -- sure there is a reply to this ConfigureRequestEvent and the
+                -- window knows we (possibly) ignored its request.
+                setEventType ev configureNotify
+                setConfigureEvent ev w w
+                    (wa_x wa) (wa_y wa) (wa_width wa)
+                    (wa_height wa) (wa_border_width wa) none (wa_override_redirect wa)
+                sendEvent dpy w False 0 ev
+floatConfReqHook _ _ = mempty
+
+-- | A 'Query' to determine if a window is floating.
+isFloatQ :: Query Bool
+isFloatQ = ask >>= \w -> liftX . gets $ M.member w . W.floating . windowset
+
+-- | A pre-packaged 'floatConfReqHook' that fixes flickering of the Steam client by ignoring 'ConfigureRequestEvent's on any of its floating windows.
+--
+-- To use this, add 'fixSteamFlicker' to your 'handleEventHook'.
+fixSteamFlicker :: Event -> X All
+fixSteamFlicker = floatConfReqHook fixSteamFlickerMMMH
+
+fixSteamFlickerMMMH :: MaybeMaybeManageHook
+fixSteamFlickerMMMH = map toLower `fmap` className =? "steam" -?> mempty

XMonad/Hooks/ManageHelpers.hs

@@ -51,6 +51,7 @@ module XMonad.Hooks.ManageHelpers (
     isFullscreen,
     isMinimized,
     isDialog,
+    isNotification,
     pid,
     desktop,
     transientTo,
@@ -191,9 +192,18 @@ isMinimized :: Query Bool
 isMinimized = isInProperty "_NET_WM_STATE" "_NET_WM_STATE_HIDDEN"
 
 -- | A predicate to check whether a window is a dialog.
+--
+-- See <https://specifications.freedesktop.org/wm-spec/wm-spec-1.5.html#idm46485863906176>.
 isDialog :: Query Bool
 isDialog = isInProperty "_NET_WM_WINDOW_TYPE" "_NET_WM_WINDOW_TYPE_DIALOG"
 
+-- | A predicate to check whether a window is a notification.
+--
+-- See <https://specifications.freedesktop.org/wm-spec/wm-spec-1.5.html#idm46485863906176>.
+isNotification :: Query Bool
+isNotification =
+  isInProperty "_NET_WM_WINDOW_TYPE" "_NET_WM_WINDOW_TYPE_NOTIFICATION"
+
 -- | This function returns 'Just' the @_NET_WM_PID@ property for a
 -- particular window if set, 'Nothing' otherwise.
 --

XMonad/Hooks/OnPropertyChange.hs

@@ -41,13 +41,13 @@ import XMonad.Prelude
 -- $usage
 -- You can use this module with the following in your @xmonad.hs@:
 --
--- > import XMonad.Hooks.DynamicProperty
+-- > import XMonad.Hooks.OnPropertyChange
 --
 -- Enable it by including in you handleEventHook definition:
 --
 -- >  main = xmonad $ def
 -- >      { ...
--- >      , handleEventHook = onXPropertyChange "WM_NAME" (title =? "Spotify" --> doShift "5"))
+-- >      , handleEventHook = onXPropertyChange "WM_NAME" (title =? "Spotify" --> doShift "5")
 -- >      , ...
 -- >      }
 --

XMonad/Hooks/ScreenCorners.hs

@@ -3,7 +3,7 @@
 -- |
 -- Module      :  XMonad.Hooks.ScreenCorners
 -- Description :  Run X () actions by touching the edge of your screen with your mouse.
--- Copyright   :  (c) 2009 Nils Schweinsberg, 2015 Evgeny Kurnevsky
+-- Copyright   :  (c) 2009 Nils Schweinsberg, 2015 Evgeny Kurnevsky, 2024 Yuanle Song
 -- License     :  BSD3-style (see LICENSE)
 --
 -- Maintainer  :  Nils Schweinsberg <mail@n-sch.de>
@@ -42,6 +42,10 @@ data ScreenCorner = SCUpperLeft
                   | SCUpperRight
                   | SCLowerLeft
                   | SCLowerRight
+                  | SCTop
+                  | SCBottom
+                  | SCLeft
+                  | SCRight
                   deriving (Eq, Ord, Show)
 
 --------------------------------------------------------------------------------
@@ -74,25 +78,49 @@ addScreenCorners = mapM_ (uncurry addScreenCorner)
 -- Xlib functions
 --------------------------------------------------------------------------------
 
--- "Translate" a ScreenCorner to real (x,y) Positions
+-- "Translate" a ScreenCorner to real (x,y) Positions with proper width and
+-- height.
 createWindowAt :: ScreenCorner -> X Window
-createWindowAt SCUpperLeft = createWindowAt' 0 0
+createWindowAt SCUpperLeft = createWindowAt' 0 0 1 1
 createWindowAt SCUpperRight = withDisplay $ \dpy ->
     let w = displayWidth  dpy (defaultScreen dpy) - 1
-    in createWindowAt' (fi w) 0
+    in createWindowAt' (fi w) 0 1 1
 
 createWindowAt SCLowerLeft = withDisplay $ \dpy ->
     let h = displayHeight dpy (defaultScreen dpy) - 1
-    in createWindowAt' 0 (fi h)
+    in createWindowAt' 0 (fi h) 1 1
 
 createWindowAt SCLowerRight = withDisplay $ \dpy ->
     let w = displayWidth  dpy (defaultScreen dpy) - 1
         h = displayHeight dpy (defaultScreen dpy) - 1
-    in createWindowAt' (fi w) (fi h)
+    in createWindowAt' (fi w) (fi h) 1 1
 
--- Create a new X window at a (x,y) Position
+createWindowAt SCTop = withDisplay $ \dpy ->
-createWindowAt' :: Position -> Position -> X Window
+    let w = displayWidth  dpy (defaultScreen dpy) - 1
-createWindowAt' x y = withDisplay $ \dpy -> io $ do
+        -- leave some gap so corner and edge can work nicely when they overlap
+        threshold = 150
+    in createWindowAt' threshold 0 (fi $ fi w - threshold * 2) 1
+
+createWindowAt SCBottom = withDisplay $ \dpy ->
+    let w = displayWidth  dpy (defaultScreen dpy) - 1
+        h = displayHeight dpy (defaultScreen dpy) - 1
+        threshold = 150
+    in createWindowAt' threshold (fi h) (fi $ fi w - threshold * 2) 1
+
+createWindowAt SCLeft = withDisplay $ \dpy ->
+    let h = displayHeight dpy (defaultScreen dpy) - 1
+        threshold = 150
+    in createWindowAt' 0 threshold 1 (fi $ fi h - threshold * 2)
+
+createWindowAt SCRight = withDisplay $ \dpy ->
+    let w = displayWidth  dpy (defaultScreen dpy) - 1
+        h = displayHeight dpy (defaultScreen dpy) - 1
+        threshold = 150
+    in createWindowAt' (fi w) threshold 1 (fi $ fi h - threshold * 2)
+
+-- Create a new X window at a (x,y) Position, with given width and height.
+createWindowAt' :: Position -> Position -> Dimension -> Dimension -> X Window
+createWindowAt' x y width height = withDisplay $ \dpy -> io $ do
 
     rootw <- rootWindow dpy (defaultScreen dpy)
 
@@ -107,8 +135,8 @@ createWindowAt' x y = withDisplay $ \dpy -> io $ do
                      rootw      -- parent window
                      x          -- x
                      y          -- y
-                     1          -- width
+                     width      -- width
-                     1          -- height
+                     height     -- height
                      0          -- border width
                      0          -- depth
                      inputOnly  -- class
@@ -122,7 +150,6 @@ createWindowAt' x y = withDisplay $ \dpy -> io $ do
     sync dpy False
     return w
 
-
 --------------------------------------------------------------------------------
 -- Event hook
 --------------------------------------------------------------------------------
@@ -162,9 +189,10 @@ screenCornerLayoutHook = ModifiedLayout ScreenCornerLayout
 --------------------------------------------------------------------------------
 -- $usage
 --
--- This extension adds KDE-like screen corners to XMonad. By moving your cursor
+-- This extension adds KDE-like screen corners and GNOME Hot Edge like
--- into one of your screen corners you can trigger an @X ()@ action, for
+-- features to XMonad. By moving your cursor into one of your screen corners
--- example @"XMonad.Actions.GridSelect".goToSelected@ or
+-- or edges, you can trigger an @X ()@ action, for example
+-- @"XMonad.Actions.GridSelect".goToSelected@ or
 -- @"XMonad.Actions.CycleWS".nextWS@ etc.
 --
 -- To use it, import it on top of your @xmonad.hs@:
@@ -176,6 +204,7 @@ screenCornerLayoutHook = ModifiedLayout ScreenCornerLayout
 -- > myStartupHook = do
 -- >     ...
 -- >     addScreenCorner SCUpperRight (goToSelected def { gs_cellwidth = 200})
+-- >     addScreenCorner SCBottom (goToSelected def)
 -- >     addScreenCorners [ (SCLowerRight, nextWS)
 -- >                      , (SCLowerLeft,  prevWS)
 -- >                      ]

XMonad/Hooks/StatusBar.hs

@@ -452,7 +452,7 @@ instance ExtensionClass ActiveSBs where
 -- 'avoidStruts', check 'dynamicEasySBs'.
 --
 -- Heavily inspired by "XMonad.Hooks.DynamicBars"
-dynamicSBs :: (ScreenId -> IO StatusBarConfig) -> XConfig l -> XConfig l
+dynamicSBs :: (ScreenId -> X StatusBarConfig) -> XConfig l -> XConfig l
 dynamicSBs f conf = addAfterRescreenHook (updateSBs f) $ conf
   { startupHook = startupHook conf >> killAllStatusBars >> updateSBs f
   , logHook     = logHook conf >> logSBs
@@ -462,7 +462,7 @@ dynamicSBs f conf = addAfterRescreenHook (updateSBs f) $ conf
 -- resulting config and adds 'avoidStruts' to the
 -- layout.
 dynamicEasySBs :: LayoutClass l Window
-               => (ScreenId -> IO StatusBarConfig)
+               => (ScreenId -> X StatusBarConfig)
                -> XConfig l
                -> XConfig (ModifiedLayout AvoidStruts l)
 dynamicEasySBs f conf =
@@ -471,7 +471,7 @@ dynamicEasySBs f conf =
 -- | Given the function to create status bars, update
 -- the status bars by killing those that shouldn't be
 -- visible anymore and creates any missing status bars
-updateSBs :: (ScreenId -> IO StatusBarConfig) -> X ()
+updateSBs :: (ScreenId -> X StatusBarConfig) -> X ()
 updateSBs f = do
   actualScreens    <- withWindowSet $ return . map W.screen . W.screens
   (toKeep, toKill) <-
@@ -480,7 +480,7 @@ updateSBs f = do
   cleanSBs (map snd toKill)
   -- Create new status bars if needed
   let missing = actualScreens \\ map fst toKeep
-  added <- io $ traverse (\s -> (s,) <$> f s) missing
+  added <- traverse (\s -> (s,) <$> f s) missing
   traverse_ (sbStartupHook . snd) added
   XS.put (ASB (toKeep ++ added))
 

XMonad/Layout/AutoMaster.hs

@@ -35,7 +35,7 @@ import Control.Arrow (first)
 -- in one row, in slave area underlying layout is run. Size of slave area
 -- automatically increases when number of slave windows is increasing.
 --
--- You can use this module by adding folowing in your @xmonad.hs@:
+-- You can use this module by adding following in your @xmonad.hs@:
 --
 -- > import XMonad.Layout.AutoMaster
 --

XMonad/Layout/CenteredMaster.hs

@@ -38,7 +38,7 @@ import Control.Arrow (first)
 -- All other windows in background are managed by base layout.
 -- topRightMaster is like centerMaster, but places master window in top right corner instead of center.
 --
--- Yo can use this module by adding folowing in your @xmonad.hs@:
+-- You can use this module by adding following in your @xmonad.hs@:
 --
 -- > import XMonad.Layout.CenteredMaster
 --

XMonad/Layout/Column.hs

@@ -11,7 +11,7 @@
 -- Portability :  unportable
 --
 -- Provides Column layout that places all windows in one column. Windows
--- heights are calculated from equation: H1/H2 = H2/H3 = ... = q, where q is
+-- heights are calculated from the equation: H1/H2 = H2/H3 = ... = q, where q is
 -- given. With Shrink/Expand messages you can change the q value.
 --
 -----------------------------------------------------------------------------
@@ -25,12 +25,12 @@ import XMonad
 import qualified XMonad.StackSet as W
 
 -- $usage
--- This module defines layot named Column. It places all windows in one
+-- This module defines layout named Column. It places all windows in one
--- column. Windows heights are calculated from equation: H1/H2 = H2/H3 = ... =
+-- column. Windows heights are calculated from the equation: H1/H2 = H2/H3 = ... =
 -- q, where `q' is given (thus, windows heights are members of geometric
 -- progression). With Shrink/Expand messages one can change the `q' value.
 --
--- You can use this module by adding folowing in your @xmonad.hs@:
+-- You can use this module by adding following in your @xmonad.hs@:
 --
 -- > import XMonad.Layout.Column
 --

XMonad/Layout/Columns.hs

@@ -0,0 +1,480 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+-- |
+-- Module: XMonad.Layout.Columns
+-- Description: A layout which tiles the windows in columns.
+-- Copyright: Jean-Charles Quillet
+-- License: BSD-style (see LICENSE)
+--
+-- Maintainer: none
+-- Stability: unstable
+-- Portability: unportable
+--
+-- A layout which tiles the windows in columns. The windows can be moved and
+-- resized in every directions.
+--
+-- The first window appears in a single column in the center of the screen. Its
+-- width is configurable (See 'coOneWindowWidth').
+--
+-- The second window appears in a second column. Starting with two columns, they
+-- fill up the screen.
+--
+-- Subsequent windows appear on the bottom of the last columns.
+module XMonad.Layout.Columns
+  ( -- * Usage
+    -- $usage
+    ColumnsLayout (..),
+
+    -- * Messages
+    Focus (..),
+    Move (..),
+    Resize (..),
+
+    -- * Tools
+    focusDown,
+    focusUp,
+  )
+where
+
+import Control.Applicative ((<|>))
+import Control.Arrow (Arrow (first), second)
+import Control.Monad (guard)
+import Control.Monad.State (modify)
+import Control.Monad.Trans.Maybe (MaybeT (..))
+import Data.Foldable (Foldable (..))
+import Data.List (scanl')
+import Data.Maybe (listToMaybe)
+import Data.Ratio ((%))
+import XMonad
+  ( LayoutClass (..),
+    Message,
+    Rectangle (..),
+    SomeMessage,
+    Window,
+    WindowSet,
+    X,
+    XState (..),
+    fromMessage,
+    gets,
+    scaleRationalRect,
+    sendMessage,
+  )
+import qualified XMonad.Operations as O
+import XMonad.StackSet
+  ( RationalRect (..),
+    Screen (..),
+    Stack (..),
+    StackSet (..),
+    integrate,
+    peek,
+  )
+import qualified XMonad.StackSet as StackSet
+
+-- $usage
+-- Add 'Columns' to your @layoutHook@ with an initial empty state:
+--
+-- > myLayout = Full ||| Columns 1 []
+--
+-- Here is an example of keybindings:
+--
+-- > -- Focus up/down
+-- > ((modm, xK_Tab), focusDown),
+-- > ((modm .|. shiftMask, xK_Tab), focusUp),
+-- > -- Move windows around
+-- > ((modm .|. shiftMask, xK_l), sendMessage MoveRight),
+-- > ((modm .|. shiftMask, xK_h), sendMessage MoveLeft),
+-- > ((modm .|. shiftMask, xK_k), sendMessage MoveUp),
+-- > ((modm .|. shiftMask, xK_j), sendMessage MoveDown),
+-- > -- Resize them
+-- > ((modm .|. controlMask, xK_l), sendMessage HorizontalExpand),
+-- > ((modm .|. controlMask, xK_h), sendMessage HorizontalShrink),
+-- > ((modm .|. controlMask, xK_k), sendMessage VerticalExpand),
+-- > ((modm .|. controlMask, xK_j), sendMessage VerticalShrink),
+--
+-- This layout is known to work with:
+--
+-- * "XMonad.Layout.WindowNavigation" for changing focus with a direction using
+-- 'XMonad.Layout.WindowNavigation.Go' messages.
+-- * 'XMonad.Layout.SubLayouts.subTabbed' for docking windows together with
+-- tabs. Note that sometimes when undocking windows, the layout is reset. This is
+-- a minor annoyance caused by the difficulty to track windows in the sublayout.
+
+-- | The windows can be moved in every directions.
+--
+-- Horizontally, a window alone in its column cannot be moved before the first
+-- or after the last column. If not alone, moving the window outside those
+-- limits will create a new column.
+-- The windows can also be moved vertically in their column.
+data Move = MoveLeft | MoveRight | MoveUp | MoveDown deriving (Show, Read)
+
+instance Message Move
+
+-- | The windows can be resized in every directions.
+--
+-- When resizing horizontally:
+--
+-- * if the window to be resized is not in the last column
+--
+--      * then the right side of the window will be moved
+--      * the last column will compensate the size change
+--
+-- * if the window is in the last column
+--
+--      * then the left side of the window will be moved
+--      * the column on the left of the current one will compensate the size change
+--
+-- The same applies when resizing vertically using the bottom side of the
+-- window unless it is the last window in the column in which case we use the
+-- top side.
+data Resize
+  = VerticalShrink
+  | VerticalExpand
+  | HorizontalShrink
+  | HorizontalExpand
+  deriving (Show, Read)
+
+instance Message Resize
+
+-- | The layout handles focus change messages.
+--
+-- Built-in focus cannot be used here because @XMonad@ does not make it easy to
+-- change the order of windows in the focus list. See also 'focusUp' and
+-- 'focusDown' functions.
+data Focus = FocusUp | FocusDown
+  deriving (Show, Read)
+
+instance Message Focus
+
+-- | A column is a list of windows with their relative vertical dimensions.
+type Column = [(Rational, Window)]
+
+-- | The layout is a list of 'Column' with their relative horizontal dimensions.
+type Columns = [(Rational, Column)]
+
+data ColumnsLayout a = Columns
+  { -- | With of the first column when there is only one window. Usefull on wide
+    -- screens.
+    coOneWindowWidth :: Rational,
+    -- | The current state
+    coColumns :: Columns
+  }
+  deriving (Show, Read)
+
+instance LayoutClass ColumnsLayout Window where
+  description _ = layoutDescription
+
+  doLayout (Columns oneWindowWidth columns) rectangle stack =
+    pure (rectangles, Just (Columns oneWindowWidth columns'))
+    where
+      hackedColumns = hackForTabs columns stack
+      columns' = updateWindowList hackedColumns stack
+      rectangles = toRectangles rectangle' columns'
+      -- If there is only one window, we set the destination rectangle according
+      -- to the width in the layout setting.
+      rectangle'
+        | (length . toList $ stack) == 1 =
+            scaleRationalRect rectangle singleColumnRR
+        | otherwise = rectangle
+      singleColumnOffset = (1 - oneWindowWidth) / 2
+      singleColumnRR = RationalRect singleColumnOffset 0 oneWindowWidth 1
+
+  handleMessage layout@(Columns oneWindowWidth columns) message = do
+    mbStack <- runMaybeT $ handleFocus' =<< getStack
+    changedFocus <- traverse updateStack' mbStack
+
+    movedOrResized <-
+      runMaybeT $
+        Columns oneWindowWidth
+          <$> (handleMoveOrResize' =<< peekFocus)
+
+    pure $ movedOrResized <|> changedFocus
+    where
+      getStack = MaybeT . gets $ StackSet.stack . workspace . current . windowset
+      handleFocus' = hoistMaybe . handleFocus columns message
+      -- A 'Just' needs to be return for the new stack to be taken into account
+      updateStack' s = modify (setStack s) >> pure layout
+      peekFocus = MaybeT . gets $ peek . windowset
+      handleMoveOrResize' = hoistMaybe . handleMoveOrResize columns message
+      hoistMaybe = MaybeT . pure
+
+layoutDescription :: String
+layoutDescription = "Columns"
+
+-- | Change the keyboard focus to the previous window
+focusUp :: X ()
+focusUp =
+  sendMsgOrOnWindowsSet FocusUp StackSet.focusUp
+    =<< getCurrentLayoutDescription
+
+-- | Change the keyboard focus to the next window
+focusDown :: X ()
+focusDown =
+  sendMsgOrOnWindowsSet FocusDown StackSet.focusDown
+    =<< getCurrentLayoutDescription
+
+sendMsgOrOnWindowsSet :: (Message a) => a -> (WindowSet -> WindowSet) -> String -> X ()
+sendMsgOrOnWindowsSet message f description'
+  | description' == layoutDescription = sendMessage message
+  | otherwise = O.windows f
+
+getCurrentLayoutDescription :: X String
+getCurrentLayoutDescription =
+  gets
+    ( description
+        . StackSet.layout
+        . workspace
+        . current
+        . windowset
+    )
+
+setStack :: Stack Window -> XState -> XState
+setStack stack state =
+  state
+    { windowset =
+        (windowset state)
+          { current =
+              (current $ windowset state)
+                { workspace =
+                    (workspace . current $ windowset state)
+                      { StackSet.stack = Just stack
+                      }
+                }
+          }
+    }
+
+handleFocus :: Columns -> SomeMessage -> Stack Window -> Maybe (Stack Window)
+handleFocus columns message stack
+  | Just FocusDown <- fromMessage message = setFocus' stack <$> mbNext
+  | Just FocusUp <- fromMessage message = setFocus' stack <$> mbPrevious
+  | otherwise = Nothing
+  where
+    focused = focus stack
+    windows = columnsToWindows columns
+    exists = focused `elem` windows
+    mbNext = guard exists >> next focused windows
+    mbPrevious = guard exists >> previous focused windows
+    setFocus' = flip setFocus
+    previous a = next a . reverse
+    setFocus w = until ((==) w . focus) StackSet.focusDown'
+    next _ [] = Nothing
+    next a (x : xs)
+      | a == x = listToMaybe xs
+      | otherwise = next a (xs <> [x])
+
+oldNewWindows :: Columns -> Stack Window -> ([Window], [Window])
+oldNewWindows columns stack = (old, new)
+  where
+    old = filter (`notElem` stackList) windows
+    new = filter (`notElem` windows) stackList
+    stackList = toList stack
+    windows = columnsToWindows columns
+
+-- | Add the new windows to the layout and remove the old ones.
+updateWindowList :: Columns -> Stack Window -> Columns
+updateWindowList columns stack = addWindows newWindows (removeWindows oldWindows columns)
+  where
+    (oldWindows, newWindows) = oldNewWindows columns stack
+
+-- | If one window disappeared and another appeared, we assume that the sublayout
+-- tabs just changed focused.
+hackForTabs :: Columns -> Stack Window -> Columns
+hackForTabs columns stack = mapWindow replace columns
+  where
+    replace window
+      | (w1 : _, [w2]) <- oldNewWindows columns stack =
+          if window == w1
+            then w2
+            else window
+      | otherwise = window
+
+toRectangles :: Rectangle -> [(Rational, [(Rational, a)])] -> [(a, Rectangle)]
+toRectangles rectangle columns =
+  second (scaleRationalRect rectangle) <$> windowsAndRectangles
+  where
+    offsetsAndRatios = toOffsetRatio (second toOffsetRatio <$> columns)
+    windowsAndRectangles = foldMap toWindowAndRectangle offsetsAndRatios
+    toWindowAndRectangle (x, w, cs) = (\(y, h, ws) -> (ws, RationalRect x y w h)) <$> cs
+
+onFocused :: (a -> a) -> Stack a -> Stack a
+onFocused f (Stack a before after) = Stack (f a) before after
+
+onFocusedM :: (Monad m) => (a -> m a) -> Stack a -> m (Stack a)
+onFocusedM f (Stack a before after) = Stack <$> f a <*> pure before <*> pure after
+
+onFocusedOrPrevious :: (a -> a) -> Stack a -> Stack a
+onFocusedOrPrevious f (Stack a (a' : others) []) = Stack a (f a' : others) []
+onFocusedOrPrevious f stack = onFocused f stack
+
+handleMoveOrResize :: Columns -> SomeMessage -> Window -> Maybe Columns
+handleMoveOrResize columns message window
+  | Just msg <- fromMessage message = move msg window columns
+  | Just HorizontalShrink <- fromMessage message =
+      onFocusedOrPrevious' shrink <$> findInColumns window columns
+  | Just HorizontalExpand <- fromMessage message =
+      onFocusedOrPrevious' expand <$> findInColumns window columns
+  | Just VerticalExpand <- fromMessage message =
+      onFocusedM'
+        (fmap (onFocusedOrPrevious' shrink) . findInColumn window)
+        =<< findInColumns window columns
+  | Just VerticalShrink <- fromMessage message =
+      onFocusedM'
+        (fmap (onFocusedOrPrevious' expand) . findInColumn window)
+        =<< findInColumns window columns
+  | otherwise = Nothing
+  where
+    expand = first $ flip (+) (3 / 100)
+    shrink = first $ flip (-) (3 / 100)
+    onFocusedM' f = fmap integrate . onFocusedM (sequence . second f)
+    onFocusedOrPrevious' f = sanitize . integrate . onFocusedOrPrevious f
+
+move :: Move -> Window -> Columns -> Maybe Columns
+move direction window columns =
+  case (direction, findInColumns window columns) of
+    (MoveRight, Just (Stack (_, [(_, _)]) _ [])) -> Nothing
+    (MoveLeft, Just (Stack (_, [(_, _)]) [] _)) -> Nothing
+    (MoveRight, Just (Stack column@(_, [(_, _)]) before (next : others))) ->
+      let (column', next') = swapWindowBetween window column next
+       in Just . integrate $ Stack column' before (next' : others)
+    (MoveLeft, Just (Stack column@(_, [(_, _)]) (previous : others) after)) ->
+      let (column', previous') = swapWindowBetween window column previous
+       in Just . integrate $ Stack column' (previous' : others) after
+    (MoveRight, Just stack) ->
+      let (newColumns', Stack column before after) = rationalize newColumns stack
+          windows = removeWindow window column
+       in Just . integrate $ Stack windows before (newColumns' <> after)
+    (MoveLeft, Just stack) ->
+      let (newColumns', Stack column before after) = rationalize newColumns stack
+          windows = removeWindow window column
+       in Just . integrate $ Stack windows (newColumns' <> before) after
+    (MoveUp, Just stack) -> integrate <$> onFocusedM (swapWindowUp window) stack
+    (MoveDown, Just stack) -> integrate <$> onFocusedM (swapWindowDown window) stack
+    _ -> Nothing
+  where
+    newColumns = [[(1, window)]]
+
+mapWindow :: (Window -> Window) -> Columns -> Columns
+mapWindow = fmap . fmap . fmap . fmap
+
+columnsToWindows :: Columns -> [Window]
+columnsToWindows = foldMap ((: []) . snd) . foldMap snd
+
+swapWindowBetween ::
+  Window ->
+  (Rational, Column) ->
+  (Rational, Column) ->
+  ((Rational, Column), (Rational, Column))
+swapWindowBetween window from to = (removed, added)
+  where
+    removed = removeWindow window from
+    added = appendWindows [window] to
+
+swapWindowUp :: Window -> (Rational, Column) -> Maybe (Rational, Column)
+swapWindowUp window (width, column)
+  | Just (Stack (height, _) (previous : before') after) <- findInColumn window column =
+      Just (width, integrate $ Stack previous ((height, window) : before') after)
+  | otherwise = Nothing
+
+swapWindowDown :: Window -> (Rational, Column) -> Maybe (Rational, Column)
+swapWindowDown window (width, column)
+  | Just (Stack (height, _) before (next : others)) <- findInColumn window column =
+      Just (width, integrate $ Stack next before ((height, window) : others))
+  | otherwise = Nothing
+
+-- | Adjust the ratio of a list or a stack of elts so that when adding new
+--  elements:
+-- - the new elements are distributed according to the total number of elements
+-- - the existing elements keep their proportion in the remaining space
+rationalize ::
+  (Functor f, Foldable f) =>
+  [a] ->
+  f (Rational, a) ->
+  ([(Rational, a)], f (Rational, a))
+rationalize new existing = (new', existing')
+  where
+    nbNew = fromIntegral $ length new
+    nbInColumn = fromIntegral $ length existing
+    newRatio = nbNew % (nbNew + nbInColumn)
+    existingRatio = 1 - newRatio
+    new' = fitElements newRatio new
+    existing' = first (* existingRatio) <$> existing
+
+append :: [a] -> [(Rational, a)] -> [(Rational, a)]
+append new existing = uncurry (flip mappend) (rationalize new existing)
+
+appendWindows ::
+  [Window] ->
+  (Rational, [(Rational, Window)]) ->
+  (Rational, [(Rational, Window)])
+appendWindows windows = second (append windows)
+
+fitElements :: Rational -> [a] -> [(Rational, a)]
+fitElements dimension elts = (dimension',) <$> elts
+  where
+    dimension' = dimension / fromIntegral (length elts)
+
+singleColumn :: Rational -> Rational -> [Window] -> Columns
+singleColumn width height windows = [(width, fitElements height windows)]
+
+findElement' :: (a -> Bool) -> [(Rational, a)] -> Maybe (Stack (Rational, a))
+findElement' predicate list
+  | (before, c : after) <- break (predicate . snd) list =
+      Just $ Stack c (reverse before) after
+  | otherwise = Nothing
+
+findInColumns :: Window -> Columns -> Maybe (Stack (Rational, Column))
+findInColumns window = findElement' (any ((== window) . snd))
+
+findInColumn :: Window -> Column -> Maybe (Stack (Rational, Window))
+findInColumn window = findElement' (== window)
+
+removeWindows :: [Window] -> Columns -> Columns
+removeWindows windows = removeEmptyColumns . fmap (second removeWindows')
+  where
+    inWindows (_, window) = window `notElem` windows
+    removeWindows' = normalize . filter inWindows
+    removeEmptyColumns = normalize . filter (not . null . snd)
+
+removeWindow :: Window -> (Rational, Column) -> (Rational, Column)
+removeWindow window = second (normalize . filter ((/= window) . snd))
+
+addWindows :: [Window] -> Columns -> Columns
+addWindows [] columns = columns
+-- When there is only one column, create a new one on the right
+addWindows windows [(_, windows')] = (1 % 2, windows') : singleColumn (1 % 2) 1 windows
+-- When there is more, append the windows to the last column
+addWindows windows columns
+  | Just (columns', column) <- unsnoc columns =
+      sanitizeColumns $ columns' <> [appendWindows windows column]
+  | otherwise = singleColumn 1 1 windows
+
+-- | Make sure the sum of all dimensions is 1
+normalize :: [(Rational, a)] -> [(Rational, a)]
+normalize elts = fmap (first (/ total)) elts
+  where
+    total = sum (fst <$> elts)
+
+-- | Update the last dimension so that the sum of all dimensions is 1
+sanitize :: [(Rational, a)] -> [(Rational, a)]
+sanitize list
+  | Just (elts, (_, a)) <- unsnoc list = elts <> [(1 - sum (fst <$> elts), a)]
+  | otherwise = []
+
+-- | Same on the whole layout
+sanitizeColumns :: Columns -> Columns
+sanitizeColumns = sanitize . fmap (second sanitize)
+
+toOffsetRatio :: [(Rational, a)] -> [(Rational, Rational, a)]
+toOffsetRatio ra = zipWith toTruple ra positions
+  where
+    toTruple (dimension, a) position = (position, dimension, a)
+    positions = scanl' (\position (dimension, _) -> position + dimension) 0 ra
+
+unsnoc :: [a] -> Maybe ([a], a)
+unsnoc [] = Nothing
+unsnoc (x : xs)
+  | Just (is, l) <- unsnoc xs = Just (x : is, l)
+  | otherwise = Just ([], x)

XMonad/Layout/Hidden.hs

@@ -118,7 +118,7 @@ popHiddenWindow = sendMessage . PopSpecificHiddenWindow
 --------------------------------------------------------------------------------
 hideWindowMsg :: HiddenWindows a -> Window -> X (Maybe (HiddenWindows a))
 hideWindowMsg (HiddenWindows hidden) win = do
-  modify (\s -> s { windowset = W.delete' win $ windowset s })
+  modifyWindowSet $ W.delete' win
   return . Just . HiddenWindows $ hidden ++ [win]
 
 --------------------------------------------------------------------------------

XMonad/Layout/IfMax.hs

@@ -36,7 +36,7 @@ import qualified XMonad.StackSet as W
 -- IfMax layout will run one layout if number of windows on workspace is as
 -- maximum N, and else will run another layout.
 --
--- You can use this module by adding folowing in your @xmonad.hs@:
+-- You can use this module by adding following in your @xmonad.hs@:
 --
 -- > import XMonad.Layout.IfMax
 --

XMonad/Layout/TabBarDecoration.hs

@@ -46,8 +46,8 @@ import XMonad.Prompt ( XPPosition (..) )
 -- 'tabBar' will give you the possibility of setting a custom shrinker
 -- and a custom theme.
 --
--- The deafult theme can be dynamically change with the xmonad theme
+-- The default theme can be dynamically changed with the xmonad theme
--- selector. See "XMonad.Prompt.Theme". For more themse, look at
+-- selector. See "XMonad.Prompt.Theme". For more themes, look at
 -- "XMonad.Util.Themes"
 
 -- | Add, on the top of the screen, a simple bar of tabs to a given

XMonad/Prompt.hs

@@ -562,7 +562,7 @@ mkXPromptImplementation historyKey conf om = do
   s <- gets $ screenRect . W.screenDetail . W.current . windowset
   cleanMask <- cleanKeyMask
   cachedir <- asks (cacheDir . directories)
-  hist <- io $ readHistory cachedir
+  hist <- io $ readHistory conf cachedir
   fs <- initXMF (font conf)
   let width = getWinWidth s (position conf)
   st' <- io $
@@ -582,7 +582,7 @@ mkXPromptImplementation historyKey conf om = do
   releaseXMF fs
   when (successful st') $ do
     let prune = take (historySize conf)
-    io $ writeHistory cachedir $
+    io $ writeHistory conf cachedir $
       M.insertWith
       (\xs ys -> prune . historyFilter conf $ xs ++ ys)
       historyKey
@@ -1690,16 +1690,18 @@ emptyHistory = M.empty
 getHistoryFile :: FilePath -> FilePath
 getHistoryFile cachedir = cachedir ++ "/prompt-history"
 
-readHistory :: FilePath -> IO History
+readHistory :: XPConfig -> FilePath -> IO History
-readHistory cachedir = readHist `E.catch` \(SomeException _) -> return emptyHistory
+readHistory (XPC { historySize = 0 }) _ = return emptyHistory
+readHistory _ cachedir = readHist `E.catch` \(SomeException _) -> return emptyHistory
  where
     readHist = do
         let path = getHistoryFile cachedir
         xs <- withFile path ReadMode hGetLine
         readIO xs
 
-writeHistory :: FilePath -> History -> IO ()
+writeHistory :: XPConfig -> FilePath -> History -> IO ()
-writeHistory cachedir hist = do
+writeHistory (XPC { historySize = 0 }) _ _ = return ()
+writeHistory _ cachedir hist = do
   let path = getHistoryFile cachedir
       filtered = M.filter (not . null) hist
   writeFile path (show filtered) `E.catch` \(SomeException e) ->
@@ -1793,17 +1795,17 @@ breakAtSpace s
 -- | 'historyCompletion' provides a canned completion function much like
 --   'getShellCompl'; you pass it to mkXPrompt, and it will make completions work
 --   from the query history stored in the XMonad cache directory.
-historyCompletion :: X ComplFunction
+historyCompletion :: XPConfig -> X ComplFunction
-historyCompletion = historyCompletionP (const True)
+historyCompletion conf = historyCompletionP conf (const True)
 
 -- | Like 'historyCompletion' but only uses history data from Prompts whose
 -- name satisfies the given predicate.
-historyCompletionP :: (String -> Bool) -> X ComplFunction
+historyCompletionP :: XPConfig -> (String -> Bool) -> X ComplFunction
-historyCompletionP p = do
+historyCompletionP conf p = do
     cd <- asks (cacheDir . directories)
     pure $ \x ->
         let toComplList = deleteConsecutive . filter (isInfixOf x) . M.foldr (++) []
-         in toComplList . M.filterWithKey (const . p) <$> readHistory cd
+         in toComplList . M.filterWithKey (const . p) <$> readHistory conf cd
 
 -- | Sort a list and remove duplicates. Like 'deleteAllDuplicates', but trades off
 --   laziness and stability for efficiency.

XMonad/Prompt/OrgMode.hs

@@ -53,6 +53,7 @@ module XMonad.Prompt.OrgMode (
     Date (..),
     Time (..),
     TimeOfDay (..),
+    OrgTime (..),
     DayOfWeek (..),
 #endif
 
@@ -122,7 +123,9 @@ Monday and you schedule something for Monday, you will actually schedule
 it for the /next/ Monday (the one in seven days).
 
 The time is specified in the @HH:MM@ or @HHMM@ format.  The minutes may
-be omitted, in which case we assume a full hour is specified.
+be omitted, in which case we assume a full hour is specified.  It is also
+possible to enter a time span using the syntax @HH:MM-HH:MM@ or @HH:MM+HH@.
+In the former case, minutes may be omitted.
 
 A few examples are probably in order.  Suppose we have bound the key
 above, pressed it, and are now confronted with a prompt:
@@ -137,6 +140,10 @@ above, pressed it, and are now confronted with a prompt:
   - @hello +d today 12:30@ works just like above, but creates a
     deadline.
 
+  - @hello +d today 12:30-14:30@ works like the above, but gives the
+    event a duration of two hours.  An alternative way to specify
+    this would be @hello +d today 12:30+2@.
+
   - @hello +s thu@ would schedule the note for next thursday.
 
   - @hello +s 11@ would schedule it for the 11th of this month and this
@@ -356,21 +363,30 @@ refile (asString -> parent) (asString -> fp) =
 -- @HH:MM@ time.
 data Time = Time
   { date :: Date
-  , tod  :: Maybe TimeOfDay
+  , tod  :: Maybe OrgTime
   }
   deriving (Eq, Show)
 
 -- | The time in HH:MM.
-data TimeOfDay = TimeOfDay Int Int
+data TimeOfDay = HHMM Int Int
   deriving (Eq)
 
 instance Show TimeOfDay where
   show :: TimeOfDay -> String
-  show (TimeOfDay h m) = pad h <> ":" <> pad m
+  show (HHMM h m) = pad h <> ":" <> pad m
    where
     pad :: Int -> String
     pad n = (if n <= 9 then "0" else "") <> show n
 
+-- | The time—possibly as a span—in HH:MM format.
+data OrgTime = MomentInTime TimeOfDay | TimeSpan TimeOfDay TimeOfDay
+  deriving (Eq)
+
+instance Show OrgTime where
+  show :: OrgTime -> String
+  show (MomentInTime tod)  = show tod
+  show (TimeSpan tod tod') = show tod <> "-" <> show tod'
+
 -- | Type for specifying exactly which day one wants.
 data Date
   = Today
@@ -383,7 +399,7 @@ data Date
     -- ^ Manual date entry in the format DD [MM] [YYYY]
   deriving (Eq, Ord, Show)
 
-toOrgFmt :: Maybe TimeOfDay -> Day -> String
+toOrgFmt :: Maybe OrgTime -> Day -> String
 toOrgFmt tod day =
   mconcat ["<", isoDay, " ", take 3 $ show (dayOfWeek day), time, ">"]
  where
@@ -498,8 +514,8 @@ ppNote clp todo = \case
 -- | Parse the given string into a 'Note'.
 pInput :: String -> Maybe Note
 pInput inp = (`runParser` inp) . choice $
-  [ Scheduled <$> getLast "+s" <*> (Time <$> pDate <*> pTimeOfDay) <*> pPriority
+  [ Scheduled <$> (getLast "+s" <* " ") <*> join (fixTime <$> pDate <*> pOrgTime) <*> pPriority
-  , Deadline  <$> getLast "+d" <*> (Time <$> pDate <*> pTimeOfDay) <*> pPriority
+  , Deadline  <$> (getLast "+d" <* " ") <*> join (fixTime <$> pDate <*> pOrgTime) <*> pPriority
   , do s <- munch1 (pure True)
        let (s', p) = splitAt (length s - 3) s
        pure $ case tryPrio p of
@@ -507,6 +523,12 @@ pInput inp = (`runParser` inp) . choice $
          Nothing   -> NormalMsg s                   NoPriority
   ]
  where
+  fixTime :: Maybe Date -> Maybe OrgTime -> Parser Time
+  fixTime d tod = case (d, tod) of
+    (Nothing, Nothing) -> mempty                -- no day and no time
+    (Nothing, Just{})  -> pure (Time Today tod) -- no day, but a time
+    (Just d', _)       -> pure (Time d'    tod) -- day given
+
   tryPrio :: String -> Maybe Priority
   tryPrio [' ', '#', x]
     | x `elem` ("Aa" :: String) = Just A
@@ -533,21 +555,33 @@ pInput inp = (`runParser` inp) . choice $
 -- | Parse a 'Priority'.
 pPriority :: Parser Priority
 pPriority = option NoPriority $
-  " " *> skipSpaces *> choice
+  skipSpaces *> choice
     [ "#" *> foldCase "a" $> A
     , "#" *> foldCase "b" $> B
     , "#" *> foldCase "c" $> C
     ]
 
 -- | Try to parse a 'Time'.
-pTimeOfDay :: Parser (Maybe TimeOfDay)
+pOrgTime :: Parser (Maybe OrgTime)
-pTimeOfDay = option Nothing $
+pOrgTime = option Nothing $
-  skipSpaces >> Just <$> choice
+  between skipSpaces (void " " <|> eof) $
-    [ TimeOfDay <$> pHour <* ":" <*> pMinute -- HH:MM
+    Just <$> choice
-    , pHHMM                                  -- HHMM
+      [ TimeSpan <$> (pTimeOfDay <* ("--" <|> "-" <|> "–")) <*> pTimeOfDay
-    , TimeOfDay <$> pHour        <*> pure 0  -- HH
+      -- Org is not super smart around times with this syntax, so
+      -- we pretend not to be as well.
+      , do from@(HHMM h m) <- pTimeOfDay <* "+"
+           off <- pHour
+           pure $ TimeSpan from (HHMM (h + off) m)
+      , MomentInTime <$> pTimeOfDay
       ]
  where
+  pTimeOfDay :: Parser TimeOfDay
+  pTimeOfDay = choice
+    [ HHMM <$> pHour <* ":" <*> pMinute -- HH:MM
+    , pHHMM                             -- HHMM
+    , HHMM <$> pHour        <*> pure 0  -- HH
+    ]
+
   pHHMM :: Parser TimeOfDay
   pHHMM = do
     let getTwo = count 2 (satisfy isDigit)
@@ -555,18 +589,19 @@ pTimeOfDay = option Nothing $
     guard (hh >= 0 && hh <= 23)
     mm <- read <$> getTwo
     guard (mm >= 0 && mm <= 59)
-    pure $ TimeOfDay hh mm
+    pure $ HHMM hh mm
+
   pHour   :: Parser Int = pNumBetween 0 23
   pMinute :: Parser Int = pNumBetween 0 59
 
--- | Parse a 'Date'.
+-- | Try to parse a 'Date'.
-pDate :: Parser Date
+pDate :: Parser (Maybe Date)
-pDate = skipSpaces *> choice
+pDate = skipSpaces *> optional (choice
   [ pPrefix "tod" "ay"    Today
   , pPrefix "tom" "orrow" Tomorrow
   , Next <$> pNext
   , Date <$> pDate'
-  ]
+  ])
  where
   pNext :: Parser DayOfWeek = choice
     [ pPrefix "m"  "onday"    Monday   , pPrefix "tu" "esday"  Tuesday
@@ -585,7 +620,7 @@ pDate = skipSpaces *> choice
 
   pDate' :: Parser (Int, Maybe Int, Maybe Integer)
   pDate' =
-    (,,) <$> pNumBetween 1 31               -- day
+    (,,) <$> (pNumBetween 1 31 <* (void " " <|> eof))  -- day
          <*> optional (skipSpaces *> choice
                [ pPrefix "ja"  "nuary"    1 , pPrefix "f"   "ebruary" 2
                , pPrefix "mar" "ch"       3 , pPrefix "ap"  "ril"     4

XMonad/Util/EZConfig.hs

@@ -552,8 +552,8 @@ doKeymapCheck :: XConfig l -> [(String,a)] -> ([String], [String])
 doKeymapCheck conf km = (bad,dups)
   where ks = map ((readKeySequence conf &&& id) . fst) km
         bad = nub . map snd . filter (isNothing . fst) $ ks
-        dups = map (snd . NE.head)
+        dups = map (snd . NE.head . notEmpty)
-             . mapMaybe nonEmpty
+             . filter ((>1) . length)
              . groupBy ((==) `on` fst)
              . sortBy (comparing fst)
              . map (first fromJust)

XMonad/Util/Grab.hs

@@ -29,15 +29,12 @@ module XMonad.Util.Grab
   ) where
 
 -- core
-import           XMonad                         hiding (mkGrabs)
+import           XMonad
 
 import           Control.Monad                  ( when )
-import           Data.Bits                      ( setBit )
 import           Data.Foldable                  ( traverse_ )
 -- base
-import qualified Data.Map.Strict               as M
 import           Data.Semigroup                 ( All(..) )
-import           Data.Traversable               ( for )
 
 -- }}}
 
@@ -70,9 +67,8 @@ grabUngrab
   -> [(KeyMask, KeySym)] -- ^ Keys to ungrab
   -> X ()
 grabUngrab gr ugr = do
-  f <- mkGrabs
+  traverse_ (uncurry ungrabKP) =<< mkGrabs ugr
-  traverse_ (uncurry ungrabKP) (f ugr)
+  traverse_ (uncurry grabKP)   =<< mkGrabs gr
-  traverse_ (uncurry grabKP)   (f gr)
 
 -- | A convenience function to grab keys. This also ungrabs all
 -- previously grabbed keys.
@@ -88,49 +84,9 @@ customRegrabEvHook regr = \case
   e@MappingNotifyEvent{} -> do
     io (refreshKeyboardMapping e)
     when (ev_request e `elem` [mappingKeyboard, mappingModifier])
-      $  setNumlockMask
+      $  cacheNumlockMask
       >> regr
     pure (All False)
   _ -> pure (All True)
 
 -- }}}
-
--- --< Private Utils >-- {{{
-
--- | Private action shamelessly copied and restyled from XMonad.Main source.
-setNumlockMask :: X ()
-setNumlockMask = withDisplay $ \dpy -> do
-  ms <- io (getModifierMapping dpy)
-  xs <- sequence
-    [ do
-        ks <- io (keycodeToKeysym dpy kc 0)
-        pure $ if ks == xK_Num_Lock
-          then setBit 0 (fromIntegral m)
-          else 0 :: KeyMask
-    | (m, kcs) <- ms
-    , kc       <- kcs
-    , kc /= 0
-    ]
-  modify $ \s -> s { numberlockMask = foldr (.|.) 0 xs }
-
--- | Private function shamelessly copied and refactored from XMonad.Main source.
-mkGrabs :: X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
-mkGrabs = withDisplay $ \dpy -> do
-  let (minCode, maxCode) = displayKeycodes dpy
-      allCodes           = [fromIntegral minCode .. fromIntegral maxCode]
-  syms <- io . for allCodes $ \code -> keycodeToKeysym dpy code 0
-  let keysymMap = M.fromListWith (++) (zip syms $ pure <$> allCodes)
-      keysymToKeycodes sym = M.findWithDefault [] sym keysymMap
-  extraMods <- extraModifiers
-  pure $ \ks -> do
-    (mask, sym) <- ks
-    keycode     <- keysymToKeycodes sym
-    extraMod    <- extraMods
-    pure (mask .|. extraMod, keycode)
-
--- }}}
-
-
--- NOTE: there is some duplication between this module and core. The
--- latter probably will never change, but this needs to be kept in sync
--- with any potential bugs that might arise.

XMonad/Util/Hacks.hs

@@ -40,10 +40,14 @@ module XMonad.Util.Hacks (
   trayerPaddingXmobarEventHook,
   trayPaddingXmobarEventHook,
   trayPaddingEventHook,
+
+  -- * Steam flickering fix
+  fixSteamFlicker,
   ) where
 
 
 import XMonad
+import XMonad.Hooks.FloatConfigureReq (fixSteamFlicker)
 import XMonad.Hooks.StatusBar (xmonadPropLog')
 import XMonad.Prelude (All (All), fi, filterM, when)
 import System.Posix.Env (putEnv)

XMonad/Util/Rectangle.hs

@@ -67,7 +67,7 @@ data PointRectangle a = PointRectangle
 -- @[N,N+1]@, as though each real-valued coordinate had been rounded (either
 -- down or up) to the nearest integers. So each pixel, from zero, is listed as:
 -- @[0,0]@, @[1,1]@, @[2,2]@, and so on. Rather than a coordinate system, this
--- considers pixels as row/colum indices.  While easiest to reason with,
+-- considers pixels as row/column indices.  While easiest to reason with,
 -- indices are unable to represent zero-dimension rectangles.
 --
 -- Consider pixels as indices. Do not use this on empty rectangles.

scripts/build/build-with-cabal.sh

@@ -15,7 +15,7 @@ output="$1"
 
 if [ "$SRC_DIR" = "" ]; then
     # look for the config directory, fall back to the old one
-    SRC_DIR="${XMONAD_CONFIG_DIR:-${XDG_CONFIG_HOME:-$HOME/.config/xmonad}}"
+    SRC_DIR="${XMONAD_CONFIG_DIR:-${XDG_CONFIG_HOME:-$HOME/.config}/xmonad}"
     if test -f "$SRC_DIR/build"; then
 	:
     else

stack.yaml

@@ -8,7 +8,7 @@ packages:
 
 extra-deps:
 - X11-1.10.2
-- xmonad-0.17.0
+- xmonad-0.18.0
 
 nix:
   packages:

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/OrgMode.hs

@@ -45,7 +45,7 @@ spec = do
         `shouldBe` Just
           ( Deadline
               "todo"
-              (Time {date = Date (1, Nothing, Nothing), tod = Just $ TimeOfDay 1 1})
+              (Time {date = Date (1, Nothing, Nothing), tod = Just $ MomentInTime(HHMM 1 1)})
               NoPriority
           )
     it "works with todo +d 22 jan 2021 01:01 #b" $ do
@@ -53,9 +53,23 @@ spec = do
         `shouldBe` Just
           ( Deadline
                 "todo"
-                (Time {date = Date (22, Just 1, Just 2021), tod = Just $ TimeOfDay 1 1})
+                (Time {date = Date (22, Just 1, Just 2021), tod = Just $ MomentInTime(HHMM 1 1)})
                 B
           )
+    it "parses no day as today when given a time" $ do
+      pInput "todo +s 12:00"
+        `shouldBe` Just (Scheduled "todo" (Time {date = Today, tod = Just $ MomentInTime(HHMM 12 0)}) NoPriority)
+      pInput "todo +d 14:05 #B"
+        `shouldBe` Just (Deadline "todo" (Time {date = Today, tod = Just $ MomentInTime(HHMM 14 5)}) B)
+    it "parses `blah+d`, `blah +d`, `blah +d `, and `blah +d #B` as normal messages" $ do
+      pInput "blah+d"
+        `shouldBe` Just (NormalMsg "blah+d" NoPriority)
+      pInput "blah +d"
+        `shouldBe` Just (NormalMsg "blah +d" NoPriority)
+      pInput "blah +d "
+        `shouldBe` Just (NormalMsg "blah +d " NoPriority)
+      pInput "blah +d #B"
+        `shouldBe` Just (NormalMsg "blah +d" B)
 
   context "no priority#b" $ do
     it "parses to the correct thing" $
@@ -100,10 +114,10 @@ ppPrio = \case
   prio       -> " #" <> show prio
 
 ppTime :: Time -> String
-ppTime (Time d t) = ppDate d <> ppTOD t
+ppTime (Time d t) = ppDate d <> ppOrgTime t
  where
-  ppTOD :: Maybe TimeOfDay -> String
+  ppOrgTime :: Maybe OrgTime -> String
-  ppTOD = maybe "" ((' ' :) . show)
+  ppOrgTime = maybe "" ((' ' :) . show)
 
   ppDate :: Date -> String
   ppDate dte = case days !? dte of
@@ -179,7 +193,7 @@ instance Arbitrary Date where
     [ pure Today
     , pure Tomorrow
     , Next . toEnum <$> choose (0, 6)
-    , do d <- posInt
+    , do d <- posInt `suchThat` (<= 31)
          m <- mbPos `suchThat` (<= Just 12)
          Date . (d, m, ) <$> if   isNothing m
                              then pure Nothing
@@ -188,7 +202,14 @@ instance Arbitrary Date where
 
 instance Arbitrary TimeOfDay where
   arbitrary :: Gen TimeOfDay
-  arbitrary = TimeOfDay <$> hourInt <*> minuteInt
+  arbitrary = HHMM <$> hourInt <*> minuteInt
+
+instance Arbitrary OrgTime where
+  arbitrary :: Gen OrgTime
+  arbitrary = oneof
+    [ MomentInTime <$> arbitrary
+    , TimeSpan <$> arbitrary <*> arbitrary
+    ]
 
 ------------------------------------------------------------------------
 -- Util

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

@@ -1,5 +1,5 @@
 name:               xmonad-contrib
-version:            0.18.0
+version:            0.18.1
 -- ^ also update cpp-options: -DXMONAD_CONTRIB_VERSION_*
 
 homepage:           https://xmonad.org/
@@ -38,7 +38,7 @@ cabal-version:      1.12
 build-type:         Simple
 bug-reports:        https://github.com/xmonad/xmonad-contrib/issues
 
-tested-with:        GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.8 || == 9.4.8 || == 9.6.4 || == 9.8.1
+tested-with:        GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.8 || == 9.4.8 || == 9.6.6 || == 9.8.2 || == 9.10.1
 
 source-repository head
   type:     git
@@ -54,29 +54,30 @@ flag pedantic
   manual:      True
 
 library
-    build-depends: base >= 4.11 && < 5,
+    build-depends: base >= 4.12 && < 5,
                    bytestring >= 0.10 && < 0.13,
                    containers >= 0.5 && < 0.8,
                    directory,
                    filepath,
-                   time >= 1.8 && < 1.13,
+                   time >= 1.8 && < 1.15,
                    process,
                    random,
                    mtl >= 1 && < 3,
+                   transformers,
                    unix,
                    X11 >= 1.10 && < 1.11,
-                   xmonad >= 0.16.99999 && < 0.19,
+                   xmonad >= 0.18.0 && < 0.19,
                    utf8-string,
                    deepseq
     default-language: Haskell2010
 
     cpp-options:   -DXMONAD_CONTRIB_VERSION_MAJOR=0
                    -DXMONAD_CONTRIB_VERSION_MINOR=18
-                   -DXMONAD_CONTRIB_VERSION_PATCH=0
+                   -DXMONAD_CONTRIB_VERSION_PATCH=1
     ghc-options:   -Wall -Wno-unused-do-bind
 
     if flag(pedantic)
-       ghc-options: -Werror -Wwarn=deprecations -Wwarn=dodgy-imports
+       ghc-options: -Werror -Wwarn=deprecations
 
     -- Keep this in sync with the oldest version in 'tested-with'
     if impl(ghc > 8.6.5)
@@ -130,6 +131,7 @@ library
                         XMonad.Actions.PhysicalScreens
                         XMonad.Actions.Plane
                         XMonad.Actions.Prefix
+                        XMonad.Actions.Profiles
                         XMonad.Actions.Promote
                         XMonad.Actions.RandomBackground
                         XMonad.Actions.RepeatAction
@@ -191,6 +193,7 @@ library
                         XMonad.Hooks.EwmhDesktops
                         XMonad.Hooks.FadeInactive
                         XMonad.Hooks.FadeWindows
+                        XMonad.Hooks.FloatConfigureReq
                         XMonad.Hooks.FloatNext
                         XMonad.Hooks.Focus
                         XMonad.Hooks.InsertPosition
@@ -234,6 +237,7 @@ library
                         XMonad.Layout.Circle
                         XMonad.Layout.CircleEx
                         XMonad.Layout.Column
+                        XMonad.Layout.Columns
                         XMonad.Layout.Combo
                         XMonad.Layout.ComboP
                         XMonad.Layout.Cross
@@ -425,7 +429,9 @@ test-suite tests
                   RotateSome
                   Selective
                   SwapWorkspaces
+                  WindowNavigation
                   Utils
+                  XMonad.Actions.CopyWindow
                   XMonad.Actions.CycleRecentWS
                   XMonad.Actions.CycleWS
                   XMonad.Actions.FocusNth
@@ -437,10 +443,13 @@ test-suite tests
                   XMonad.Actions.SwapWorkspaces
                   XMonad.Actions.TagWindows
                   XMonad.Actions.WindowBringer
+                  XMonad.Actions.WindowGo
+                  XMonad.Actions.WindowNavigation
                   XMonad.Hooks.ManageDocks
                   XMonad.Hooks.ManageHelpers
                   XMonad.Hooks.UrgencyHook
                   XMonad.Hooks.WorkspaceHistory
+                  XMonad.Hooks.StatusBar.PP
                   XMonad.Layout.Decoration
                   XMonad.Layout.LayoutModifier
                   XMonad.Layout.LimitWindows
@@ -474,13 +483,13 @@ test-suite tests
                   XMonad.Util.XUtils
                   XPrompt
   hs-source-dirs: tests, .
-  build-depends: base
+  build-depends: base >= 4.12 && < 5
                , QuickCheck >= 2
                , X11 >= 1.10 && < 1.11
                , bytestring >= 0.10 && < 0.13
                , containers
                , directory
-               , time >= 1.8 && < 1.13
+               , time >= 1.8 && < 1.15
                , hspec >= 2.4.0 && < 3
                , mtl
                , random
@@ -494,7 +503,7 @@ test-suite tests
   default-language: Haskell2010
 
   if flag(pedantic)
-     ghc-options: -Werror -Wwarn=deprecations -Wwarn=dodgy-imports
+     ghc-options: -Werror -Wwarn=deprecations
 
   -- Keep this in sync with the oldest version in 'tested-with'
   if impl(ghc > 8.6.5)