{-# LANGUAGE NamedFieldPuns, GeneralizedNewtypeDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.MostRecentlyUsed
-- Description :  Tab through windows by recency of use.
-- Copyright   :  (c) 2022 L. S. Leary
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  @LSLeary (on github)
-- Stability   :  unstable
-- Portability :  unportable
--
-- Based on the Alt+Tab behaviour common outside of xmonad.
--
-----------------------------------------------------------------------------

-- --< Imports & Exports >-- {{{

module XMonad.Actions.MostRecentlyUsed (

  -- * Usage
  -- $usage

  -- * Interface
  configureMRU,
  mostRecentlyUsed,
  withMostRecentlyUsed,
  Location(..),

  ) where

-- base
import Data.Maybe (fromMaybe)
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import Data.Monoid (All(..), Any)
import Data.Foldable (for_)
import Data.Functor (($>))
import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef)
import Control.Applicative (liftA2)
import Control.Monad (when, unless, join)
import Control.Monad.IO.Class (MonadIO)

-- mtl
import Control.Monad.Trans (lift)
import Control.Monad.State (get, put, gets)

-- containers
import qualified Data.Map.Strict as M

-- xmonad
import XMonad
  ( Window, KeySym, keyPress, io
  , Event (DestroyWindowEvent, UnmapEvent, ev_send_event, ev_window)
  )
import XMonad.Core
  ( X, XConfig(..), windowset, WorkspaceId, ScreenId
  , ExtensionClass(..), StateExtension(..)
  , waitingUnmap
  )
import XMonad.Operations (screenWorkspace)
import qualified XMonad.StackSet as W

-- xmonad-contrib
import qualified XMonad.Util.ExtensibleConf  as XC
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Util.PureX
  (handlingRefresh, curScreenId, curTag, greedyView, view, peek, focusWindow)
import XMonad.Util.History (History, origin, event, erase, ledger)
import XMonad.Actions.Repeatable (repeatableSt)

-- }}}

-- --< Core Data Types: WindowHistory & Location >-- {{{

data WindowHistory = WinHist
  { WindowHistory -> Bool
busy :: !Bool
  , WindowHistory -> History Window Location
hist :: !(History Window Location)
  } deriving (Int -> WindowHistory -> ShowS
[WindowHistory] -> ShowS
WindowHistory -> WorkspaceId
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WindowHistory] -> ShowS
$cshowList :: [WindowHistory] -> ShowS
show :: WindowHistory -> WorkspaceId
$cshow :: WindowHistory -> WorkspaceId
showsPrec :: Int -> WindowHistory -> ShowS
$cshowsPrec :: Int -> WindowHistory -> ShowS
Show, ReadPrec [WindowHistory]
ReadPrec WindowHistory
Int -> ReadS WindowHistory
ReadS [WindowHistory]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WindowHistory]
$creadListPrec :: ReadPrec [WindowHistory]
readPrec :: ReadPrec WindowHistory
$creadPrec :: ReadPrec WindowHistory
readList :: ReadS [WindowHistory]
$creadList :: ReadS [WindowHistory]
readsPrec :: Int -> ReadS WindowHistory
$creadsPrec :: Int -> ReadS WindowHistory
Read)

instance ExtensionClass WindowHistory where
  initialValue :: WindowHistory
initialValue = WinHist
    { busy :: Bool
busy = Bool
False
    , hist :: History Window Location
hist = forall k a. History k a
origin
    }
  extensionType :: WindowHistory -> StateExtension
extensionType = forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

data Location = Location
  { Location -> WorkspaceId
workspace :: !WorkspaceId
  , Location -> ScreenId
screen    :: !ScreenId
  } deriving (Int -> Location -> ShowS
[Location] -> ShowS
Location -> WorkspaceId
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [Location] -> ShowS
$cshowList :: [Location] -> ShowS
show :: Location -> WorkspaceId
$cshow :: Location -> WorkspaceId
showsPrec :: Int -> Location -> ShowS
$cshowsPrec :: Int -> Location -> ShowS
Show, ReadPrec [Location]
ReadPrec Location
Int -> ReadS Location
ReadS [Location]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Location]
$creadListPrec :: ReadPrec [Location]
readPrec :: ReadPrec Location
$creadPrec :: ReadPrec Location
readList :: ReadS [Location]
$creadList :: ReadS [Location]
readsPrec :: Int -> ReadS Location
$creadsPrec :: Int -> ReadS Location
Read, Location -> Location -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c== :: Location -> Location -> Bool
Eq, Eq Location
Location -> Location -> Bool
Location -> Location -> Ordering
Location -> Location -> Location
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Location -> Location -> Location
$cmin :: Location -> Location -> Location
max :: Location -> Location -> Location
$cmax :: Location -> Location -> Location
>= :: Location -> Location -> Bool
$c>= :: Location -> Location -> Bool
> :: Location -> Location -> Bool
$c> :: Location -> Location -> Bool
<= :: Location -> Location -> Bool
$c<= :: Location -> Location -> Bool
< :: Location -> Location -> Bool
$c< :: Location -> Location -> Bool
compare :: Location -> Location -> Ordering
$ccompare :: Location -> Location -> Ordering
Ord)

