Better implementation of history.

Each screen now has its own history and if a workspace is swapped with
another visible workspace, the history between those screens is also
swapped, so this gives a feeling of a kind of persistent history that
follows the screen.

1 files changed, 101 insertions, 96 deletions

diff --git a/src/Rahm/Desktop/History.hs b/src/Rahm/Desktop/History.hs
index dc6d6a1..e39171f 100644
--- a/src/Rahm/Desktop/History.hs
+++ b/src/Rahm/Desktop/History.hs
@@ -13,16 +13,20 @@ module Rahm.Desktop.History
   )
 where
 
+import Control.Monad (forM_, when)
 import Data.Default (Default (..))
-import Data.Foldable (toList)
+import Data.Foldable (find, toList)
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Data.Sequence (Seq (..))
 import qualified Data.Sequence as Seq (length, (!?))
-import Rahm.Desktop.Common (Location (Location), focusLocation, getCurrentScreen)
+import Rahm.Desktop.Common (Location (Location), focusLocation, getCurrentScreen, getCurrentWorkspace)
+import Rahm.Desktop.Hooks.WindowChange
+import Rahm.Desktop.Logger
 import Text.Printf (printf)
 import XMonad (ExtensionClass (extensionType, initialValue), ScreenId, StateExtension (..), X)
