X.U.NamedScratchpad: Add exclusive scratchpad capabilities

CHANGES.md

@@ -64,6 +64,13 @@
 
 ### Bug Fixes and Minor Changes
 
+* `XMonad.Util.NamedScratchpad`
+
+  - Added `addExclusives`, `resetFocusedNSP`, `setNoexclusive`,
+    `resizeNoexclusive`, and `floatMoveNoexclusive` in order to augment
+    named scratchpads with the exclusive scratchpad functionality of
+    `XMonad.Util.ExclusiveScratchpads`.
+
 * `XMonad.Layout.BorderResize`
 
   - Added `borderResizeNear` as a variant of `borderResize` that can

XMonad/Util/NamedScratchpad.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE InstanceSigs     #-}
+{-# LANGUAGE InstanceSigs   #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ViewPatterns   #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Util.NamedScratchpad
@@ -36,24 +37,34 @@ module XMonad.Util.NamedScratchpad (
   dynamicNSPAction,
   toggleDynamicNSP,
 
+  -- * Exclusive Scratchpads
+  -- $exclusive-scratchpads
+  addExclusives,
+  -- ** Keyboard related
+  resetFocusedNSP,
+  -- ** Mouse related
+  setNoexclusive,
+  resizeNoexclusive,
+  floatMoveNoexclusive,
+
   -- * Deprecations
   namedScratchpadFilterOutWorkspace,
   namedScratchpadFilterOutWorkspacePP,
 
   ) where
 
-import Data.Coerce (coerce)
 import Data.Map.Strict (Map, (!?))
 import XMonad
 import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace)
 import XMonad.Actions.SpawnOn (spawnHere)
+import XMonad.Actions.TagWindows (addTag, delTag)
 import XMonad.Hooks.ManageHelpers (doRectFloat)
 import XMonad.Hooks.RefocusLast (withRecentsIn)
 import XMonad.Hooks.StatusBar.PP (PP, ppSort)
