-- |
-- Module      :  XMonad.Util.StickyWindows
-- Description :  Make windows sticky to a screen across workspace changes.
-- Copyright   :  (c) Yecine Megdiche <yecine.megdiche@gmail.com>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Yecine Megdiche <yecine.megdiche@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- This module provides functionality to make windows \"sticky\" to a particular
-- screen. When a window is marked as sticky on a screen, it will automatically
-- follow that screen across workspace changes, staying visible even when you
-- switch to a different workspace.
--
-- This is particularly useful for windows you want to keep visible at all times
-- on a specific monitor, such as Picture-in-Picture videos, music players,
-- communication apps, or reference documentation.
module XMonad.Util.StickyWindows (
    -- * Usage
    -- $usage
    sticky,
    stick,
    unstick,
) where

import qualified Data.Map as M
import qualified Data.Set as S
import XMonad
import XMonad.Prelude
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS

-- $usage
-- You can use this module with the following in your @xmonad.hs@:
--
-- > import XMonad.Util.StickyWindows
--
-- To enable sticky windows, wrap your config with 'sticky':
--
-- > main = xmonad $ … . sticky . … $ def { ... }
--
-- This adds the necessary hooks to manage sticky windows. Next, add keybindings
-- to stick and unstick windows:
--
-- > , ((modMask, xK_s), withFocused stick)
-- > , ((modMask .|. shiftMask, xK_s), withFocused unstick)
--
-- Now you can:
--
--   1. Focus a window and press @Mod-s@ to make it sticky to the current screen
--   2. Switch workspaces on that screen, and the sticky window will follow
--   3. Press @Mod-Shift-s@ to unstick the window
--
-- Note that windows are sticky to a /specific screen/, not to all screens. If you
-- have multiple monitors, a window marked sticky on screen 0 will only follow
-- workspace changes on screen 0, not on other screens.
--
-- The sticky state persists across XMonad restarts.

data StickyState = SS
    { StickyState -> Map ScreenId WorkspaceId
lastWs :: !(M.Map ScreenId WorkspaceId)
    , StickyState -> Map ScreenId (Set Window)
stickies :: !(M.Map ScreenId (S.Set Window))
    }
    deriving (Int -> StickyState -> ShowS
[StickyState] -> ShowS
StickyState -> WorkspaceId
(Int -> StickyState -> ShowS)
-> (StickyState -> WorkspaceId)
-> ([StickyState] -> ShowS)
-> Show StickyState
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StickyState -> ShowS
showsPrec :: Int -> StickyState -> ShowS
$cshow :: StickyState -> WorkspaceId
show :: StickyState -> WorkspaceId
$cshowList :: [StickyState] -> ShowS
showList :: [StickyState] -> ShowS
Show, ReadPrec [StickyState]
ReadPrec StickyState
Int -> ReadS StickyState
ReadS [StickyState]
(Int -> ReadS StickyState)
-> ReadS [StickyState]
-> ReadPrec StickyState
-> ReadPrec [StickyState]
-> Read StickyState
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS StickyState
readsPrec :: Int -> ReadS StickyState
$creadList :: ReadS [StickyState]
readList :: ReadS [StickyState]
$creadPrec :: ReadPrec StickyState
readPrec :: ReadPrec StickyState
$creadListPrec :: ReadPrec [StickyState]
readListPrec :: ReadPrec [StickyState]
Read)

instance ExtensionClass StickyState where
    initialValue :: StickyState
initialValue = Map ScreenId WorkspaceId
-> Map ScreenId (Set Window) -> StickyState
SS Map ScreenId WorkspaceId
forall a. Monoid a => a
mempty Map ScreenId (Set Window)
forall a. Monoid a => a
mempty
    extensionType :: StickyState -> StateExtension
extensionType = StickyState -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

modifySticky ::
    (S.Set Window -> S.Set Window) -> ScreenId -> StickyState -> StickyState
modifySticky :: (Set Window -> Set Window)
-> ScreenId -> StickyState -> StickyState
modifySticky Set Window -> Set Window
f ScreenId
sid (SS Map ScreenId WorkspaceId
ws Map ScreenId (Set Window)
ss) =
    Map ScreenId WorkspaceId