-- }}}

-- --< Interface >-- {{{

-- $usage
--
-- 'configureMRU' must be applied to your config in order for 'mostRecentlyUsed'
-- to work.
--
-- > main :: IO ()
-- > main = xmonad . configureMRU . ... $ def
-- >   { ...
-- >   }
--
-- Once that's done, it can be used normally in keybinds:
--
-- > , ((mod1Mask, xK_Tab), mostRecentlyUsed [xK_Alt_L, xK_Alt_R] xK_Tab)
--
-- N.B.: This example assumes that 'mod1Mask' corresponds to alt, which is not
-- always the case, depending on how your system is configured.

-- | Configure xmonad to support 'mostRecentlyUsed'.
configureMRU :: XConfig l -> XConfig l
configureMRU :: forall (l :: * -> *). XConfig l -> XConfig l
configureMRU = forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
(XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
XC.once forall (l :: * -> *). XConfig l -> XConfig l
f (() -> MRU
MRU ()) where
  f :: XConfig l -> XConfig l
f XConfig l
cnf = XConfig l
cnf
    { logHook :: X ()
logHook         = forall (l :: * -> *). XConfig l -> X ()
logHook         XConfig l
cnf forall a. Semigroup a => a -> a -> a
<> X ()
logWinHist
    , handleEventHook :: Event -> X All
handleEventHook = forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig l
cnf forall a. Semigroup a => a -> a -> a
<> Event -> X All
winHistEH
    }
newtype MRU = MRU () deriving NonEmpty MRU -> MRU
MRU -> MRU -> MRU
forall b. Integral b => b -> MRU -> MRU
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> MRU -> MRU
$cstimes :: forall b. Integral b => b -> MRU -> MRU
sconcat :: NonEmpty MRU -> MRU
$csconcat :: NonEmpty MRU -> MRU
<> :: MRU -> MRU -> MRU
$c<> :: MRU -> MRU -> MRU
Semigroup

-- | An action to browse through the history of focused windows, taking
--   another step back with each tap of the key.
mostRecentlyUsed
  :: [KeySym] -- ^ The 'KeySym's corresponding to the modifier to which the
              --   action is bound.
  -> KeySym   -- ^ The 'KeySym' corresponding to the key to which the action
              --   is bound.
  -> X ()
mostRecentlyUsed :: [Window] -> Window -> X ()
mostRecentlyUsed [Window]
mods Window
key = do
  (X Any -> X ()
toUndo, X Any
undo) <- forall (m :: * -> *) a.
(MonadIO m, Monoid a) =>
m (m a -> m (), m a)
undoer
  let undoably :: X t -> (t -> X Any) -> t -> X ()
undoably X t
curThing t -> X Any
withThing t
thing = X t
curThing forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \t
cur ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (t
cur forall a. Eq a => a -> a -> Bool
/= t
thing) forall a b. (a -> b) -> a -> b
$ t -> X Any
withThing t
thing forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X Any -> X ()
toUndo (t -> X Any
withThing t
cur)
  [Window] -> Window -> (Window -> Location -> X ()) -> X ()
withMostRecentlyUsed [Window]
mods Window
key forall a b. (a -> b) -> a -> b
$ \Window
win Location{WorkspaceId
workspace :: WorkspaceId
workspace :: Location -> WorkspaceId
workspace,ScreenId
screen :: ScreenId
screen :: Location -> ScreenId
screen} ->
    X () -> X ()
handlingRefresh forall a b. (a -> b) -> a -> b
$ do
      X Any
undo
      forall {t}. Eq t => X t -> (t -> X Any) -> t -> X ()
undoably forall (m :: * -> *). XLike m => m ScreenId
curScreenId ScreenId -> X Any
viewScreen ScreenId
screen
      forall {t}. Eq t => X t -> (t -> X Any) -> t -> X ()
undoably forall (m :: * -> *). XLike m => m WorkspaceId
curTag      forall (m :: * -> *). XLike m => WorkspaceId -> m Any
greedyView WorkspaceId
workspace
      Maybe WorkspaceId
mi <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Maybe i
W.findTag Window
win forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe WorkspaceId
mi forall a b. (a -> b) -> a -> b
$ \WorkspaceId
i -> do
        forall {t}. Eq t => X t -> (t -> X Any) -> t -> X ()
undoably forall (m :: * -> *). XLike m => m WorkspaceId
curTag forall (m :: * -> *). XLike m => WorkspaceId -> m Any
greedyView WorkspaceId
i
        Maybe Window
mfw <- forall (m :: * -> *). XLike m => m (Maybe Window)
peek
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Window
mfw forall a b. (a -> b) -> a -> b
$ \Window
fw -> do
          forall {t}. Eq t => X t -> (t -> X Any) -> t -> X ()
undoably (forall (f :: * -> *) a. Applicative f => a -> f a
pure Window
fw) forall (m :: * -> *). XLike m => Window -> m Any
focusWindow Window
win
  where
    undoer :: (MonadIO m, Monoid a) => m (m a -> m (), m a)
    undoer :: forall (m :: * -> *) a.
(MonadIO m, Monoid a) =>
m (m a -> m (), m a)
undoer = do
      IORef (m a)
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
      let toUndo :: m a -> m ()
toUndo = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (m a)
ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>)
          undo :: m a
undo   = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (m a)
ref)
                forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (forall a. IORef a -> a -> IO ()
writeIORef IORef (m a)
ref forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (m a -> m ()
toUndo, m a
undo)
    viewScreen :: ScreenId -> X Any
    viewScreen :: ScreenId -> X Any
viewScreen ScreenId
scr = ScreenId -> X (Maybe WorkspaceId)
screenWorkspace ScreenId
scr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (m :: * -> *). XLike m => WorkspaceId -> m Any
view

-- | A version of 'mostRecentlyUsed' that allows you to customise exactly what
--   is done with each window you tab through (the default being to visit its
--   previous 'Location' and give it focus).
withMostRecentlyUsed
  :: [KeySym]                     -- ^ The 'KeySym's corresponding to the
                                  --   modifier to which the action is bound.
  -> KeySym                       -- ^ The 'KeySym' corresponding to the key to
                                  --   which the action is bound.
  -> (Window -> Location -> X ()) -- ^ The function applied to each window.
  -> X ()
withMostRecentlyUsed :: [Window] -> Window -> (Window -> Location -> X ()) -> X ()
withMostRecentlyUsed [Window]
mods Window
tab Window -> Location -> X ()
preview = do
  wh :: WindowHistory
wh@WinHist{Bool
busy :: Bool
busy :: WindowHistory -> Bool
busy,History Window Location
hist :: History Window Location
hist :: WindowHistory -> History Window Location
hist} <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
busy forall a b. (a -> b) -> a -> b
$ do
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put WindowHistory
wh{ busy :: Bool
busy = Bool
True }

    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall a b. (a -> b) -> a -> b
$ forall k a. History k a -> [(k, a)]
ledger History Window Location
hist) forall a b. (a -> b) -> a -> b
$ \NonEmpty (Window, Location)
ne -> do
      Maybe Window
mfw <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
      let iSt :: Stream (Window, Location)
iSt = case forall a. NonEmpty a -> Stream a
cycleS NonEmpty (Window, Location)
ne of
            (Window
w, Location
_) :~ Stream (Window, Location)
s | Maybe Window
mfw forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Window
w -> Stream (Window, Location)
s
            Stream (Window, Location)
s                           -> Stream (Window, Location)
s
      forall a s.
Monoid a =>
s
-> [Window]
-> Window
-> (EventType -> Window -> StateT s X a)
-> X (a, s)
repeatableSt Stream (Window, Location)
iSt [Window]
mods Window
tab forall a b. (a -> b) -> a -> b
$ \EventType
t Window
s ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventType
t forall a. Eq a => a -> a -> Bool
== EventType
keyPress Bool -> Bool -> Bool
&& Window
s forall a. Eq a => a -> a -> Bool
== Window
tab) (StateT (Stream (Window, Location)) X (Window, Location)
pop forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Window -> Location -> X ()
preview)

    forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall a b. (a -> b) -> a -> b
$ \ws :: WindowHistory
ws@WinHist{} -> WindowHistory
ws{ busy :: Bool
busy = Bool
False }
    X ()
logWinHist
  where
    pop :: StateT (Stream (Window, Location)) X (Window, Location)
pop = do
      (Window, Location)
h :~ Stream (Window, Location)
t <- forall s (m :: * -> *). MonadState s m => m s
get
      forall s (m :: * -> *). MonadState s m => s -> m ()
put Stream (Window, Location)
t forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Window, Location)
h

