{-# 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
(Int -> WindowHistory -> ShowS)
-> (WindowHistory -> WorkspaceId)
-> ([WindowHistory] -> ShowS)
-> Show WindowHistory
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WindowHistory -> ShowS
showsPrec :: Int -> WindowHistory -> ShowS
$cshow :: WindowHistory -> WorkspaceId
show :: WindowHistory -> WorkspaceId
$cshowList :: [WindowHistory] -> ShowS
showList :: [WindowHistory] -> ShowS
Show, ReadPrec [WindowHistory]
ReadPrec WindowHistory
Int -> ReadS WindowHistory
ReadS [WindowHistory]
(Int -> ReadS WindowHistory)
-> ReadS [WindowHistory]
-> ReadPrec WindowHistory
-> ReadPrec [WindowHistory]
-> Read WindowHistory
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS WindowHistory
readsPrec :: Int -> ReadS WindowHistory
$creadList :: ReadS [WindowHistory]
readList :: ReadS [WindowHistory]
$creadPrec :: ReadPrec WindowHistory
readPrec :: ReadPrec WindowHistory
$creadListPrec :: ReadPrec [WindowHistory]
readListPrec :: ReadPrec [WindowHistory]
Read)
instance ExtensionClass WindowHistory where
initialValue :: WindowHistory
initialValue = WinHist
{ busy :: Bool
busy = Bool
False
, hist :: History Window Location
hist = History Window Location
forall k a. History k a
origin
}
extensionType :: WindowHistory -> StateExtension
extensionType = WindowHistory -> StateExtension
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
(Int -> Location -> ShowS)
-> (Location -> WorkspaceId)
-> ([Location] -> ShowS)
-> Show Location
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Location -> ShowS
showsPrec :: Int -> Location -> ShowS
$cshow :: Location -> WorkspaceId
show :: Location -> WorkspaceId
$cshowList :: [Location] -> ShowS
showList :: [Location] -> ShowS
Show, ReadPrec [Location]
ReadPrec Location
Int -> ReadS Location
ReadS [Location]
(Int -> ReadS Location)
-> ReadS [Location]
-> ReadPrec Location
-> ReadPrec [Location]
-> Read Location
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Location
readsPrec :: Int -> ReadS Location
$creadList :: ReadS [Location]
readList :: ReadS [Location]
$creadPrec :: ReadPrec Location
readPrec :: ReadPrec Location
$creadListPrec :: ReadPrec [Location]
readListPrec :: ReadPrec [Location]
Read, Location -> Location -> Bool
(Location -> Location -> Bool)
-> (Location -> Location -> Bool) -> Eq Location
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
/= :: Location -> Location -> Bool
Eq, Eq Location
Eq Location =>
(Location -> Location -> Ordering)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Location)
-> (Location -> Location -> Location)
-> Ord 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
$ccompare :: Location -> Location -> Ordering
compare :: Location -> Location -> Ordering
$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
>= :: Location -> Location -> Bool
$cmax :: Location -> Location -> Location
max :: Location -> Location -> Location
$cmin :: Location -> Location -> Location
min :: Location -> Location -> Location
Ord)
configureMRU :: XConfig l -> XConfig l
configureMRU :: forall (l :: * -> *). XConfig l -> XConfig l
configureMRU = (XConfig l -> XConfig l) -> MRU -> XConfig l -> XConfig l
forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
(XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
XC.once XConfig l -> XConfig l
forall (l :: * -> *). XConfig l -> XConfig l
f (() -> MRU
MRU ()) where
f :: XConfig l -> XConfig l
f XConfig l
cnf = XConfig l
cnf
{ logHook = logHook cnf <> logWinHist
, handleEventHook = handleEventHook cnf <> winHistEH
}
newtype MRU = MRU () deriving NonEmpty MRU -> MRU
MRU -> MRU -> MRU
(MRU -> MRU -> MRU)
-> (NonEmpty MRU -> MRU)
-> (forall b. Integral b => b -> MRU -> MRU)
-> Semigroup 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
$c<> :: MRU -> MRU -> MRU
<> :: MRU -> MRU -> MRU
$csconcat :: NonEmpty MRU -> MRU
sconcat :: NonEmpty MRU -> MRU
$cstimes :: forall b. Integral b => b -> MRU -> MRU
stimes :: forall b. Integral b => b -> MRU -> MRU
Semigroup
mostRecentlyUsed
:: [KeySym]
-> KeySym
-> X ()
mostRecentlyUsed :: [Window] -> Window -> X ()
mostRecentlyUsed [Window]
mods Window
key = do
(toUndo, undo) <- X (X Any -> X (), X Any)
forall (m :: * -> *) a.
(MonadIO m, Monoid a) =>
m (m a -> m (), m a)
undoer
let undoably X t
curThing t -> X Any
withThing t
thing = X t
curThing X t -> (t -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \t
cur ->
Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (t
cur t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
thing) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ t -> X Any
withThing t
thing X Any -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X Any -> X ()
toUndo (t -> X Any
withThing t
cur)
withMostRecentlyUsed mods key $ \Window
win Location{WorkspaceId
workspace :: Location -> WorkspaceId
workspace :: WorkspaceId
workspace,ScreenId
screen :: Location -> ScreenId
screen :: ScreenId
screen} ->
X () -> X ()
handlingRefresh (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
X Any
undo
X ScreenId -> (ScreenId -> X Any) -> ScreenId -> X ()
forall {t}. Eq t => X t -> (t -> X Any) -> t -> X ()
undoably X ScreenId
forall (m :: * -> *). XLike m => m ScreenId
curScreenId ScreenId -> X Any
viewScreen ScreenId
screen
X WorkspaceId -> (WorkspaceId -> X Any) -> WorkspaceId -> X ()
forall {t}. Eq t => X t -> (t -> X Any) -> t -> X ()
undoably X WorkspaceId
forall (m :: * -> *). XLike m => m WorkspaceId
curTag WorkspaceId -> X Any
forall (m :: * -> *). XLike m => WorkspaceId -> m Any
greedyView WorkspaceId
workspace
mi <- (XState -> Maybe WorkspaceId) -> X (Maybe WorkspaceId)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Window
-> StackSet
WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Maybe WorkspaceId
forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Maybe i
W.findTag Window
win (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Maybe WorkspaceId)
-> (XState
-> StackSet
WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Maybe WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
WorkspaceId (Layout Window) Window ScreenId ScreenDetail
windowset)
for_ mi $ \WorkspaceId
i -> do
X WorkspaceId -> (WorkspaceId -> X Any) -> WorkspaceId -> X ()
forall {t}. Eq t => X t -> (t -> X Any) -> t -> X ()
undoably X WorkspaceId
forall (m :: * -> *). XLike m => m WorkspaceId
curTag WorkspaceId -> X Any
forall (m :: * -> *). XLike m => WorkspaceId -> m Any
greedyView WorkspaceId
i
mfw <- X (Maybe Window)
forall (m :: * -> *). XLike m => m (Maybe Window)
peek
for_ mfw $ \Window
fw -> do
X Window -> (Window -> X Any) -> Window -> X ()
forall {t}. Eq t => X t -> (t -> X Any) -> t -> X ()
undoably (Window -> X Window
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Window
fw) Window -> X Any
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
ref <- IO (IORef (m a)) -> m (IORef (m a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (IORef (m a)) -> m (IORef (m a)))
-> (m a -> IO (IORef (m a))) -> m a -> m (IORef (m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> IO (IORef (m a))
forall a. a -> IO (IORef a)
newIORef (m a -> m (IORef (m a))) -> m a -> m (IORef (m a))
forall a b. (a -> b) -> a -> b
$ a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
let toUndo = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> (m a -> IO ()) -> m a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (m a) -> (m a -> m a) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (m a)
ref ((m a -> m a) -> IO ()) -> (m a -> m a -> m a) -> m a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a) -> m a -> m a -> m a
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)
undo = m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (m a) -> m (m a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (m a) -> m (m a)) -> IO (m a) -> m (m a)
forall a b. (a -> b) -> a -> b
$ IORef (m a) -> IO (m a)
forall a. IORef a -> IO a
readIORef IORef (m a)
ref)
m a -> m () -> m a
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IORef (m a) -> m a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (m a)
ref (m a -> IO ()) -> m a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty)
pure (toUndo, undo)
viewScreen :: ScreenId -> X Any
viewScreen :: ScreenId -> X Any
viewScreen ScreenId
scr = ScreenId -> X (Maybe WorkspaceId)
screenWorkspace ScreenId
scr X (Maybe WorkspaceId) -> (Maybe WorkspaceId -> X Any) -> X Any
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (WorkspaceId -> X Any) -> Maybe WorkspaceId -> X Any
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap WorkspaceId -> X Any
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@WinHist{busy,hist} <- X WindowHistory
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
unless busy $ do
XS.put wh{ busy = True }
for_ (nonEmpty $ ledger hist) $ \NonEmpty (Window, Location)
ne -> do
mfw <- (XState -> Maybe Window) -> X (Maybe Window)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Maybe Window
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Maybe Window)
-> (XState
-> StackSet
WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Maybe Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
WorkspaceId (Layout Window) Window ScreenId ScreenDetail
windowset)
let iSt = case NonEmpty (Window, Location) -> Stream (Window, Location)
forall a. NonEmpty a -> Stream a
cycleS NonEmpty (Window, Location)
ne of
(Window
w, Location
_) :~ Stream (Window, Location)
s | Maybe Window
mfw Maybe Window -> Maybe Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window -> Maybe Window
forall a. a -> Maybe a
Just Window
w -> Stream (Window, Location)
s
Stream (Window, Location)
s -> Stream (Window, Location)
s
repeatableSt iSt mods tab $ \EventType
t Window
s ->
Bool
-> StateT (Stream (Window, Location)) X ()
-> StateT (Stream (Window, Location)) X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
keyPress Bool -> Bool -> Bool
&& Window
s Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
tab) (StateT (Stream (Window, Location)) X (Window, Location)
pop StateT (Stream (Window, Location)) X (Window, Location)
-> ((Window, Location) -> StateT (Stream (Window, Location)) X ())
-> StateT (Stream (Window, Location)) X ()
forall a b.
StateT (Stream (Window, Location)) X a
-> (a -> StateT (Stream (Window, Location)) X b)
-> StateT (Stream (Window, Location)) X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= X () -> StateT (Stream (Window, Location)) X ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Stream (Window, Location)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (X () -> StateT (Stream (Window, Location)) X ())
-> ((Window, Location) -> X ())
-> (Window, Location)
-> StateT (Stream (Window, Location)) X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window -> Location -> X ()) -> (Window, Location) -> X ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Window -> Location -> X ()
preview)
XS.modify $ \ws :: WindowHistory
ws@WinHist{} -> WindowHistory
ws{ busy = False }
logWinHist
where
pop :: StateT (Stream (Window, Location)) X (Window, Location)
pop = do
h :~ t <- StateT (Stream (Window, Location)) X (Stream (Window, Location))
forall s (m :: * -> *). MonadState s m => m s
get
put t $> h
logWinHist :: X ()
logWinHist :: X ()
logWinHist = do
wh@WinHist{busy,hist} <- X WindowHistory
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
unless busy $ do
cs <- gets (W.current . windowset)
let cws = Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Window) Window
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
for_ (W.stack cws) $ \Stack Window
st -> do
let location :: Location
location = Location{ workspace :: WorkspaceId
workspace = Workspace WorkspaceId (Layout Window) Window -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag Workspace WorkspaceId (Layout Window) Window
cws, screen :: ScreenId
screen = Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
cs }
WindowHistory -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put WindowHistory
wh{ hist = event (W.focus st) location hist }
winHistEH :: Event -> X All
winHistEH :: Event -> X All
winHistEH Event
ev = Bool -> All
All Bool
True All -> X () -> X All
forall a b. a -> X b -> X a
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
e <- (XState -> Int) -> X Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (XState -> Maybe Int) -> XState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> Map Window Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
w (Map Window Int -> Maybe Int)
-> (XState -> Map Window Int) -> XState -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> Map Window Int
waitingUnmap)
when (synth || e == 0) (collect w)
DestroyWindowEvent{ ev_window :: Event -> Window
ev_window = Window
w } -> Window -> X ()
forall {m :: * -> *}. XLike m => Window -> m ()
collect Window
w
Event
_ -> () -> X ()
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where collect :: Window -> m ()
collect Window
w = (WindowHistory -> WindowHistory) -> m ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((WindowHistory -> WindowHistory) -> m ())
-> (WindowHistory -> WindowHistory) -> m ()
forall a b. (a -> b) -> a -> b
$ \wh :: WindowHistory
wh@WinHist{History Window Location
hist :: WindowHistory -> History Window Location
hist :: History Window Location
hist} -> WindowHistory
wh{ hist = erase w hist }