-> Map ScreenId (Set Window) -> StickyState
SS Map ScreenId WorkspaceId
ws (Map ScreenId (Set Window) -> StickyState)
-> Map ScreenId (Set Window) -> StickyState
forall a b. (a -> b) -> a -> b
$ (Maybe (Set Window) -> Maybe (Set Window))
-> ScreenId
-> Map ScreenId (Set Window)
-> Map ScreenId (Set Window)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Set Window -> Maybe (Set Window)
forall a. a -> Maybe a
Just (Set Window -> Maybe (Set Window))
-> (Maybe (Set Window) -> Set Window)
-> Maybe (Set Window)
-> Maybe (Set Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Window -> Set Window
f (Set Window -> Set Window)
-> (Maybe (Set Window) -> Set Window)
-> Maybe (Set Window)
-> Set Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Window -> Maybe (Set Window) -> Set Window
forall a. a -> Maybe a -> a
fromMaybe Set Window
forall a. Set a
S.empty) ScreenId
sid Map ScreenId (Set Window)
ss

modifyStickyM :: (S.Set Window -> S.Set Window) -> ScreenId -> X ()
modifyStickyM :: (Set Window -> Set Window) -> ScreenId -> X ()
modifyStickyM Set Window -> Set Window
f ScreenId
sid = (StickyState -> StickyState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((Set Window -> Set Window)
-> ScreenId -> StickyState -> StickyState
modifySticky Set Window -> Set Window
f ScreenId
sid)

stick' :: Window -> ScreenId -> X ()
stick' :: Window -> ScreenId -> X ()
stick' = (Set Window -> Set Window) -> ScreenId -> X ()
modifyStickyM ((Set Window -> Set Window) -> ScreenId -> X ())
-> (Window -> Set Window -> Set Window)
-> Window
-> ScreenId
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> Set Window -> Set Window
forall a. Ord a => a -> Set a -> Set a
S.insert

unstick' :: Window -> ScreenId -> X ()
unstick' :: Window -> ScreenId -> X ()
unstick' = (Set Window -> Set Window) -> ScreenId -> X ()
modifyStickyM ((Set Window -> Set Window) -> ScreenId -> X ())
-> (Window -> Set Window -> Set Window)
-> Window
-> ScreenId
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> Set Window -> Set Window
forall a. Ord a => a -> Set a -> Set a
S.delete

-- | Remove the sticky status from the given window on the current screen.
-- The window will no longer automatically follow workspace changes.
--
-- Typically used with 'withFocused':
--
-- > , ((modMask .|. shiftMask, xK_s), withFocused unstick)
unstick :: Window -> X ()
unstick :: Window -> X ()
unstick Window
w = Window -> ScreenId -> X ()
unstick' Window
w (ScreenId -> X ()) -> X ScreenId -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X ScreenId
currentScreen

-- | Mark the given window as sticky to the current screen. The window will
-- automatically follow this screen across workspace changes until explicitly
-- unstuck with 'unstick' or until the window is destroyed.
--
-- Typically used with 'withFocused':
--
-- > , ((modMask, xK_s), withFocused stick)
stick :: Window -> X ()
stick :: Window -> X ()
stick Window
w = Window -> ScreenId -> X ()
stick' Window
w (ScreenId -> X ()) -> X ScreenId -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X ScreenId
currentScreen

currentScreen :: X ScreenId
currentScreen :: X ScreenId
currentScreen = (XState -> ScreenId) -> X ScreenId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> ScreenId) -> X ScreenId)
-> (XState -> ScreenId) -> X ScreenId
forall a b. (a -> b) -> a -> b
$ 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
 -> ScreenId)