-- }}}

-- --< Raw Config >-- {{{

logWinHist :: X ()
logWinHist :: X ()
logWinHist = do
  wh :: WindowHistory
wh@WinHist{Bool
busy :: Bool
busy :: WindowHistory -> Bool
busy,History Window Location
hist :: History Window Location
hist :: WindowHistory -> History Window Location
hist} <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
busy forall a b. (a -> b) -> a -> b
$ do
    Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
cs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
    let cws :: Workspace WorkspaceId (Layout Window) Window
cws = forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
cs
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack Workspace WorkspaceId (Layout Window) Window
cws) forall a b. (a -> b) -> a -> b
$ \Stack Window
st -> do
      let location :: Location
location = Location{ workspace :: WorkspaceId
workspace = forall i l a. Workspace i l a -> i
W.tag Workspace WorkspaceId (Layout Window) Window
cws, screen :: ScreenId
screen = forall i l a sid sd. Screen i l a sid sd -> sid
W.screen Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
cs }
      forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put WindowHistory
wh{ hist :: History Window Location
hist = forall k a. Ord k => k -> a -> History k a -> History k a
event (forall a. Stack a -> a
W.focus Stack Window
st) Location
location History Window Location
hist }

winHistEH :: Event -> X All
winHistEH :: Event -> X All
winHistEH Event
ev = Bool -> All
All Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case Event
ev of
  UnmapEvent{ ev_send_event :: Event -> Bool
ev_send_event = Bool
synth, ev_window :: Event -> Window
ev_window = Window
w } -> do
    Int
e <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. a -> Maybe a -> a
fromMaybe Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> Map Window Int
waitingUnmap)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
synth Bool -> Bool -> Bool
|| Int
e forall a. Eq a => a -> a -> Bool
== Int
0) (forall {m :: * -> *}. XLike m => Window -> m ()
collect Window
w)
  DestroyWindowEvent{                ev_window :: Event -> Window
ev_window = Window
w } -> forall {m :: * -> *}. XLike m => Window -> m ()
collect Window
w
  Event
_                                                  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where collect :: Window -> m ()
collect Window
w = forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall a b. (a -> b) -> a -> b
$ \wh :: WindowHistory
wh@WinHist{History Window Location
hist :: History Window Location
hist :: WindowHistory -> History Window Location
hist} -> WindowHistory
wh{ hist :: History Window Location
hist = forall k a. Ord k => k -> History k a -> History k a
erase Window
w History Window Location
hist }

-- }}}

-- --< Auxiliary Data Type: Stream >-- {{{

-- To satisfy the almighty exhaustivity checker.

data Stream a = !a :~ Stream a
infixr 5 :~

(+~) :: [a] -> Stream a -> Stream a
[a]
xs +~ :: forall a. [a] -> Stream a -> Stream a
+~ Stream a
s = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. a -> Stream a -> Stream a
(:~) Stream a
s [a]
xs
infixr 5 +~

cycleS :: NonEmpty a -> Stream a
cycleS :: forall a. NonEmpty a -> Stream a
cycleS (a
x :| [a]
xs) = Stream a
s where s :: Stream a
s = a
x forall a. a -> Stream a -> Stream a
:~ [a]
xs forall a. [a] -> Stream a -> Stream a
+~ Stream a
s

-- }}}