{-# LANGUAGE ViewPatterns #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.RotateSome
-- Description :  Rotate some elements around the stack.
-- Copyright   :  (c) 2020 Ivan Brennan <ivanbrennan@gmail.com>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Ivan Brennan <ivanbrennan@gmail.com>
-- Stability   :  stable
-- Portability :  unportable
--
-- Functions for rotating some elements around the stack while keeping others
-- anchored in place. Useful in combination with layouts that dictate window
-- visibility based on stack position, such as "XMonad.Layout.LimitWindows".
--
-----------------------------------------------------------------------------

module XMonad.Actions.RotateSome (
    -- * Usage
    -- $usage
    -- * Example
    -- $example
    surfaceNext,
    surfacePrev,
    rotateSome,
  ) where

import Control.Arrow ((***))
import XMonad.Prelude (NonEmpty(..), notEmpty, partition, sortOn, (\\))
import qualified Data.Map as M
import XMonad (Window, WindowSpace, Rectangle, X, runLayout, screenRect, windows, withWindowSet)
import XMonad.StackSet (Screen (Screen), Stack (Stack), current, floating, modify', stack)
import XMonad.Util.Stack (reverseS)

{- $usage
You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:

> import XMonad.Actions.RotateSome

and add keybindings such as the following:

>   , ((modMask .|. controlMask, xK_n), surfaceNext)
>   , ((modMask .|. controlMask, xK_p), surfacePrev)

-}

{- $example
#Example#

Consider a workspace whose stack contains five windows A B C D E but whose
layout limits how many will actually be shown, showing only the first plus
two additional windows, starting with the third:

>  ┌─────┬─────┐
>  │     │  C  │
>  │  A  ├─────┤
>  │     │  D  │
>  └─────┴─────┘
>
>  A  B  C  D  E
>  _     ____

If C has focus and we'd like to replace it with one of the unshown windows,
'surfaceNext' will move the next unshown window, E, into the focused position:

>  ┌─────┬─────┐                ┌─────┬─────┐
>  │     │ *C* │                │     │ *E* │
>  │  A  ├─────┤ surfaceNext -> │  A  ├─────┤
>  │     │  D  │                │     │  D  │
>  └─────┴─────┘                └─────┴─────┘
>
>  A  B *C* D  E                A  C *E* D  B
>  _     ____                   _     ____

This repositioned windows B C E by treating them as a sequence that can be
rotated through the focused stack position. Windows A and D remain anchored
to their original (visible) positions.

A second call to 'surfaceNext' moves B into focus:

>  ┌─────┬─────┐                ┌─────┬─────┐
>  │     │ *E* │                │     │ *B* │
>  │  A  ├─────┤ surfaceNext -> │  A  ├─────┤
>  │     │  D  │                │     │  D  │
>  └─────┴─────┘                └─────┴─────┘
>
>  A  C *E* D  B                A  E *B* D  C
>  _     ____                   _     ____

A third call would complete the cycle, bringing C back into focus.

-}

-- |
-- Treating the focused window and any unshown windows as a ring that can be
-- rotated through the focused position, surface the next element in the ring.
surfaceNext :: X ()
surfaceNext :: X ()
surfaceNext = do
  [Window]
ring <- X [Window]
surfaceRing
  (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> ((Stack Window -> Stack Window) -> WindowSet -> WindowSet)
-> (Stack Window -> Stack Window)
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stack Window -> Stack Window) -> WindowSet -> WindowSet
forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
modify' ((Stack Window -> Stack Window) -> X ())
-> (Stack Window -> Stack Window) -> X ()
forall a b. (a -> b) -> a -> b
$ (Window -> Bool) -> Stack Window -> Stack Window
forall a. (a -> Bool) -> Stack a -> Stack a
rotateSome (Window -> [Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
ring)

-- | Like 'surfaceNext' in reverse.
surfacePrev :: X ()
surfacePrev :: X ()
surfacePrev = do
  [Window]
ring <- X [Window]
surfaceRing
  (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> ((Stack Window -> Stack Window) -> WindowSet -> WindowSet)
-> (Stack Window -> Stack Window)
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stack Window -> Stack Window) -> WindowSet -> WindowSet
forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
modify' ((Stack Window -> Stack Window) -> X ())
-> (Stack Window -> Stack Window) -> X ()
forall a b. (a -> b) -> a -> b
$ Stack Window -> Stack Window
forall a. Stack a -> Stack a
reverseS (Stack Window -> Stack Window)
-> (Stack Window -> Stack Window) -> Stack Window -> Stack Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window -> Bool) -> Stack Window -> Stack Window
forall a. (a -> Bool) -> Stack a -> Stack a
rotateSome (Window -> [Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
ring) (Stack Window -> Stack Window)
-> (Stack Window -> Stack Window) -> Stack Window -> Stack Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack Window -> Stack Window
forall a. Stack a -> Stack a
reverseS

-- |
-- Return a list containing the current focus plus any unshown windows. Note
-- that windows are shown if 'runLayout' provides them with a rectangle or if
-- they are floating.
surfaceRing :: X [Window]
surfaceRing :: X [Window]
surfaceRing = (WindowSet -> X [Window]) -> X [Window]
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X [Window]) -> X [Window])
-> (WindowSet -> X [Window]) -> X [Window]
forall a b. (a -> b) -> a -> b
$ \WindowSet
wset -> do
  let Screen Workspace WorkspaceId (Layout Window) Window
wsp ScreenId
_ ScreenDetail
sd = WindowSet
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current WindowSet
wset

  case Workspace WorkspaceId (Layout Window) Window
-> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
stack Workspace WorkspaceId (Layout Window) Window
wsp Maybe (Stack Window)
-> (Stack Window -> Maybe (Stack Window)) -> Maybe (Stack Window)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Window -> Bool) -> Stack Window -> Maybe (Stack Window)
forall a. (a -> Bool) -> Stack a -> Maybe (Stack a)
filter' (Window -> Map Window RationalRect -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` WindowSet -> Map Window RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
floating WindowSet
wset) of
    Maybe (Stack Window)
