Merge pull request #543 from slotThe/view-ws-instead-of-entering-parallel-universe-where-the-focus-is-somewhere-else

X.A.CycleRecentWS: Cycle workspaces, not windowsets

CHANGES.md

@@ -92,6 +92,15 @@
       `tiActions`, `tiDirs`, `noAction`, and `inHome` for a more
       convenient specification of topics.
 
+  * `XMonad.Actions.CycleRecentWS`
+
+    - Changed the signature of `recentWS` to return a `[WorkspaceId]`
+      instead of a `[WindowSet]`, while `cycleWindowSets` and
+      `toggleWindowSets` now take a function `WindowSet ->
+      [WorkspaceId]` instead of one to `[WindowSet]` as their first
+      argument.  This fixes the interplay between this module and any
+      layout that stores state.
+
 ### New Modules
 
   * `XMonad.Hooks.StatusBar.PP`

XMonad/Actions/CycleRecentWS.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternGuards #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Actions.CycleRecentWS
@@ -24,12 +27,19 @@ module XMonad.Actions.CycleRecentWS (
                                 toggleRecentWS,
                                 toggleRecentNonEmptyWS,
                                 toggleWindowSets,
-                                recentWS
+                                recentWS,
+
+#ifdef TESTING
+                                unView,
+#endif
 ) where
 
 import XMonad hiding (workspaces)
 import XMonad.StackSet hiding (filter)
 
+import Control.Arrow ((&&&))
+import Data.Function (on)
+
 -- $usage
 -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:
 --
@@ -76,41 +86,37 @@ toggleRecentNonEmptyWS :: X ()
 toggleRecentNonEmptyWS = toggleWindowSets $ recentWS (not . null . stack)
 
 
--- | Given a predicate p and the current WindowSet w, create a list of recent WindowSets,
--- most recent first, where the focused workspace satisfies p.
+-- | Given a predicate @p@ and the current 'WindowSet' @w@, create a
+-- list of workspaces to choose from. They are ordered by recency and
+-- have to satisfy @p@.
 recentWS :: (WindowSpace -> Bool) -- ^ A workspace predicate.
          -> WindowSet             -- ^ The current WindowSet
-         -> [WindowSet]
-recentWS p w = map (`view` w) recentTags
- where recentTags = map tag
-                  $ filter p
-                  $ map workspace (visible w)
-                    ++ hidden w
-                    ++ [workspace (current w)]
+         -> [WorkspaceId]
+recentWS p w = map tag
+             $ filter p
+             $ map workspace (visible w)
+               ++ hidden w
+               ++ [workspace (current w)]
 
-
-cycref :: [a] -> Int -> a
-cycref l i = l !! (i `mod` length l)
-
--- | Cycle through a finite list of WindowSets with repeated presses of a key, while
+-- | Cycle through a finite list of workspaces with repeated presses of a key, while
 --   a modifier key is held down. For best effects use the same modkey+key combination
 --   as the one used to invoke this action.
-cycleWindowSets :: (WindowSet -> [WindowSet]) -- ^ A function used to create a list of WindowSets to choose from
-                -> [KeySym]                   -- ^ A list of modifier keys used when invoking this action.
-                                              --   As soon as one of them is released, the final WindowSet is chosen and the action exits.
-                -> KeySym                     -- ^ Key used to preview next WindowSet from the list of generated options
-                -> KeySym                     -- ^ Key used to preview previous WindowSet from the list of generated options.
-                                              --   If it's the same as nextOption key, it is effectively ignored.
+cycleWindowSets :: (WindowSet -> [WorkspaceId]) -- ^ A function used to create a list of workspaces to choose from
+                -> [KeySym]                     -- ^ A list of modifier keys used when invoking this action.
+                                                --   As soon as one of them is released, the final workspace is chosen and the action exits.
+                -> KeySym                       -- ^ Key used to preview next workspace from the list of generated options
+                -> KeySym                       -- ^ Key used to preview previous workspace from the list of generated options.
+                                                --   If it's the same as nextOption key, it is effectively ignored.
                 -> X ()
 cycleWindowSets genOptions mods keyNext keyPrev = do