-> (XState
    -> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> ScreenId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> 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
W.current (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> (XState
    -> StackSet
         WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
windowset

-- | Incorporates sticky window functionality into an 'XConfig'. This adds
-- the necessary log hook and event hook to:
--
--   * Automatically move sticky windows when workspaces change on their screen
--   * Clean up sticky state when windows are destroyed
--
-- Example usage:
--
-- > main = xmonad $ … . sticky .  … $ def { ... }
sticky :: XConfig l -> XConfig l
sticky :: forall (l :: * -> *). XConfig l -> XConfig l
sticky XConfig l
xconf =
    XConfig l
xconf
        { logHook = logHook xconf >> stickyLogHook
        , handleEventHook = handleEventHook xconf <> stickyEventHook
        }

stickyLogHook :: X ()
stickyLogHook :: X ()
stickyLogHook = do
    lastWS_ <- (StickyState -> Map ScreenId WorkspaceId)
-> X (Map ScreenId WorkspaceId)
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets StickyState -> Map ScreenId WorkspaceId
lastWs
    screens <- withWindowSet $ return . map (\Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
s -> (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
s, Workspace WorkspaceId (Layout Window) Window -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag (Workspace WorkspaceId (Layout Window) Window -> WorkspaceId)
-> (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> Workspace WorkspaceId (Layout Window) Window)
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
 -> WorkspaceId)
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> WorkspaceId
forall a b. (a -> b) -> a -> b
$ Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
s)) . W.screens
    for_ screens $ \(ScreenId
sid, WorkspaceId
wsTag) -> do
        Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ScreenId -> Map ScreenId WorkspaceId -> Maybe WorkspaceId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ScreenId
sid Map ScreenId WorkspaceId
lastWS_ Maybe WorkspaceId -> Maybe WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
== WorkspaceId -> Maybe WorkspaceId
forall a. a -> Maybe a
Just WorkspaceId
wsTag) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
            -- We need to update the last workspace before moving windows to avoid
            -- getting stuck in a loop: This is a log hook, and calling moveWindows
            -- (which in turn calls 'windows') would trigger another log hook.
            (StickyState -> StickyState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify (\(SS Map ScreenId WorkspaceId
ws Map ScreenId (Set Window)
ss) -> Map ScreenId WorkspaceId
-> Map ScreenId (Set Window) -> StickyState
SS (ScreenId
-> WorkspaceId
-> Map ScreenId WorkspaceId
-> Map ScreenId WorkspaceId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ScreenId
sid WorkspaceId
wsTag Map ScreenId WorkspaceId
ws) Map ScreenId (Set Window)
ss)
                X () -> X (Maybe (Set Window)) -> X (Maybe (Set Window))
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (StickyState -> Maybe (Set Window)) -> X (Maybe (Set Window))
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets (ScreenId -> Map ScreenId (Set Window) -> Maybe (Set Window)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ScreenId
sid (Map ScreenId (Set Window) -> Maybe (Set Window))
-> (StickyState -> Map ScreenId (Set Window))
-> StickyState
-> Maybe (Set Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StickyState -> Map ScreenId (Set Window)
stickies)
                X (Maybe (Set Window)) -> (Maybe (Set Window) -> 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
>>= X () -> (Set Window -> X ()) -> Maybe (Set Window) -> X ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe X ()
forall a. Monoid a => a
mempty (WorkspaceId -> Set Window -> X ()
moveWindows WorkspaceId
wsTag)

moveWindows :: WorkspaceId -> S.Set Window -> X ()
moveWindows :: WorkspaceId -> Set Window -> X ()
moveWindows WorkspaceId
wsTag = (Window -> X ()) -> Set Window -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Window
w -> (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> StackSet
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> X ()
windows ((StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
  -> StackSet
       WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
 -> X ())
-> (StackSet
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> StackSet
         WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> X ()
forall a b. (a -> b) -> a -> b
$ StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.focusDown (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> StackSet
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> (StackSet
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> StackSet
         WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceId
-> Window
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> a -> StackSet i l a s sd -> StackSet i l a s sd
W.shiftWin WorkspaceId
wsTag Window
w)

stickyEventHook :: Event -> X All
stickyEventHook :: Event -> X All
stickyEventHook DestroyWindowEvent{ev_window :: Event -> Window
ev_window = Window
w} =
    (StickyState -> StickyState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify (\(SS Map ScreenId WorkspaceId
ws Map ScreenId (Set Window)
ss) -> Map ScreenId WorkspaceId
-> Map ScreenId (Set Window) -> StickyState
SS Map ScreenId WorkspaceId
ws ((Set Window -> Set Window)
-> Map ScreenId (Set Window) -> Map ScreenId (Set Window)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Window -> Set Window -> Set Window
forall a. Ord a => a -> Set a -> Set a
S.delete Window
w) Map ScreenId (Set Window)
ss)) X () -> All -> X All
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool -> All
All Bool
True
stickyEventHook Event
_ = All -> X All
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)