{-# LANGUAGE NamedFieldPuns, GeneralizedNewtypeDeriving #-}
module XMonad.Actions.MostRecentlyUsed (
configureMRU,
mostRecentlyUsed,
withMostRecentlyUsed,
Location(..),
) where
import Data.List.NonEmpty (nonEmpty)
import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans (lift)
import Control.Monad.State (get, put, gets)
import qualified Data.Map.Strict as M
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
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
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)
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
mostRecentlyUsed
:: [KeySym]
-> KeySym
-> 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
withMostRecentlyUsed
:: [KeySym]
-> KeySym
-> (Window -> Location -> X ())
-> 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
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 }