Merge pull request #774 from slotThe/nsp/exclusive

X.U.NamedScratchpad: Add exclusive scratchpad capabilities

CHANGES.md

@@ -4,6 +4,11 @@
 
 ### Breaking Changes
 
+  * `XMonad.Util.ExclusiveScratchpads`
+
+    - Deprecated the module in favour of the (new) exclusive scratchpad
+      functionality of `XMonad.Util.NamedScratchpad`.
+
   * `XMonad.Hooks.DynamicProperty`
 
     - Deprecated the module in favour of the more aptly named
@@ -65,50 +70,57 @@
 
 ### New Modules
 
-* `XMonad.Hooks.OnPropertyChange`:
+  * `XMonad.Hooks.OnPropertyChange`:
 
-  - A new module replicating the functionality of
+    - A new module replicating the functionality of
-    `XMonad.Hooks.DynamicProperty`, but with more discoverable names.
+      `XMonad.Hooks.DynamicProperty`, but with more discoverable names.
 
 ### Bug Fixes and Minor Changes
 
-* `XMonad.Layout.BorderResize`
+  * `XMonad.Util.NamedScratchpad`
 
-  - Added `borderResizeNear` as a variant of `borderResize` that can
+    - Added `addExclusives`, `resetFocusedNSP`, `setNoexclusive`,
-    control how many pixels near a border resizing still works.
+      `resizeNoexclusive`, and `floatMoveNoexclusive` in order to augment
+      named scratchpads with the exclusive scratchpad functionality of
+      `XMonad.Util.ExclusiveScratchpads`.
 
-* `XMonad.Util.Run`
+  * `XMonad.Layout.BorderResize`
 
-  - It is now ensured that all arguments of `execute` and `eval` are
+    - Added `borderResizeNear` as a variant of `borderResize` that can
-    quoted.  Likewise, `executeNoQuote` is added as a version of
+      control how many pixels near a border resizing still works.
-    `execute` that does not do that.
 
-  - Added `findFile` as a shorthand to call `find-file`.
+  * `XMonad.Util.Run`
 
-  - Added `list` and `saveExcursion` to the list of Emacs commands.
+    - It is now ensured that all arguments of `execute` and `eval` are
+      quoted.  Likewise, `executeNoQuote` is added as a version of
+      `execute` that does not do that.
 
-* `XMonad.Util.Parser`
+    - Added `findFile` as a shorthand to call `find-file`.
 
-  - Added the `gather`, `count`, `between`, `option`, `optionally`,
+    - Added `list` and `saveExcursion` to the list of Emacs commands.
-    `skipMany`, `skipMany1`, `chainr`, `chainr1`, `chainl`, `chainl1`,
-    and `manyTill` functions, in order to achieve feature parity with
-    `Text.ParserCombinators.ReadP`.
 
-* `XMonad.Actions.FloatKeys`
+  * `XMonad.Util.Parser`
 
-  - Added `directionMoveWindow` and `directionMoveWindow` as more
+    - Added the `gather`, `count`, `between`, `option`, `optionally`,
-    alternatives to the existing functions.
+      `skipMany`, `skipMany1`, `chainr`, `chainr1`, `chainl`, `chainl1`,
+      and `manyTill` functions, in order to achieve feature parity with
+      `Text.ParserCombinators.ReadP`.
 
-* `XMonad.Hooks.InsertPosition`
+  * `XMonad.Actions.FloatKeys`
 
-  - Added `setupInsertPosition` as a combinator alternative to
+    - Added `directionMoveWindow` and `directionMoveWindow` as more
-    `insertPosition`.
+      alternatives to the existing functions.
 
-* `XMonad.Actions.Navigation2D`
+  * `XMonad.Hooks.InsertPosition`
 
-  - Added `sideNavigation` as a fallback to the default tiling strategy,
+    - Added `setupInsertPosition` as a combinator alternative to
-    in case `lineNavigation` can't find a window.  This benefits
+      `insertPosition`.
-    especially users who use `XMonad.Layout.Spacing`.
+
+  * `XMonad.Actions.Navigation2D`
+
+    - Added `sideNavigation` as a fallback to the default tiling strategy,
+      in case `lineNavigation` can't find a window.  This benefits
+      especially users who use `XMonad.Layout.Spacing`.
 
 * `XMonad.Prompt.OrgMode`
 

XMonad/Actions/TagWindows.hs

@@ -134,11 +134,6 @@ focusTagged' :: (WindowSet -> [Window]) -> String -> X ()
 focusTagged' wl t = gets windowset >>= findM (hasTag t) . wl >>=
     maybe (return ()) (windows . focusWindow)
 
-findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)
-findM _ []      = return Nothing
-findM p (x:xs)  = do b <- p x
-                     if b then return (Just x) else findM p xs
-
 -- | apply a pure function to windows with a tag
 withTaggedP, withTaggedGlobalP :: String -> (Window -> WindowSet -> WindowSet) -> X ()
 withTaggedP       t f = withTagged'       t (winMap f)

XMonad/Layout/IM.hs

@@ -30,10 +30,11 @@ module XMonad.Layout.IM (
 ) where
 
 import XMonad
