{-# 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.List.NonEmpty (nonEmpty)
import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef)
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)
import XMonad.Prelude

-- }}}

-- --< 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 }

-- }}}