+import XMonad.StackSet
 import qualified XMonad.Util.ExtensibleState as XS
   ( get,
     modify,
@@ -35,18 +39,26 @@ data BoundedSeqZipper a = BoundedSeqZipper Int (Seq a) (Seq a)
 instance Functor BoundedSeqZipper where
   fmap fn (BoundedSeqZipper i h t) = BoundedSeqZipper i (fmap fn h) (fmap fn t)
 
-zipperDbgPrint :: (Show a) => BoundedSeqZipper a -> String
+popSeqZipper :: BoundedSeqZipper a -> BoundedSeqZipper a
+popSeqZipper (BoundedSeqZipper n h (c :<| t)) = BoundedSeqZipper n h t
+popSeqZipper a = a
+
+zipperDbgPrint :: BoundedSeqZipper Location -> String
 zipperDbgPrint (BoundedSeqZipper _ h (c :<| t)) =
   concat $
-    map (printf " %s " . show) (toList h)
-      ++ [printf "[%s]" (show c)]
-      ++ map (printf " %s " . show) (toList t)
+    map (printf " %s " . showLoc) (toList h)
+      ++ [printf "[%s]" (showLoc c)]
+      ++ map (printf " %s " . showLoc) (toList t)
+  where
+    showLoc :: Location -> String
+    showLoc (Location workspaceId windowId) =
+      printf "%s@%s" (maybe "nil" show windowId) workspaceId
 zipperDbgPrint _ = "<empty>"
 
 pushZipper :: a -> BoundedSeqZipper a -> BoundedSeqZipper a
 pushZipper e (BoundedSeqZipper maxSize _ (tail :|> _))
   | maxSize <= Seq.length tail =
-    BoundedSeqZipper maxSize mempty (e :<| tail)
+      BoundedSeqZipper maxSize mempty (e :<| tail)
 pushZipper e (BoundedSeqZipper maxSize _ tail) =
   BoundedSeqZipper maxSize mempty (e :<| tail)
 
@@ -54,6 +66,9 @@ getZipper :: BoundedSeqZipper a -> Maybe a
 getZipper (BoundedSeqZipper _ _ (e :<| _)) = Just e
 getZipper _ = Nothing
 
+emptyZipper :: BoundedSeqZipper a
+emptyZipper = BoundedSeqZipper 1000 mempty mempty
+
 zipperBack :: BoundedSeqZipper a -> BoundedSeqZipper a
 zipperBack (BoundedSeqZipper s h (e :<| t)) = BoundedSeqZipper s (e :<| h) t
 zipperBack b = b
@@ -62,124 +77,114 @@ zipperForward :: BoundedSeqZipper a -> BoundedSeqZipper a
 zipperForward (BoundedSeqZipper s (e :<| h) t) = BoundedSeqZipper s h (e :<| t)
 zipperForward b = b
 
-data History = History
-  { historyByScreenId :: Map ScreenId (BoundedSeqZipper Location),
-    gobalHistory :: BoundedSeqZipper Location
+newtype History = History
+  { historyByScreenId :: Map ScreenId (BoundedSeqZipper Location)
   }
   deriving (Read, Show)
 
 instance Default History where
-  def = History mempty (BoundedSeqZipper 1000 mempty mempty)
+  def = History mempty
 
 instance ExtensionClass History where
   initialValue = def
   extensionType = PersistentExtension
 
 getCurrentZipper :: ScreenId -> History -> BoundedSeqZipper Location
-getCurrentZipper screenId (History byScreenId _) =
+getCurrentZipper screenId (History byScreenId) =
   fromMaybe
-    (BoundedSeqZipper 1000 mempty mempty)
+    emptyZipper
     (Map.lookup screenId byScreenId)
 
-historyDo :: (forall a. BoundedSeqZipper a -> BoundedSeqZipper a) -> X ()
-historyDo f = do
-  screenId <- getCurrentScreen
-  History byScreenId gb <- XS.get
-  let mz' = Map.lookup screenId byScreenId
-  case mz' of
-    Nothing ->
-      return ()
-    Just z -> do
-      let z' = f z
-      mapM_ focusLocation (getZipper z')
-      XS.put
-        ( History (Map.insert screenId z' byScreenId) gb
-        )
-
+historyBack :: X ()
 historyBack = historyDo zipperBack
 
+historyForward :: X ()
 historyForward = historyDo zipperForward
 
 jumpToLastLocation :: X ()
-jumpToLastLocation = mapM_ focusLocation =<< lastLocation
-
--- pastGlobalHistory :: Int -> X (Maybe Location)
--- pastGlobalHistory i = do
---   History (BoundedSeqZipper _ _ t) _ <- XS.get
---   return $ t Seq.!? i
---
--- getMostRecentLocationInGlobalHistory :: X (Maybe Location)
--- getMostRecentLocationInGlobalHistory = do
---   History z _ <- XS.get
---   case z of
---     (BoundedSeqZipper _ (_ :|> h) _) -> return $ Just h
---     (BoundedSeqZipper _ _ (t :<| _)) -> return $ Just t
---     _ -> return Nothing
---
--- globalHistoryBack :: X ()
--- globalHistoryBack = do
---   History z _ <- XS.get
---   let z' = zipperBack z
---   mapM_ focusLocation (getZipper z')
---   XS.put (History z')
---
--- globalHistoryForward :: X ()
--- globalHistoryForward = do
---   History z _ <- XS.get
---   let z' = zipperForward z
---   mapM_ focusLocation (getZipper z')
---   XS.put (History z')
---
--- lastLocation :: X (Maybe Location)
--- lastLocation = getZipper . zipperBack . currentZipper <$> XS.get
---
--- nextLocation :: X (Maybe Location)
--- nextLocation = getZipper . zipperForward . currentZipper <$> XS.get
---
--- jumpToLastLocation :: X ()
--- jumpToLastLocation = mapM_ focusLocation =<< lastLocation
---
+jumpToLastLocation = do
+  logs Trace "Jumping to Last Location."
+  mapM_ focusLocation =<< lastLocation
 
 -- Get the last location for the current screen.
 lastLocation :: X (Maybe Location)
 lastLocation = do
   screenId <- getCurrentScreen
-  getZipper . zipperBack . getCurrentZipper screenId <$> XS.get
+  ret <- getZipper . getCurrentZipper screenId <$> XS.get
+  XS.modify $ \(History byScreen) ->
+    History (Map.adjust popSeqZipper screenId byScreen)
+  return ret
 
 nextLocation :: X (Maybe Location)
 nextLocation = do
   screenId <- getCurrentScreen
   getZipper . zipperForward . getCurrentZipper screenId <$> XS.get
 
-historyHook :: Maybe Location -> Location -> X ()
-historyHook Nothing loc = do
-  currentScreen <- getCurrentScreen
+dbgLogHistory :: X ()
+dbgLogHistory = do
+  (History byScreen) <- XS.get
+  logs Trace "History State: \n"
+  forM_ (Map.toList byScreen) $ \(screenId, hist) ->
+    logs Trace "%s    ->    %s\n" (show screenId) (zipperDbgPrint hist)
 
-  XS.modify $ \(History byScreen global) ->
-    History
-      ( Map.alter
-          ( Just
-              . pushZipper loc
-              . fromMaybe (BoundedSeqZipper 1000 mempty mempty)
-          )
-          currentScreen
-          byScreen
-      )
-      (pushZipper loc global)
+historyHook :: WindowStack -> WindowStack -> X ()
 -- History hook where the 'from' location workspace does not match the 'to'
 -- location workspace.
-historyHook (Just (Location ws _)) l@(Location ws' _) | ws /= ws' = do
-  currentScreen <- getCurrentScreen
-
-  XS.modify $ \(History byScreen z) ->
-    History
-      ( Map.alter
-          ( Just
-              . pushZipper l
-              . fromMaybe (BoundedSeqZipper 1000 mempty mempty)
+historyHook lastWindowSet currentWindowSet = do
+  let (sc1, ws1, win1) = getWindowsetData lastWindowSet
+      (sc2, ws2, win2) = getWindowsetData currentWindowSet
+      l1 = Location ws1 win1
+
+  case () of
+    -- We moved to a previously invisible workspace
+    () | not (ws2 `visibleIn` lastWindowSet) -> do
+      logs Trace "Jumped to hidden workspace"
+      XS.modify $ \(History byScreen) ->
+        History
+          ( Map.alter
+              (Just . pushZipper l1 . fromMaybe emptyZipper)
+              sc2
+              byScreen
           )
-          currentScreen
-          byScreen
-      )
-      (pushZipper l z)
-historyHook _ _ = return ()
+
+    -- We moved to a workspace that was on a different monitor, but was still
+    -- visible. In this case, we'll swap the history for the current screen with
+    -- the screen that the workspace was previously on. This will keep
+    -- per-screen history somewhat persistent
+    ()
+      | ws1 /= ws2 && sc1 == sc2,
+        (Just oldScreen) <- screenOf ws2 lastWindowSet -> do
+          logs Trace "Just Swapping Screens"
+          XS.modify $ \(History byScreen) ->
+            History (mapSwap oldScreen sc2 byScreen)
+
+    -- This is typically the case when changing focus to a different monitor,
+    -- but did not actually swap anything.
+    _ -> return ()
+
+  dbgLogHistory
+  where
+    mapSwap k1 k2 map =
+      Map.alter (const $ Map.lookup k2 map) k1 $
+        Map.alter (const $ Map.lookup k1 map) k2 map
+
+    visibleIn wsId ws = isJust $ screenOf wsId ws
+
+    screenOf wsId ws@(StackSet cur vis _ _) =
+      screen <$> find ((== wsId) . tag . workspace) (cur : vis)
+
+    getWindowsetData ws@(StackSet cur vis hidden floating) =
+      (screen cur, tag $ workspace cur, focus <$> stack (workspace cur))
+
+historyDo :: (forall a. BoundedSeqZipper a -> BoundedSeqZipper a) -> X ()
+historyDo f = do
+  screenId <- getCurrentScreen
+  History byScreenId <- XS.get
+  let mz' = Map.lookup screenId byScreenId
+  case mz' of
+    Nothing ->
+      return ()
+    Just z -> do
+      let z' = f z
+      mapM_ focusLocation (getZipper z')
+      XS.put (History (Map.insert screenId z' byScreenId))