Nothing -> [Window] -> X [Window]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just Stack Window
st -> Stack Window -> [Window] -> [Window]
go Stack Window
st ([Window] -> [Window]) -> X [Window] -> X [Window]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Workspace WorkspaceId (Layout Window) Window
-> Rectangle -> X [Window]
layoutWindows Workspace WorkspaceId (Layout Window) Window
wsp {stack :: Maybe (Stack Window)
stack = Stack Window -> Maybe (Stack Window)
forall a. a -> Maybe a
Just Stack Window
st} (ScreenDetail -> Rectangle
screenRect ScreenDetail
sd)
  where
    go :: Stack Window -> [Window] -> [Window]
    go :: Stack Window -> [Window] -> [Window]
go (Stack Window
t [Window]
ls [Window]
rs) [Window]
shown = Window
t Window -> [Window] -> [Window]
forall a. a -> [a] -> [a]
: (([Window]
ls [Window] -> [Window] -> [Window]
forall a. [a] -> [a] -> [a]
++ [Window]
rs) [Window] -> [Window] -> [Window]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Window]
shown)

    layoutWindows :: WindowSpace -> Rectangle -> X [Window]
    layoutWindows :: Workspace WorkspaceId (Layout Window) Window
-> Rectangle -> X [Window]
layoutWindows Workspace WorkspaceId (Layout Window) Window
wsp Rectangle
rect = ((Window, Rectangle) -> Window)
-> [(Window, Rectangle)] -> [Window]
forall a b. (a -> b) -> [a] -> [b]
map (Window, Rectangle) -> Window
forall a b. (a, b) -> a
fst ([(Window, Rectangle)] -> [Window])
-> (([(Window, Rectangle)], Maybe (Layout Window))
    -> [(Window, Rectangle)])
