aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Main.hs4
-rw-r--r--src/Rahm/Desktop/History.hs197
-rw-r--r--src/Rahm/Desktop/Hooks/WindowChange.hs39
3 files changed, 127 insertions, 113 deletions
diff --git a/src/Main.hs b/src/Main.hs
index e2c9407..6166518 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -9,7 +9,7 @@ import Rahm.Desktop.Common
)
import Rahm.Desktop.DMenu (menuCommandString)
import Rahm.Desktop.History (historyHook)
-import Rahm.Desktop.Hooks.WindowChange (withLocationChangeHook)
+import Rahm.Desktop.Hooks.WindowChange (withStackChangeHook)
import Rahm.Desktop.Keys (applyKeys)
import Rahm.Desktop.Layout (myLayout)
import Rahm.Desktop.Logger (LogLevel (Debug, Info), logs)
@@ -81,7 +81,7 @@ main = do
(=<<) X.xmonad $
applyKeys $
- withLocationChangeHook historyHook $
+ withStackChangeHook historyHook $
ewmh $
docks $
def
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))
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
}
generated by cgit (git 2.34.1) at 2026-02-22 15:45:02 +0000