-  options <- gets $ genOptions . windowset
+  (options, unView') <- gets $ (genOptions &&& unView) . windowset
   XConf {theRoot = root, display = d} <- ask
   let event = allocaXEvent $ \p -> do
                 maskEvent d (keyPressMask .|. keyReleaseMask) p
                 KeyEvent {ev_event_type = t, ev_keycode = c} <- getEvent p
                 s <- keycodeToKeysym d c 0
                 return (t, s)
-  let setOption n = do windows $ const $ options `cycref` n
+  let setOption n = do windows $ view (options `cycref` n) . unView'
                        (t, s) <- io event
                        case () of
                          () | t == keyPress   && s == keyNext  -> setOption (n+1)
@@ -120,12 +126,37 @@ cycleWindowSets genOptions mods keyNext keyPrev = do
   io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
   setOption 0
   io $ ungrabKeyboard d currentTime
+ where
+  cycref :: [a] -> Int -> a
+  cycref l i = l !! (i `mod` length l)
 
+-- | Given an old and a new 'WindowSet', which is __exactly__ one
+-- 'view' away from the old one, restore the workspace order of the
+-- former inside of the latter.  This respects any new state that the
+-- new 'WindowSet' may have accumulated.
+unView :: forall i l a s sd. (Eq i, Eq s)
+       => StackSet i l a s sd -> StackSet i l a s sd -> StackSet i l a s sd
+unView w0 w1 = fixOrderH . fixOrderV . view' (currentTag w0) $ w1
+ where
+  view' = if screen (current w0) == screen (current w1) then greedyView else view
+  fixOrderV w | v : vs <- visible w = w{ visible = insertAt (pfxV (visible w0) vs) v vs }
+              | otherwise = w
+  fixOrderH w | h : hs <- hidden w = w{ hidden = insertAt (pfxH (hidden w0) hs) h hs }
+              | otherwise = w
+  pfxV = commonPrefix `on` fmap (tag . workspace)
+  pfxH = commonPrefix `on` fmap tag
 
--- | Switch to the first of a finite list of WindowSets.
-toggleWindowSets :: (WindowSet -> [WindowSet]) -> X ()
+  insertAt :: Int -> x -> [x] -> [x]
+  insertAt n x xs = let (l, r) = splitAt n xs in l ++ [x] ++ r
+
+  commonPrefix :: Eq x => [x] -> [x] -> Int
+  commonPrefix a b = length $ takeWhile id $ zipWith (==) a b
+
+-- | Given some function that generates a list of workspaces from a
+-- given 'WindowSet', switch to the first generated workspace.
+toggleWindowSets :: (WindowSet -> [WorkspaceId]) -> X ()
 toggleWindowSets genOptions = do
   options <- gets $ genOptions . windowset
   case options of
     []  -> return ()
-    o:_ -> windows (const o)
+    o:_ -> windows (view o)

tests/CycleRecentWS.hs

@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -Wall #-}
+module CycleRecentWS where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+
+import XMonad.Actions.CycleRecentWS (unView)
+import XMonad.StackSet (view, greedyView, mapLayout)
+
+import Instances
+import Utils (tags)
+
+spec :: Spec
+spec = do
+    prop "prop_unView" $ prop_unView
+
+prop_unView :: T -> Property
+prop_unView ss = conjoin
+    [ counterexample desc (unView ss (state (v t ss)) === state ss)
+    | t <- tags ss
+    , (desc, v) <- [("view " <> show t, view), ("greedyView " <> show t, greedyView)] ]
+  where
+    state = mapLayout succ

tests/Main.hs

@@ -10,6 +10,7 @@ import qualified RotateSome
 import qualified Selective
 import qualified SwapWorkspaces
 import qualified XPrompt
+import qualified CycleRecentWS
 
 main :: IO ()
 main = hspec $ do
@@ -45,3 +46,4 @@ main = hspec $ do
         prop "prop_skipGetLastWord"  $ XPrompt.prop_skipGetLastWord
     context "NoBorders" $ NoBorders.spec
     context "ExtensibleConf" $ ExtensibleConf.spec
+    context "CycleRecentWS" $ CycleRecentWS.spec

xmonad-contrib.cabal

@@ -373,15 +373,16 @@ library
 test-suite tests
   type:           exitcode-stdio-1.0
   main-is:        Main.hs
-  other-modules:  ManageDocks
+  other-modules:  CycleRecentWS
+                  Instances
+                  ManageDocks
                   NoBorders
                   RotateSome
                   Selective
                   SwapWorkspaces
-                  XPrompt
-                  Instances
                   Utils
                   ExtensibleConf
+                  XMonad.Actions.CycleRecentWS
                   XMonad.Actions.CycleWS
                   XMonad.Actions.FocusNth
                   XMonad.Actions.PhysicalScreens
@@ -409,6 +410,7 @@ test-suite tests
                   XMonad.Util.WorkspaceCompare
                   XMonad.Util.XSelection
                   XMonad.Util.XUtils
+                  XPrompt
   hs-source-dirs: tests, .
   build-depends: base
                , QuickCheck >= 2