-import XMonad.Prelude (filterM, unless, when)
+import XMonad.Prelude (appEndo, filterM, findM, foldl', for_, unless, void, when, (<=<))
 
-import qualified Data.Map.Strict    as Map
 import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Strict    as Map
 
 import qualified XMonad.StackSet             as W
 import qualified XMonad.Util.ExtensibleState as XS
@@ -124,23 +135,51 @@ data NamedScratchpad = NS { name   :: String      -- ^ Scratchpad name
                           , hook   :: ManageHook  -- ^ Manage hook called for application window, use it to define the placement. See @nonFloating@, @defaultFloating@ and @customFloating@
                           }
 
--- | The NSP state associates a name to an entire scratchpad.
+-- | The NSP state.
-newtype NSPState = NSPState (Map String NamedScratchpad)
+data NSPState = NSPState
+  { nspExclusives  :: !(Map String NamedScratchpads)
+    -- ^ Associates the name of a scratchpad to some list of scratchpads
+    -- that should be mutually exclusive to it.
+  , nspScratchpads :: !(Map String NamedScratchpad)
+    -- ^ Associates a name to an entire scratchpad.
+  }
 
 instance ExtensionClass NSPState where
   initialValue :: NSPState
-  initialValue = NSPState mempty
+  initialValue = NSPState mempty mempty
 
--- | Try to fill the 'NSPState' with the given list of scratchpads.  In
+-- | Try to:
--- case the state is already non-empty, don't do anything and return
+--
--- that state.  Otherwise, fill the state with the given scratchpads.
+--    (i) Fill the 'nspScratchpads' portion of the 'NSPState' with the
+--        given list of scratchpads.  In case that particular map of the
+--        state is already non-empty, don't do anything and return that
+--        state.
+--
+--   (ii) Replace possibly dummy scratchpads in @nspExclusives@ with
+--        proper values.  For convenience, the user may specify
+--        exclusive scratchpads by name in the startup hook.  However,
+--        we don't necessarily have all information then to immediately
+--        turn these into proper NamedScratchpads.  As such, we thinly
+--        wrap the names into an NSP skeleton, to be filled in later.
+--        This function, to be executed _before_
+--        'someNamedScratchpadAction' is the (latest) point where that
+--        happens.
 fillNSPState :: NamedScratchpads -> X NSPState
 fillNSPState nsps = do
-    nsp@(NSPState xs) <- XS.get
+    nsp@(NSPState exs scratches) <- XS.get
-    let nspState = NSPState . Map.fromList $ zip (map name nsps) nsps
+    if null scratches
-    if null xs
+      then let nspState = NSPState (fillOut exs) nspScratches
-        then nspState <$ XS.put nspState
+            in nspState <$ XS.put nspState
-        else pure nsp
+      else pure nsp
+  where
+    -- @fillNSPState@ only runs once, so the complexity here is probably
+    -- not a big deal.
+    nspScratches :: Map String NamedScratchpad
+    nspScratches = Map.fromList $ zip (map name nsps) nsps
+    fillOut :: Map String [NamedScratchpad] -> Map String [NamedScratchpad]
+    fillOut exs = foldl' (\nspMap n -> Map.map (replaceWith n) nspMap) exs nsps
+    replaceWith :: NamedScratchpad -> [NamedScratchpad] -> [NamedScratchpad]
+    replaceWith n = map (\x -> if name x == name n then n else x)
 
 -- | Manage hook that makes the window non-floating
 nonFloating :: ManageHook
@@ -243,19 +282,23 @@ someNamedScratchpadAction :: ((Window -> X ()) -> NE.NonEmpty Window -> X ())
                           -> String
                           -> X ()
 someNamedScratchpadAction f runApp _ns scratchpadName = do
-    NSPState scratchpadConfig <- fillNSPState _ns  -- See Note [Filling NSPState]
+    NSPState{ nspScratchpads } <- fillNSPState _ns  -- See Note [Filling NSPState]
-    case scratchpadConfig !? scratchpadName of
+    case nspScratchpads !? scratchpadName of
         Just conf -> withWindowSet $ \winSet -> do
-            let focusedWspWindows = maybe [] W.integrate (W.stack . W.workspace . W.current $ winSet)
+            let focusedWspWindows = W.index winSet
                 allWindows        = W.allWindows winSet
             matchingOnCurrent <- filterM (runQuery (query conf)) focusedWspWindows
             matchingOnAll     <- filterM (runQuery (query conf)) allWindows
 
             case NE.nonEmpty matchingOnCurrent of
                 -- no matching window on the current workspace -> scratchpad not running or in background
-                Nothing -> case NE.nonEmpty matchingOnAll of
+                Nothing -> do
-                    Nothing   -> runApp conf
+                    -- summon the scratchpad
-                    Just wins -> f (windows . W.shiftWin (W.currentTag winSet)) wins
+                    case NE.nonEmpty matchingOnAll of
+                        Nothing   -> runApp conf
+                        Just wins -> f (windows . W.shiftWin (W.currentTag winSet)) wins
+                    -- check for exclusive scratchpads to hide
+                    hideUnwanted (name conf)
 
                 -- matching window running on current workspace -> window should be shifted to scratchpad workspace
                 Just wins -> shiftToNSP (W.workspaces winSet) (`f` wins)
@@ -286,7 +329,7 @@ scratchpadWorkspaceTag = "NSP"
 namedScratchpadManageHook :: NamedScratchpads -- ^ Named scratchpads configuration
                           -> ManageHook
 namedScratchpadManageHook nsps = do
-    ns <- Map.elems . coerce <$> liftX (fillNSPState nsps)
+    ns <- Map.elems . nspScratchpads <$> liftX (fillNSPState nsps)
     composeAll $ fmap (\c -> query c --> hook c) ns
 
 -- | Shift some windows to the scratchpad workspace according to the
@@ -341,11 +384,12 @@ mkDynamicNSP s w =
 
 -- | Make a window a dynamic scratchpad
 addDynamicNSP :: String -> Window -> X ()
-addDynamicNSP s w = XS.modify @NSPState . coerce $ Map.insert s (mkDynamicNSP s w)
+addDynamicNSP s w = XS.modify $ \(NSPState exs ws) ->
+  NSPState exs (Map.insert s (mkDynamicNSP s w) ws)
 
 -- | Make a window stop being a dynamic scratchpad
 removeDynamicNSP :: String -> X ()
-removeDynamicNSP s = XS.modify @NSPState . coerce $ Map.delete @_ @NamedScratchpad s
+removeDynamicNSP s = XS.modify $ \(NSPState exs ws) -> NSPState exs (Map.delete s ws)
 
 -- | Toggle the visibility of a dynamic scratchpad.
 dynamicNSPAction :: String -> X ()
@@ -355,13 +399,139 @@ dynamicNSPAction = customRunNamedScratchpadAction (const $ pure ()) []
 -- a window from being one if it already is.
 toggleDynamicNSP :: String -> Window -> X ()
 toggleDynamicNSP s w = do
-    NSPState nsps <- XS.get
+    NSPState{ nspScratchpads } <- XS.get
-    case nsps !? s of
+    case nspScratchpads !? s of
         Nothing  -> addDynamicNSP s w
         Just nsp -> ifM (runQuery (query nsp) w)
                         (removeDynamicNSP s)
                         (addDynamicNSP s w)
 
+-----------------------------------------------------------------------
+-- Exclusive scratchpads
+
+-- $exclusive-scratchpads
+--
+-- Exclusive scratchpads allow you to hide certain scratchpads in
+-- relation to others.  There can be multiple groups of pairwise
+-- exclusive scratchpads; whenever one such scratchpad gets called, it
+-- will hide all other scratchpads on the focused workspace that are in
+-- this group.
+--
+-- For example, having defined "Calc", "Mail", and "Term" scratchpads,
+-- you can use 'addExclusives' to make some of them dislike each other:
+--
+-- > myExclusives = [ ["Calc", "Mail"]
+-- >                , ["Mail", "Term"]
+-- >                ]
+--
+-- You now have to add @myExclusives@ to you startupHook:
+--
+-- > main :: IO
+-- > main = xmonad . … . $ def
+-- >   { …
+-- >   , startupHook = myStartupHook >> myExclusives
+-- >   }
+--
+-- This will hide the "Mail" scratchpad whenever the "Calc" scratchpad
+-- is brought up, and vice-versa.  Likewise, "Mail" and "Term" behave in
+-- this way, but "Calc" and "Term" may peacefully coexist.
+--
+-- If you move a scratchpad it still gets hidden when you fetch a
+-- scratchpad of the same family.  To change that behaviour—and make
+-- windows not exclusive anymore when they get resized or moved—add
+-- these mouse bindings (see
+-- "XMonad.Doc.Extending#Editing_mouse_bindings"):
+--
+-- >     , ((mod4Mask, button1), floatMoveNoexclusive)
+-- >     , ((mod4Mask, button3), resizeNoexclusive)
+--
+-- To reset a moved scratchpad to the original position that you set
+-- with its hook, focus is and then call 'resetFocusedNSP'.  For
+-- example, if you want to extend @M-\<Return\>@ to reset the placement
+-- when a scratchpad is in focus but keep the default behaviour for
+-- tiled windows, set these key bindings:
+--
+-- > , ((modMask, xK_Return), windows W.swapMaster >> resetFocusedNSP)
+
+-- | Make some scratchpads exclusive.
+addExclusives :: [[String]] -> X ()
+addExclusives exs = do
+    NSPState _ ws <- XS.get
+    -- Re-initialise `ws' to nothing, so we can react to changes in case
+    -- of a restart.  See 'fillNSPState' for more details on filling.
+    XS.put (NSPState (foldl' (go []) mempty exs) mempty)
+    unless (null ws) $
+        void (fillNSPState (Map.elems ws))
+  where
+    -- Ignoring that this is specialised to NSPs, it works something like
+    -- >>> foldl' (go []) mempty [[1, 2], [3, 4], [1, 3]]
+    -- fromList [(1, [3, 2]), (2, [1]), (3, [1, 4]), (4, [3])]
+    go _  m []       = m
+    go ms m (n : ns) = go (n : ms) (Map.insertWith (<>) n (mkNSP (ms <> ns)) m) ns
+    mkNSP = map (\n -> NS n mempty (pure False) mempty)
+
+-- | @setNoexclusive w@ makes the window @w@ lose its exclusivity
+-- features.
+setNoexclusive :: Window -> X ()
+setNoexclusive w = do
+    NSPState _ ws <- XS.get
+    whenX (isNSP w (Map.elems ws)) $
+        addTag "_NSP_NOEXCLUSIVE" w
+
+-- | If the focused window is a scratchpad, the scratchpad gets reset to
+-- the original placement specified with the hook and becomes exclusive
+-- again.
+resetFocusedNSP :: X ()
+resetFocusedNSP = do
+    NSPState _ (Map.elems -> ws) <- XS.get
+    withFocused $ \w -> do
+        mbWin <- findM ((`runQuery` w) . query) ws
+        whenJust mbWin $ \win -> do
+            (windows . appEndo <=< runQuery (hook win)) w
+            hideUnwanted (name win)
+            delTag "_NSP_NOEXCLUSIVE" w
+
+-- | @hideUnwanted nspWindow@ hides all windows that @nspWindow@ does
+-- not like; i.e., windows that are in some kind of exclusivity contract
+-- with it.
+--
+-- A consistency assumption for this is that @nspWindow@ must be the
+-- currently focused window.  For this to take effect, @nspWindow@ must
+-- not have set the @_NSP_NOEXCLUSIVE@ property, neither must any
+-- exclusive window we'd like to hide.
+hideUnwanted :: String -> X ()
+hideUnwanted nspWindow = withWindowSet $ \winSet -> do
+    NSPState{ nspExclusives } <- XS.get
+    whenJust (nspExclusives !? nspWindow) $ \unwanted ->
+        withFocused $ \w -> whenX (runQuery notIgnored w) $ do
+            for_ (W.index winSet) $ \win ->
+                whenX (runQuery (isUnwanted unwanted) win) $
+                    shiftToNSP (W.workspaces winSet) ($ win)
+  where
+    notIgnored :: Query Bool
+    notIgnored = notElem "_NSP_NOEXCLUSIVE" . words <$> stringProperty "_XMONAD_TAGS"
+
+    isUnwanted :: [NamedScratchpad] -> Query Bool
+    isUnwanted = (notIgnored <&&>) . foldr (\nsp qs -> qs <||> query nsp) (pure False)
+
+-- | Float and drag the window; make it lose its exclusivity status in
+-- the process.
+floatMoveNoexclusive :: Window -- ^ Window which should be moved
+                     -> X ()
+floatMoveNoexclusive = mouseHelper mouseMoveWindow
+
+-- | Resize window and make it lose its exclusivity status in the
+-- process.
+resizeNoexclusive :: Window -- ^ Window which should be resized
+                  -> X ()
+resizeNoexclusive = mouseHelper mouseResizeWindow
+
+mouseHelper :: (Window -> X a) -> Window -> X ()
+mouseHelper f w = setNoexclusive w
+               >> focus w
+               >> f w
+               >> windows W.shiftMaster
+
 ------------------------------------------------------------------------
 -- Deprecations