aboutsummaryrefslogtreecommitdiff
path: root/src/Rahm/Desktop/History.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rahm/Desktop/History.hs')
-rw-r--r--src/Rahm/Desktop/History.hs197
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))
generated by cgit (git 2.34.1) at 2026-02-22 16:10:44 +0000