aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Rahm/Desktop/Keys.hs95
-rw-r--r--src/Rahm/Desktop/Lib.hs108
-rw-r--r--src/Rahm/Desktop/Marking.hs8
-rw-r--r--src/Rahm/Desktop/Workspaces.hs136
-rw-r--r--src/Rahm/Desktop/XMobarLog.hs2
5 files changed, 201 insertions, 148 deletions
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index f7aae3c..2f30763 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -61,6 +61,7 @@ import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically)
import Rahm.Desktop.Layout.Rotate (rotateLayout)
import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward)
import Rahm.Desktop.Layout.ConsistentMosaic
+import Rahm.Desktop.Workspaces
type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ())
type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ())
@@ -264,6 +265,19 @@ keymap = runKeys $ do
sendMessage flipHorizontally
bind xK_g $ do
+ let selectWorkspace :: (KeySym, String) -> Maybe (X WorkspaceId)
+ selectWorkspace s = case s of
+ (_, [ch]) | isAlphaNum ch -> Just $ return [ch]
+ (_, "]") -> Just $ adjacentWorkspace next =<< getCurrentWorkspace
+ (_, "[") -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace
+ (_, "}") -> Just $ adjacentScreen next
+ (_, "{") -> Just $ adjacentScreen prev
+ (_, "/") -> Just $ runMaybeT $ do
+ windowId <- askWindowId
+ workspaceWithWindow askWindowId
+ (_, " ") -> Just $ accompaningWorkspace <$> getCurrentWorkspace
+ _ -> Nothing
+
justMod $
doc "Goto a workspace\n\n\t\
@@ -279,35 +293,45 @@ keymap = runKeys $ do
\<space>: Jump to the accompaning workspace.\n\t\t\
\F1: display this help.\n" $
mapNextStringWithKeysym $ \_ keysym str ->
- case (keysym, str) of
- (_, [ch]) | isAlphaNum ch -> gotoWorkspace ch
- (_, "]") -> pushHistory $ withRelativeWorkspace next W.greedyView
- (_, "[") -> pushHistory $ withRelativeWorkspace prev W.greedyView
- (_, "}") -> windows screenRotateForward
- (_, "{") -> windows screenRotateBackward
- (_, " ") -> gotoAccompaningWorkspace
-
+ case ((keysym, str), selectWorkspace (keysym, str)) of
+ (_, Just w) -> pushHistory $ gotoWorkspace =<< w
-- Test binding. Tests that I can still submap keysyms alone (keys
-- where XLookupString won't return anything helpful.)
- (f, _) | f == xK_F1 ->
+ ((f, _), _) | f == xK_F1 ->
(safeSpawn "gxmessage" [
"-fn", "Source Code Pro",
documentation (keymap config)] :: X ())
-
_ -> return ()
+
shiftMod $
doc "Move the currently focused window to another workspace" $
- mapNextString $ \_ str ->
- case str of
- [ch] | isAlphaNum ch -> shiftToWorkspace ch
- "]" -> withRelativeWorkspace next W.shift
- "[" -> withRelativeWorkspace prev W.shift
+ mapNextStringWithKeysym $ \_ keysym str ->
+ case ((keysym, str), selectWorkspace (keysym, str)) of
+ (_, Just w) -> shiftToWorkspace =<< w
+ _ -> return ()
+
+ controlMod $
+ doc "Move the current focused window to another workspace and view that workspace" $
+ mapNextStringWithKeysym $ \_ keysym str ->
+ case ((keysym, str), selectWorkspace (keysym, str)) of
+ (_, Just w) -> pushHistory $ do
+ ws <- w
+ shiftToWorkspace ws
+ gotoWorkspace ws
+ _ -> return ()
+
+ altMod $
+ doc "Copy a window to the given workspace" $
+ mapNextStringWithKeysym $ \_ keysym str ->
+ case ((keysym, str), selectWorkspace (keysym, str)) of
+ (_, Just ws) -> windows . CopyWindow.copy =<< ws
_ -> return ()
+
shiftAltMod $
doc "Swap this workspace with another workspace (rename)." $
- mapNextString $ \_ str ->
- case str of
- [ch] | isAlphaNum ch -> swapWorkspace ch
+ mapNextStringWithKeysym $ \_ keysym str ->
+ case ((keysym, str), selectWorkspace (keysym, str)) of
+ (_, Just ws) -> swapWorkspace =<< ws
_ -> return ()
bind xK_h $ do
@@ -373,16 +397,6 @@ keymap = runKeys $ do
[ch] | isAlphaNum ch -> markCurrentWindow ch
_ -> return ()
- bind xK_n $ do
- justMod $
- doc "Shift to the next workspace." $
- withRelativeWorkspace next W.greedyView
-
- bind xK_p $ do
- justMod $
- doc "Shift to the previous workspace." $
- withRelativeWorkspace prev W.greedyView
-
bind xK_plus $ do
justMod $
doc "Increase the number of windows in the master region." $
@@ -511,14 +525,6 @@ keymap = runKeys $ do
doc "Less often used keybindings." $
subkeys $ do
- bind xK_g $ do
- (justMod -|- noMod) $
- doc "Copy a window to the given workspace" $
- mapNextString $ \_ s ->
- case s of
- [ch] | isAlphaNum ch -> windows (CopyWindow.copy s)
- _ -> return ()
-
bind xK_p $ do
(justMod -|- noMod) $
doc "Go to the prior window in the history" historyPrev
@@ -660,10 +666,12 @@ mouseMap = runButtons $ do
justMod $ \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster
bind button6 $
- justMod $ noWindow (withRelativeWorkspace prev W.greedyView)
+ justMod $
+ noWindow (viewAdjacent prev)
bind button7 $
- justMod $ noWindow (withRelativeWorkspace next W.greedyView)
+ justMod $
+ noWindow (viewAdjacent next)
bind button8 $
justMod $ noWindow mediaPrev
@@ -675,7 +683,7 @@ mouseMap = runButtons $ do
noMod $ subMouse $ do
bind button3 $
- noMod $ noWindow (gotoWorkspace 's')
+ noMod $ noWindow (gotoWorkspace "s")
bind button13 $ do
noMod $ noWindow $ click >> CopyWindow.kill1
@@ -714,7 +722,10 @@ mouseMap = runButtons $ do
bind button15 $ do
noMod $ subMouse $ do
- bind button13 $ noMod $ noWindow gotoAccompaningWorkspace
+ bind button13 $
+ noMod $
+ noWindow $
+ gotoWorkspace =<< (accompaningWorkspace <$> getCurrentWorkspace)
bind button15 $ do
noMod $ noWindow jumpToLast
@@ -723,8 +734,8 @@ mouseMap = runButtons $ do
let workspaceButtons = [
(button2, swapMaster),
- (button9, withRelativeWorkspace next W.greedyView),
- (button8, withRelativeWorkspace prev W.greedyView),
+ (button9, viewAdjacent next),
+ (button8, viewAdjacent prev),
(button4, windows W.focusUp),
(button5, windows W.focusDown),
diff --git a/src/Rahm/Desktop/Lib.hs b/src/Rahm/Desktop/Lib.hs
index 2f90d0a..3b4ee9c 100644
--- a/src/Rahm/Desktop/Lib.hs
+++ b/src/Rahm/Desktop/Lib.hs
@@ -25,86 +25,12 @@ import Data.Ord (comparing)
import qualified XMonad.StackSet as S
import Rahm.Desktop.Windows
-type WorkspaceName = Char
-newtype Selector = Selector (forall a. (Eq a) => a -> [a] -> a)
-
data WinPrompt = WinPrompt
instance XPrompt WinPrompt where
showXPrompt _ = "[Window] "
commandToComplete _ = id
-data WorkspaceState = Current | Hidden | Visible
- deriving (Ord, Eq, Enum)
-
--- Returns all the workspaces that are either visible, current or Hidden but
--- have windows and that workspace's state.
---
--- In other words, filters out workspaces that have no windows and are not
--- visible.
---
--- This function will sort the result by the workspace tag.
-getPopulatedWorkspaces ::
- (Ord i) => S.StackSet i l a sid sd -> [(WorkspaceState, S.Workspace i l a)]
-getPopulatedWorkspaces (S.StackSet (S.Screen cur _ _) vis hi _) =
- sortOn (tag . snd) $
- mapMaybe (\w@(S.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi ++
- map (\(S.Screen w _ _) -> (Visible, w)) vis ++
- [(Current, cur)]
-
-getHorizontallyOrderedScreens ::
- StackSet wid l a ScreenId ScreenDetail ->
- [Screen wid l a ScreenId ScreenDetail]
--- ^ Returns a list of screens ordered from leftmost to rightmost.
-getHorizontallyOrderedScreens windowSet =
- flip sortBy screens $ \sc1 sc2 ->
- let (SD (Rectangle x1 _ _ _)) = screenDetail sc1
- (SD (Rectangle x2 _ _ _)) = screenDetail sc2
- in x1 `compare` x2
- where
- screens = current windowSet : visible windowSet
-
-getCurrentWorkspace :: X WorkspaceName
-getCurrentWorkspace = withWindowSet $
- \(StackSet (Screen (Workspace t _ _) _ _) _ _ _) -> do
- return (head t)
-
-gotoAccompaningWorkspace :: X ()
-gotoAccompaningWorkspace = do
- cur <- getCurrentWorkspace
- if isUpper cur
- then gotoWorkspace (toLower cur)
- else gotoWorkspace (toUpper cur)
-
-gotoWorkspace :: WorkspaceName -> X ()
-gotoWorkspace ch = pushHistory $ do
- addHiddenWorkspace [ch]
- windows $ greedyView $ return ch
-
-shiftToWorkspace :: WorkspaceName -> X ()
-shiftToWorkspace ch = do
- addHiddenWorkspace [ch]
- (windows . shift . return) ch
-
-swapWorkspace :: WorkspaceName -> X ()
-swapWorkspace toWorkspaceName = do
- addHiddenWorkspace [toWorkspaceName]
- windows $ \ss -> do
- let fromWorkspace = tag $ workspace $ current ss
- toWorkspace = [toWorkspaceName] in
- StackSet (swapSc fromWorkspace toWorkspace $ current ss)
- (map (swapSc fromWorkspace toWorkspace) $ visible ss)
- (map (swapWs fromWorkspace toWorkspace) $ hidden ss)
- (floating ss)
- where
- swapSc fromWorkspace toWorkspace (Screen ws a b) =
- Screen (swapWs fromWorkspace toWorkspace ws) a b
-
- swapWs fromWorkspace toWorkspace ws@(Workspace t' l s)
- | t' == fromWorkspace = Workspace toWorkspace l s
- | t' == toWorkspace = Workspace fromWorkspace l s
- | otherwise = ws
-
fuzzyCompletion :: String -> String -> Bool
fuzzyCompletion str0 str1 =
all (`isInfixOf`l0) ws
@@ -121,38 +47,16 @@ getString = runQuery $ do
then t
else printf "%s - %s" t a
-withRelativeWorkspace :: Selector -> (WorkspaceId -> WindowSet -> WindowSet) -> X ()
-withRelativeWorkspace (Selector selector) fn =
- windows $ \ss ->
- let tags = sort (tag . snd <$> filter (\x -> fst x /= Visible ) (getPopulatedWorkspaces ss))
- from = tag $ workspace $ current ss
- to = selector from tags
- in fn to ss
-
-next :: Selector
-next = Selector $ \a l -> select a l l
- where select n (x:y:xs) _ | n == x = y
- select n [x] (y:_) | n == x = y
- select n (x:xs) orig = select n xs orig
- select n _ _ = n
-
-prev :: Selector
-prev = Selector $ \a l ->
- let (Selector fn) = next in fn a (reverse l)
+askWindowId :: X (Maybe Window)
+askWindowId = pushHistory $ do
+ windowTitlesToWinId <- withWindowSet $ \ss ->
+ Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss)
-withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X ()
-withScreen fn n = do
- windows $ \windowSet ->
- case getHorizontallyOrderedScreens windowSet !! n of
- Nothing -> windowSet
- Just screen -> fn (tag $ workspace screen) windowSet
+ runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId
windowJump :: X ()
windowJump = pushHistory $ do
- windowTitlesToWinId <- withWindowSet $ \ss ->
- Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss)
-
- windowId <- runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId
+ windowId <- askWindowId
case windowId of
Nothing -> return ()
diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs
index 8ca50fd..1144ad7 100644
--- a/src/Rahm/Desktop/Marking.hs
+++ b/src/Rahm/Desktop/Marking.hs
@@ -94,7 +94,7 @@ instance ExtensionClass MarkState where
changeHistory :: (History Spot -> History Spot) -> (MarkState -> MarkState)
changeHistory fn ms = ms { windowHistory = fn (windowHistory ms)}
-withMaybeFocused :: (Maybe Window -> X ()) -> X ()
+withMaybeFocused :: (Maybe Window -> X a) -> X a
withMaybeFocused f = withWindowSet $ f . peek
normalizeWindows :: X ()
@@ -118,7 +118,7 @@ markCurrentWindow mark = do
markStateMap = Map.insert mark win ms
}
-pushHistory :: X () -> X ()
+pushHistory :: X a -> X a
pushHistory fn = do
withMaybeFocused $ \maybeWindowBefore -> do
case maybeWindowBefore of
@@ -128,7 +128,7 @@ pushHistory fn = do
withWindowSet $ \ws ->
XS.modify $ changeHistory (historyPush (TagSpot (currentTag ws)))
- fn
+ ret <- fn
withMaybeFocused $ \maybeWindowAfter ->
case maybeWindowAfter of
@@ -138,6 +138,8 @@ pushHistory fn = do
withWindowSet $ \ws ->
XS.modify $ changeHistory (historyPush $ TagSpot $ currentTag ws)
+ return ret
+
withHistory :: (History Spot -> X ()) -> X ()
withHistory fn = do
MarkState { windowHistory = w } <- XS.get
diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs
new file mode 100644
index 0000000..87d112e
--- /dev/null
+++ b/src/Rahm/Desktop/Workspaces.hs
@@ -0,0 +1,136 @@
+
+-- Common ways to select workspaces
+module Rahm.Desktop.Workspaces where
+
+import Prelude hiding ((!!))
+
+import Control.Arrow (second, (&&&))
+import qualified XMonad.StackSet as W
+import XMonad
+
+import Data.List.Safe ((!!))
+
+import XMonad.Actions.DynamicWorkspaces
+import Data.List (sortOn, sort, sortBy, find)
+import Data.Maybe (mapMaybe, fromMaybe)
+import Data.Char (isUpper, toUpper, toLower)
+
+newtype Selector = Selector (forall a. (a -> Bool) -> [a] -> Maybe a)
+
+data WorkspaceState = Current | Hidden | Visible
+ deriving (Ord, Eq, Enum)
+
+-- Returns all the workspaces that are either visible, current or Hidden but
+-- have windows and that workspace's state.
+--
+-- In other words, filters out workspaces that have no windows and are not
+-- visible.
+--
+-- This function will sort the result by the workspace tag.
+getPopulatedWorkspaces ::
+ (Ord i) => W.StackSet i l a sid sd -> [(WorkspaceState, W.Workspace i l a)]
+getPopulatedWorkspaces (W.StackSet (W.Screen cur _ _) vis hi _) =
+ sortOn (W.tag . snd) $
+ mapMaybe (\w@(W.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi ++
+ map (\(W.Screen w _ _) -> (Visible, w)) vis ++
+ [(Current, cur)]
+
+next :: Selector
+next = Selector $ \f l -> select f l l
+ where select f (x:y:xs) _ | f x = Just y
+ select f [x] (y:_) | f x = Just y
+ select f (x:xs) orig = select f xs orig
+ select f _ _ = Nothing
+
+prev :: Selector
+prev = Selector $ \f l ->
+ let (Selector fn) = next in fn f (reverse l)
+
+getCurrentWorkspace :: X WorkspaceId
+getCurrentWorkspace = withWindowSet $
+ \(W.StackSet (W.Screen (W.Workspace t _ _) _ _) _ _ _) -> do
+ return t
+
+getHorizontallyOrderedScreens ::
+ W.StackSet wid l a ScreenId ScreenDetail ->
+ [(Bool, W.Screen wid l a ScreenId ScreenDetail)]
+-- ^ Returns a list of screens ordered from leftmost to rightmost.
+getHorizontallyOrderedScreens windowSet =
+ flip sortBy screens $ \sc1 sc2 ->
+ let (SD (Rectangle x1 _ _ _)) = W.screenDetail (snd sc1)
+ (SD (Rectangle x2 _ _ _)) = W.screenDetail (snd sc2)
+ in x1 `compare` x2
+ where
+ screens = (True, W.current windowSet) : map (False,) (W.visible windowSet)
+
+gotoWorkspace :: WorkspaceId -> X ()
+gotoWorkspace wid = do
+ addHiddenWorkspace wid
+ windows $ W.greedyView wid
+
+shiftToWorkspace :: WorkspaceId -> X ()
+shiftToWorkspace t = do
+ addHiddenWorkspace t
+ windows . W.shift $ t
+
+
+accompaningWorkspace :: WorkspaceId -> WorkspaceId
+accompaningWorkspace [s] = return $
+ if isUpper s
+ then toLower s
+ else toUpper s
+accompaningWorkspace s = s
+
+swapWorkspace :: WorkspaceId -> X ()
+swapWorkspace toWorkspace = do
+ addHiddenWorkspace toWorkspace
+ windows $ \ss -> do
+ let fromWorkspace = W.tag $ W.workspace $ W.current ss in
+ W.StackSet (swapSc fromWorkspace toWorkspace $ W.current ss)
+ (map (swapSc fromWorkspace toWorkspace) $ W.visible ss)
+ (map (swapWs fromWorkspace toWorkspace) $ W.hidden ss)
+ (W.floating ss)
+ where
+ swapSc fromWorkspace toWorkspace (W.Screen ws a b) =
+ W.Screen (swapWs fromWorkspace toWorkspace ws) a b
+
+ swapWs fromWorkspace toWorkspace ws@(W.Workspace t' l s)
+ | t' == fromWorkspace = W.Workspace toWorkspace l s
+ | t' == toWorkspace = W.Workspace fromWorkspace l s
+ | otherwise = ws
+
+adjacentWorkspace :: Selector -> WorkspaceId -> X WorkspaceId
+adjacentWorkspace (Selector selector) from =
+ withWindowSet $ \ss ->
+ let tags = sort $
+ W.tag . snd <$> (filter (\x -> fst x /= Visible) $
+ getPopulatedWorkspaces ss)
+ in
+ return $ fromMaybe from $ selector (==from) tags
+
+viewAdjacent :: Selector -> X ()
+viewAdjacent sel =
+ gotoWorkspace =<< (adjacentWorkspace sel =<< getCurrentWorkspace)
+
+adjacentScreen :: Selector -> X WorkspaceId
+adjacentScreen (Selector f) = do
+ (screens, current) <-
+ withWindowSet $ return . (getHorizontallyOrderedScreens &&& W.current)
+
+ return $ W.tag $ W.workspace $ fromMaybe current (snd <$> f fst screens)
+
+withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X ()
+withScreen fn n = do
+ windows $ \windowSet ->
+ case map snd (getHorizontallyOrderedScreens windowSet) !! n of
+ Nothing -> windowSet
+ Just screen -> fn (W.tag $ W.workspace screen) windowSet
+
+
+workspaceWithWindow :: Window -> X (Maybe WorkspaceId)
+workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) ->
+ return $
+ W.tag <$>
+ find (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack)
+ (map W.workspace (c : v) ++ h)
+
diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs
index 82c05b7..4f8bbb8 100644
--- a/src/Rahm/Desktop/XMobarLog.hs
+++ b/src/Rahm/Desktop/XMobarLog.hs
@@ -11,7 +11,7 @@ import System.IO (Handle, hSetEncoding, hPutStrLn, utf8)
import XMonad.Util.NamedWindows (getName)
import XMonad.Util.Run (spawnPipe)
import XMonad (X)
-import Rahm.Desktop.Lib (getPopulatedWorkspaces, WorkspaceState(..))
+import Rahm.Desktop.Workspaces (getPopulatedWorkspaces, WorkspaceState(..))
import Text.Printf
import qualified XMonad as X
generated by cgit (git 2.34.1) at 2026-02-22 21:29:31 +0000