-import qualified XMonad.StackSet as S
 import XMonad.Layout.Grid
 import XMonad.Layout.LayoutModifier
+import XMonad.Prelude
 import XMonad.Util.WindowProperties
+import qualified XMonad.StackSet as S
 
 import Control.Arrow (first)
 
@@ -110,11 +111,6 @@ applyIM ratio prop wksp rect = do
             return (first ((w, masterRect) :) wrs)
         Nothing -> runLayout wksp rect
 
--- | Like find, but works with monadic computation instead of pure function.
-findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
-findM _ [] = return Nothing
-findM f (x:xs) = do { b <- f x; if b then return (Just x) else findM f xs }
-
 -- | This is for compatibility with old configs only and will be removed in future versions!
 data IM a = IM Rational Property deriving (Read, Show)
 instance LayoutClass IM Window where

XMonad/Prelude.hs

@@ -24,6 +24,7 @@ module XMonad.Prelude (
     notEmpty,
     safeGetWindowAttributes,
     mkAbsolutePath,
+    findM,
 
     -- * Keys
     keyToString,
@@ -89,6 +90,21 @@ chunksOf i xs = chunk : chunksOf i rest
 (.:) :: (a -> b) -> (c -> d -> a) -> c -> d -> b
 (.:) = (.) . (.)
 
+-- | Like 'find', but takes a monadic function instead; retains the
+-- short-circuiting behaviour of the non-monadic version.
+--
+-- For example,
+--
+-- > findM (\a -> putStr (show a <> " ") >> pure False) [1..10]
+--
+-- would print "1 2 3 4 5 6 7 8 9 10" and return @Nothing@, while
+--
+-- > findM (\a -> putStr (show a <> " ") >> pure True) [1..10]
+--
+-- would print @"1"@ and return @Just 1@.
+findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
+findM p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)
+
 -- | 'Data.List.NonEmpty.fromList' with a better error message. Useful to
 -- silence GHC's Pattern match(es) are non-exhaustive warning in places where
 -- the programmer knows it's always non-empty, but it's infeasible to express

XMonad/Util/ExclusiveScratchpads.hs

@@ -15,7 +15,9 @@
 --
 -----------------------------------------------------------------------------
 
-module XMonad.Util.ExclusiveScratchpads (
+module XMonad.Util.ExclusiveScratchpads
+  {-# DEPRECATED "Use the exclusive scratchpad functionality of \"XMonad.Util.NamedScratchpad\" insead." #-}
+  (
   -- * Usage
   -- $usage
   mkXScratchpads,

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
@@ -111,6 +122,25 @@ import qualified XMonad.Util.ExtensibleState as XS
 -- the list of workspaces from EWMH.  See the documentation of these functions
 -- for examples.
 --
+-- If you want to explore this module further, scratchpads can come in
+-- many forms and flavours:
+--
+--   + \"Regular\" scratchpads: they can be predefined and
+--     summoned/banished with a key press.  These are the scratchpads
+--     that you have seen above.
+--
+--   + [Dynamic scratchpads](#g:dynamic-scratchpads), which allow you to
+--     dynamically declare existing windows as scratchpads.  These can
+--     be treated as a separate type of scratchpad.
+--
+--   + [Exclusive](#g:exclusive-scratchpads) scratchpads, which can be
+--     seen as a property of already existing scratchpads.  Marking
+--     scratchpads as exclusive will not allow them to be shown on the
+--     same workspace; the scratchpad being brought up will hide the
+--     others.
+--
+-- See the relevant sections in the documentation for more information.
+--
 -- Further, there is also a @logHook@ that you can use to hide
 -- scratchpads when they lose focus; this is functionality akin to what
 -- some dropdown terminals provide.  See the documentation of
@@ -124,23 +154,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
@@ -154,6 +212,11 @@ defaultFloating = doFloat
 customFloating :: W.RationalRect -> ManageHook
 customFloating = doRectFloat
 
+-- | @isNSP win nsps@ checks whether the window @win@ is any scratchpad
+-- in @nsps@.
+isNSP :: Window -> NamedScratchpads -> X Bool
+isNSP w = fmap or . traverse ((`runQuery` w) . query)
+
 -- | Named scratchpads configuration
 type NamedScratchpads = [NamedScratchpad]
 
@@ -225,11 +288,8 @@ nsHideOnFocusLoss scratches = withWindowSet $ \winSet -> do
     let cur = W.currentTag winSet
     withRecentsIn cur () $ \lastFocus _ ->
         when (lastFocus `elem` W.index winSet && cur /= scratchpadWorkspaceTag) $
-            whenX (isNS lastFocus) $
+            whenX (isNSP lastFocus scratches) $
                 shiftToNSP (W.workspaces winSet) ($ lastFocus)
-  where
-    isNS :: Window -> X Bool
-    isNS w = or <$> traverse ((`runQuery` w) . query) scratches
 
 -- | Execute some action on a named scratchpad.
 --
@@ -241,19 +301,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)
@@ -284,7 +348,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
@@ -339,11 +403,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 ()
@@ -353,13 +418,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