From ecbe2eb4cc3785e9e921671d0574cec48c270d42 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 26 Nov 2023 12:53:19 -0700 Subject: 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. --- src/Rahm/Desktop/History.hs | 197 +++++++++++++++++---------------- src/Rahm/Desktop/Hooks/WindowChange.hs | 39 ++++--- 2 files changed, 125 insertions(+), 111 deletions(-) (limited to 'src/Rahm/Desktop') 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 _ = "" 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)) diff --git a/src/Rahm/Desktop/Hooks/WindowChange.hs b/src/Rahm/Desktop/Hooks/WindowChange.hs index a7d403e..4cb2371 100644 --- a/src/Rahm/Desktop/Hooks/WindowChange.hs +++ b/src/Rahm/Desktop/Hooks/WindowChange.hs @@ -1,28 +1,41 @@ module Rahm.Desktop.Hooks.WindowChange where import Control.Monad (when) +import Control.Monad.State (gets) import Data.Default (Default (..)) import Rahm.Desktop.Common ( Location (Location), + getCurrentScreen, getCurrentWorkspace, ) import qualified Rahm.Desktop.StackSet as W (peek) import XMonad ( ExtensionClass (..), + ScreenDetail, + ScreenId, StateExtension (PersistentExtension), + Window, + WorkspaceId, X, XConfig (logHook), + windowset, withWindowSet, ) +import XMonad.StackSet import qualified XMonad.Util.ExtensibleState as XS (get, put) -newtype LastLocation = LastLocation (Maybe Location) +type WindowStack = StackSet WorkspaceId () Window ScreenId ScreenDetail + +-- Type of hook. Takes the last WindowStack and the new WindowStack +type StackChangeHook = WindowStack -> WindowStack -> X () + +newtype LastState = LastState (Maybe WindowStack) deriving (Read, Show) -instance Default LastLocation where - def = LastLocation Nothing +instance Default LastState where + def = LastState def -instance ExtensionClass LastLocation where +instance ExtensionClass LastState where initialValue = def extensionType = PersistentExtension @@ -32,20 +45,16 @@ instance ExtensionClass LastLocation where -- the new window. -- -- If the first window is Nothing, this is the first time XMonad started. -withLocationChangeHook :: (Maybe Location -> Location -> X ()) -> XConfig l -> XConfig l -withLocationChangeHook fn config = +withStackChangeHook :: StackChangeHook -> XConfig l -> XConfig l +withStackChangeHook fn config = config { logHook = do logHook config - currentLocation <- - Location <$> getCurrentWorkspace <*> withWindowSet (return . W.peek) - - LastLocation last <- XS.get - - when (last /= Just currentLocation) $ - fn last currentLocation + current <- gets (mapLayout (const ()) . windowset) + LastState last <- XS.get + XS.put (LastState $ Just current) - XS.put $ LastLocation $ Just currentLocation - return () + when (Just current /= last) $ + mapM_ (`fn` current) last } -- cgit