Merge pull request #351 from elkowar/master

Make XMonad.Util.NamedScratchpad more flexible

CHANGES.md

@@ -52,6 +52,14 @@
 
 ### Bug Fixes and Minor Changes
 
+  * `XMonad.Util.NamedScratchpad`
+
+     Added two new exported functions to the module:
+     - `customRunNamedScratchpadAction` 
+         (provides the option to customize the `X ()` action the scratchpad is launched by) 
+     - `spawnHereNamedScratchpadAction` 
+         (uses `XMonad.Actions.SpawnOn.spawnHere` to initially start the scratchpad on the workspace it was launched on)
+
   * `XMonad.Util.Run` 
   
      Added two new functions to the module:

XMonad/Util/NamedScratchpad.hs

@@ -22,6 +22,8 @@ module XMonad.Util.NamedScratchpad (
   customFloating,
   NamedScratchpads,
   namedScratchpadAction,
+  spawnHereNamedScratchpadAction,
+  customRunNamedScratchpadAction,
   allNamedScratchpadAction,
   namedScratchpadManageHook,
   namedScratchpadFilterOutWorkspace,
@@ -32,8 +34,11 @@ import XMonad
 import XMonad.Hooks.ManageHelpers (doRectFloat)
 import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace)
 import XMonad.Hooks.DynamicLog (PP, ppSort)
+import XMonad.Actions.SpawnOn (spawnHere)
 
-import Control.Monad (filterM)
+import qualified Data.List.NonEmpty as NE
+
+import Control.Monad (filterM, unless)
 import Data.Maybe (listToMaybe)
 
 import qualified XMonad.StackSet as W
@@ -109,43 +114,67 @@ type NamedScratchpads = [NamedScratchpad]
 
 -- | Finds named scratchpad configuration by name
 findByName :: NamedScratchpads -> String -> Maybe NamedScratchpad
-findByName c s = listToMaybe $ filter ((s==) . name) c
+findByName c s = listToMaybe $ filter ((s ==) . name) c
 
 -- | Runs application which should appear in specified scratchpad
 runApplication :: NamedScratchpad -> X ()
 runApplication = spawn . cmd
 
+-- | Runs application which should appear in a specified scratchpad on the workspace it was launched on
+runApplicationHere :: NamedScratchpad -> X ()
+runApplicationHere = spawnHere . cmd
+
 -- | Action to pop up specified named scratchpad
 namedScratchpadAction :: NamedScratchpads -- ^ Named scratchpads configuration
                       -> String           -- ^ Scratchpad name
                       -> X ()
-namedScratchpadAction = someNamedScratchpadAction (\f ws -> f $ head ws)
+namedScratchpadAction = customRunNamedScratchpadAction runApplication
+
+-- | Action to pop up specified named scratchpad, initially starting it on the current workspace.
+spawnHereNamedScratchpadAction :: NamedScratchpads           -- ^ Named scratchpads configuration
+                               -> String                     -- ^ Scratchpad name
+                               -> X ()
+spawnHereNamedScratchpadAction = customRunNamedScratchpadAction runApplicationHere
+
+-- | Action to pop up specified named scratchpad, given a custom way to initially start the application.
+customRunNamedScratchpadAction :: (NamedScratchpad -> X ())  -- ^ Function initially running the application, given the configured @scratchpad@ cmd
+                               -> NamedScratchpads           -- ^ Named scratchpads configuration
+                               -> String                     -- ^ Scratchpad name
+                               -> X ()
+customRunNamedScratchpadAction = someNamedScratchpadAction (\f ws -> f $ NE.head ws)
 
 allNamedScratchpadAction :: NamedScratchpads
                          -> String
                          -> X ()
-allNamedScratchpadAction = someNamedScratchpadAction mapM_
+allNamedScratchpadAction = someNamedScratchpadAction mapM_ runApplication
 
-someNamedScratchpadAction :: ((Window -> X ()) -> [Window] -> X ())
+-- | execute some action on a named scratchpad
+someNamedScratchpadAction :: ((Window -> X ()) -> NE.NonEmpty Window -> X ())
+                          -> (NamedScratchpad -> X ())
                           -> NamedScratchpads
                           -> String
                           -> X ()
-someNamedScratchpadAction f confs n
-    | Just conf <- findByName confs n = withWindowSet $ \s -> do
-                     filterCurrent <- filterM (runQuery (query conf))
-                                        ((maybe [] W.integrate . W.stack . W.workspace . W.current) s)
-                     filterAll <- filterM (runQuery (query conf)) (W.allWindows s)
-                     case filterCurrent of
-                       [] ->
-                         case filterAll of
-                           [] -> runApplication conf
-                           _  -> f (windows . W.shiftWin (W.currentTag s)) filterAll
-                       _ -> do
-                         if null (filter ((== scratchpadWorkspaceTag) . W.tag) (W.workspaces s))
-                             then addHiddenWorkspace scratchpadWorkspaceTag
-                             else return ()
-                         f (windows . W.shiftWin scratchpadWorkspaceTag) filterAll
-    | otherwise = return ()
+someNamedScratchpadAction f runApp scratchpadConfig scratchpadName =
+    case findByName scratchpadConfig scratchpadName of
+        Just conf -> withWindowSet $ \winSet -> do
+            let focusedWspWindows = maybe [] W.integrate (W.stack . W.workspace . W.current $ 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   -> runApp conf
+                    Just wins -> f (windows . W.shiftWin (W.currentTag winSet)) wins
+
+                -- matching window running on current workspace -> window should be shifted to scratchpad workspace
+                Just wins -> do
+                    unless (any (\wsp -> scratchpadWorkspaceTag == W.tag wsp) (W.workspaces winSet))
+                        (addHiddenWorkspace scratchpadWorkspaceTag)
+                    f (windows . W.shiftWin scratchpadWorkspaceTag) wins
+
+        Nothing -> return ()
 
 
 -- tag of the scratchpad workspace