-> ([(Window, Rectangle)], Maybe (Layout Window))
-> [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Window, Rectangle)], Maybe (Layout Window))
-> [(Window, Rectangle)]
forall a b. (a, b) -> a
fst (([(Window, Rectangle)], Maybe (Layout Window)) -> [Window])
-> X ([(Window, Rectangle)], Maybe (Layout Window)) -> X [Window]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Workspace WorkspaceId (Layout Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (Layout Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace WorkspaceId (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace WorkspaceId (Layout Window) Window
wsp Rectangle
rect

-- | Like "XMonad.StackSet.filter" but won't move focus.
filter' :: (a -> Bool) -> Stack a -> Maybe (Stack a)
filter' :: forall a. (a -> Bool) -> Stack a -> Maybe (Stack a)
filter' a -> Bool
p (Stack a
f [a]
ls [a]
rs)
  | a -> Bool
p a
f       = Stack a -> Maybe (Stack a)
forall a. a -> Maybe a
Just (Stack a -> Maybe (Stack a)) -> Stack a -> Maybe (Stack a)
forall a b. (a -> b) -> a -> b
$ a -> [a] -> [a] -> Stack a
forall a. a -> [a] -> [a] -> Stack a
Stack a
f ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
p [a]
ls) ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
p [a]
rs)
  | Bool
otherwise = Maybe (Stack a)
forall a. Maybe a
Nothing

-- |
-- @'rotateSome' p stack@ treats the elements of @stack@ that satisfy predicate
-- @p@ as a ring that can be rotated, while all other elements remain anchored
-- in place.
rotateSome :: (a -> Bool) -> Stack a -> Stack a
rotateSome :: forall a. (a -> Bool) -> Stack a -> Stack a
rotateSome a -> Bool
p (Stack a
t [a]
ls [a]
rs) =
  let
    -- Flatten the stack, index each element relative to the focused position,
    -- then partition into movable and anchored elements.
    ([(Int, a)]
movables, [(Int, a)]
anchors) =
      ((Int, a) -> Bool) -> [(Int, a)] -> ([(Int, a)], [(Int, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (a -> Bool
p (a -> Bool) -> ((Int, a) -> a) -> (Int, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> a
forall a b. (a, b) -> b
snd) ([(Int, a)] -> ([(Int, a)], [(Int, a)]))
-> [(Int, a)] -> ([(Int, a)], [(Int, a)])
forall a b. (a -> b) -> a -> b
$
        [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip
          [Int -> Int
forall a. Num a => a -> a
negate ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls)..]
          ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
ls [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a
t a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rs)

    -- Pair each movable element with the index of its next movable neighbor.
    -- Append anchored elements, along with their unchanged indices, and sort
    -- by index. Separate lefts (negative indices) from the rest, and grab the
    -- new focus from the head of the remaining elements.
    ([a]
ls', [a] -> NonEmpty a
forall a. HasCallStack => [a] -> NonEmpty a
notEmpty -> a
t' :| [a]
rs') =
      (((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> a
forall a b. (a, b) -> b
snd ([(Int, a)] -> [a])
-> ([(Int, a)] -> [a]) -> ([(Int, a)], [(Int, a)]) -> ([a], [a])
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> a
forall a b. (a, b) -> b
snd)
        (([(Int, a)], [(Int, a)]) -> ([a], [a]))
-> ([(Int, a)] -> ([(Int, a)], [(Int, a)]))
-> [(Int, a)]
-> ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> Bool) -> [(Int, a)] -> ([(Int, a)], [(Int, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (Int -> Bool) -> ((Int, a) -> Int) -> (Int, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> Int
forall a b. (a, b) -> a
fst)
        ([(Int, a)] -> ([(Int, a)], [(Int, a)]))
-> ([(Int, a)] -> [(Int, a)])
-> [(Int, a)]
-> ([(Int, a)], [(Int, a)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> Int) -> [(Int, a)] -> [(Int, a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, a) -> Int
forall a b. (a, b) -> a
fst
        ([(Int, a)] -> [(Int, a)])
-> ([(Int, a)] -> [(Int, a)]) -> [(Int, a)] -> [(Int, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, a)] -> [(Int, a)] -> [(Int, a)]
forall a. [a] -> [a] -> [a]
(++) [(Int, a)]
anchors
        ([(Int, a)] -> ([a], [a])) -> [(Int, a)] -> ([a], [a])
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> (Int, a) -> (Int, a))
-> [(Int, a)] -> [(Int, a)] -> [(Int, a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((((Int, a), (Int, a)) -> (Int, a))
-> (Int, a) -> (Int, a) -> (Int, a)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry ((Int, a) -> Int
forall a b. (a, b) -> a
fst ((Int, a) -> Int)
-> ((Int, a) -> a) -> ((Int, a), (Int, a)) -> (Int, a)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Int, a) -> a
forall a b. (a, b) -> b
snd)) [(Int, a)]
movables ([(Int, a)] -> [(Int, a)]
forall a. [a] -> [a]
rotate [(Int, a)]
movables)
  in
    a -> [a] -> [a] -> Stack a
forall a. a -> [a] -> [a] -> Stack a
Stack a
t' ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
ls') [a]
rs'

rotate :: [a] -> [a]
rotate :: forall a. [a] -> [a]
rotate = ([a] -> [a] -> [a]) -> ([a], [a]) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (([a] -> [a] -> [a]) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)) (([a], [a]) -> [a]) -> ([a] -> ([a], [a])) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1