aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Rahm/Desktop/Common.hs13
-rw-r--r--src/Rahm/Desktop/DMenu.hs2
-rw-r--r--src/Rahm/Desktop/Keys.hs12
-rw-r--r--src/Rahm/Desktop/Keys/Wml.hs252
-rw-r--r--src/Rahm/Desktop/Lang.hs127
-rw-r--r--src/Rahm/Desktop/Marking.hs6
6 files changed, 264 insertions, 148 deletions
diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index 5a5aecf..c12322a 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -57,13 +57,6 @@ instance XPrompt WinPrompt where
showXPrompt _ = "[Window] "
commandToComplete _ = id
-fuzzyCompletion :: String -> String -> Bool
-fuzzyCompletion str0 str1 =
- all (`isInfixOf`l0) ws
- where
- ws = filter (not . all isSpace) $ words (map toLower str0)
- l0 = map toLower str1
-
getString :: Window -> X String
getString = runQuery $ do
t <- title
@@ -88,6 +81,12 @@ gotoWorkspace wid = do
addHiddenWorkspace wid
windows $ S.greedyView wid
+moveLocationToWorkspace :: Location -> WorkspaceId -> X ()
+moveLocationToWorkspace (Location _ (Just win)) wid = do
+ addHiddenWorkspace wid
+ windows $ shiftWin wid win
+moveLocationToWorkspace _ _ = return ()
+
getCurrentWorkspace :: X WorkspaceId
getCurrentWorkspace = withWindowSet $
\(S.StackSet (S.Screen (S.Workspace t _ _) _ _) _ _ _) -> do
diff --git a/src/Rahm/Desktop/DMenu.hs b/src/Rahm/Desktop/DMenu.hs
index 62ecdd3..d20d001 100644
--- a/src/Rahm/Desktop/DMenu.hs
+++ b/src/Rahm/Desktop/DMenu.hs
@@ -16,7 +16,7 @@ data Colors =
} | DefaultColors
menuCommand :: [String]
-menuCommand = ["rofi", "-monitor", "-4", "-dmenu", "-sort", "-levenshtein-sort"]
+menuCommand = ["rofi", "-monitor", "-4", "-i", "-dmenu", "-sort", "-levenshtein-sort"]
menuCommandString :: String
menuCommandString = unwords menuCommand
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index da3b695..6973b81 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -52,7 +52,7 @@ import Rahm.Desktop.Layout.Rotate (rotateLayout)
import Rahm.Desktop.Common
import Rahm.Desktop.Logger
import Rahm.Desktop.Marking
-import Rahm.Desktop.Lang
+import Rahm.Desktop.Keys.Wml
import Rahm.Desktop.MouseMotion
import Rahm.Desktop.PassMenu
import Rahm.Desktop.PromptConfig
@@ -140,7 +140,7 @@ keymap = runKeys $ do
let subkeys keysM = Submap (runKeys keysM config)
repeatable keysM = Repeat (runKeys keysM config)
- bind xK_apostrophe $ do
+ forM_ [xK_apostrophe, xK_w] $ \k -> bind k $ do
justMod $
doc "Jumps between marks." $
runMaybeT_ $ do
@@ -189,8 +189,9 @@ keymap = runKeys $ do
bind xK_F8 $
justMod $
- doc "Print this documentation." $
- sendMessage toggleHole
+ doc "Experimental" $ do
+ (logs . printf "WS: %s" . show . fmap workspaceName) =<< workspaceForString ",^"
+ (logs . printf "Wins: %s" . show) =<< locationSetForString "&s@,^"
bind xK_F10 $ do
justMod playPauseDoc
@@ -489,9 +490,6 @@ keymap = runKeys $ do
bind xK_v $
justMod (return () :: X ())
- bind xK_w $ do
- justMod $ doc "Jump to a window (via rofi)" windowJump
-
bind xK_x $ do
justMod $
doc "Toggles respect for struts." $
diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
new file mode 100644
index 0000000..47be2e7
--- /dev/null
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -0,0 +1,252 @@
+-- Wml: Window Management Language.
+--
+-- Parser for WML objects
+--
+-- Some examples of WML objects are:
+--
+-- a // The workspace or window (context dependent) tagged 'a'
+-- @a // All windows on workspace 'a' or the workspace with window 'a'
+-- ,. // The workspace to to the right of the current one.
+-- @,. // All windows on the workspace to the right of the current one.
+-- @,^ // All the windows on the screen second from the left
+-- &z!~@,,^ // The window tagged with z and The last window on the screen third from the left
+-- @@s // All the windows that share a workspace with the window tagged s
+-- \%@s // All windows except those on workspace 's'
+module Rahm.Desktop.Keys.Wml where
+
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.State as S
+import Control.Monad.Trans.Class
+import Control.Monad (join, forM_)
+
+import Data.Char (isAlphaNum, isAlpha, isDigit, ord)
+import Data.Maybe (fromMaybe)
+import XMonad.Actions.CopyWindow as CopyWindow
+import XMonad.Util.Run (safeSpawn)
+import Prelude hiding (head, last)
+import Data.List.Safe (head, last)
+import qualified XMonad.StackSet as W
+
+import Rahm.Desktop.Common
+import Rahm.Desktop.Keys.Dsl
+import Rahm.Desktop.History
+import Rahm.Desktop.Marking
+import Rahm.Desktop.Workspaces
+import Rahm.Desktop.Submap
+import Rahm.Desktop.Logger
+
+import Text.Printf
+
+import XMonad
+
+data Workspace =
+ Workspace {
+ moveLocationToWorkspaceFn :: Location -> X ()
+ , gotoWorkspaceFn :: X ()
+ , workspaceName :: String
+ }
+
+justWorkspace :: String -> Workspace
+justWorkspace s =
+ Workspace {
+ moveLocationToWorkspaceFn = flip moveLocationToWorkspace s
+ , gotoWorkspaceFn = gotoWorkspace s
+ , workspaceName = s
+ }
+
+blackHoleWorkspace :: Workspace
+blackHoleWorkspace =
+ Workspace {
+ moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow
+ , gotoWorkspaceFn = return () -- can't navigate to black hole
+ , workspaceName = "blackhole"
+ }
+
+alternateWorkspace :: Workspace
+alternateWorkspace =
+ Workspace {
+ moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do
+ logs $ "Moving Location: " ++ show l
+ case maybeWin of
+ Nothing -> return ()
+ Just win -> do
+ alter <- getAlternateWorkspace win
+ logs $ printf "Moving %s to %s" (show win) (show alter)
+ mapM_ (moveLocationToWorkspace l) alter
+
+ , gotoWorkspaceFn = do
+ (Location _ maybeWin) <- getCurrentLocation
+ case maybeWin of
+ Nothing -> return ()
+ Just win -> do
+ mapM_ gotoWorkspace =<< getAlternateWorkspace win
+
+ , workspaceName = "@"
+ }
+
+floatWorkspace :: Workspace -> Workspace
+floatWorkspace ws =
+ Workspace {
+ moveLocationToWorkspaceFn = \location -> do
+ forM_ (locationWindow location) $ \win -> do
+ logs $ "Float " ++ show win
+ windows $ W.float win (W.RationalRect 0 0 100 100)
+ withWindowSet $ logs . show . W.floating
+ moveLocationToWorkspaceFn ws location
+ , gotoWorkspaceFn = gotoWorkspaceFn ws
+ , workspaceName = workspaceName ws
+ }
+
+joinMaybe :: (Monad m) => MaybeT m (Maybe a) -> MaybeT m a
+joinMaybe (MaybeT ma) = MaybeT $ join <$> ma
+
+class (Monad m) => KeyFeeder m where
+ fromX :: X a -> m a
+
+ fromMaybeTX :: MaybeT X a -> MaybeT m a
+ fromMaybeTX = mapMaybeT fromX
+
+ readNextKey ::
+ (KeyMask -> KeySym -> String -> MaybeT m a) -> MaybeT m a
+
+instance KeyFeeder X where
+ fromX = id
+ readNextKey = mapNextStringWithKeysym
+
+newtype FeedKeys a = FeedKeys { unFeedKeys :: StateT String X a }
+ deriving (Monad, Functor, Applicative)
+
+instance KeyFeeder FeedKeys where
+ fromX = FeedKeys . lift
+
+ readNextKey fn = do
+ ls <- lift $ FeedKeys S.get
+ case ls of
+ (h:t) -> do
+ lift $ FeedKeys $ S.put t
+ fn 0 0 [h]
+ _ -> MaybeT (return Nothing)
+
+feedKeys :: String -> MaybeT FeedKeys a -> X (Maybe a)
+feedKeys s mf = flip evalStateT s . unFeedKeys $ runMaybeT mf
+
+feedKeysT :: String -> MaybeT FeedKeys a -> MaybeT X a
+feedKeysT s mf = MaybeT $ feedKeys s mf
+
+-- Allows a reference to a workspace in terms of its description in the window
+-- management language.
+workspaceForStringT :: String -> MaybeT X Workspace
+workspaceForStringT str = feedKeysT str readNextWorkspace
+
+-- Like the above, but unwrap the MaybeT
+workspaceForString :: String -> X (Maybe Workspace)
+workspaceForString = runMaybeT . workspaceForStringT
+
+-- Like the above, but unwrap the MaybeT
+locationSetForStringT :: String -> MaybeT X [Location]
+locationSetForStringT s = feedKeysT s readNextLocationSet
+
+locationSetForString :: String -> X [Location]
+locationSetForString s = fromMaybe [] <$> (runMaybeT $ locationSetForStringT s)
+
+-- Returns the next workspaces associated with the next set of keystrokes.
+readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace
+readNextWorkspace =
+ readNextKey $ \mask sym str ->
+ case (mask, sym, str) of
+ (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch]
+ (_, _, "[") -> mt $
+ justWorkspace <$>
+ (adjacentWorkspaceNotVisible prev =<< getCurrentWorkspace)
+ (_, _, "]") -> mt $
+ justWorkspace <$>
+ (adjacentWorkspaceNotVisible next =<< getCurrentWorkspace)
+ (_, _, "(") -> mt $
+ justWorkspace <$>
+ (adjacentWorkspace prev =<< getCurrentWorkspace)
+ (_, _, ")") -> mt $
+ justWorkspace <$>
+ (adjacentWorkspace next =<< getCurrentWorkspace)
+ (_, _, "}") -> mt $ justWorkspace <$> adjacentScreen next
+ (_, _, "{") -> mt $ justWorkspace <$> adjacentScreen prev
+ (_, _, "^") -> mapMaybeT fromX $ MaybeT $
+ withWindowSet $ \ws -> return $
+ (fmap (justWorkspace . W.tag . W.workspace . snd) . head)
+ (getHorizontallyOrderedScreens ws)
+ (_, _, "'") -> fromMaybeTX $ justWorkspace . locationWorkspace <$> MaybeT lastLocation
+ (_, _, ".") -> mt $ justWorkspace <$> getCurrentWorkspace
+ (_, _, "$") -> MaybeT $ fromX $
+ withWindowSet $ \ws -> return $
+ (fmap (justWorkspace . W.tag . W.workspace . snd) . last)
+ (getHorizontallyOrderedScreens ws)
+ (_, _, ":") -> floatWorkspace <$> readNextWorkspace
+ (_, _, ",") -> do
+ ws <- readNextWorkspace
+ screens <-
+ mt $
+ map (W.tag . W.workspace . snd)
+ <$> withWindowSet (return . getHorizontallyOrderedScreens)
+
+ let (_, rest) = break (==workspaceName ws) (screens ++ screens)
+
+ justWorkspace <$> (MaybeT $ return $ head $ tail $ rest)
+
+ (_, _, "/") -> fromMaybeTX $ do
+ justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT askWindowId)
+
+ (_, _, "@") -> do
+ loc <- readNextLocationSet
+ MaybeT (return $ (justWorkspace . locationWorkspace) <$> head loc)
+
+ (_, _, " ") -> mt $
+ justWorkspace . accompaningWorkspace <$> getCurrentWorkspace
+ (_, _, "_") -> return blackHoleWorkspace
+ (_, _, "-") -> return alternateWorkspace
+ _ -> MaybeT (return Nothing)
+ where
+ mt :: (KeyFeeder m) => X a -> MaybeT m a
+ mt = lift . fromX
+
+readNextLocationSet :: (KeyFeeder m) => MaybeT m [Location]
+readNextLocationSet =
+ readNextKey $ \mask sym str ->
+ case (mask, sym, str) of
+ (_, _, [ch]) | isAlpha ch -> mt $ getMarkedLocations [ch]
+ (_, _, "0") -> (:[]) <$> MaybeT (fromX getMostRecentLocationInHistory)
+ (_, _, [ch]) | isDigit ch ->
+ (:[]) <$> MaybeT (fromX $ pastHistory (ord ch - 0x30))
+ (_, _, ".") -> (:[]) <$> mt getCurrentLocation
+ (_, _, "^") -> (:[]) <$> fromMaybeTX farLeftWindow
+ (_, _, "$") -> (:[]) <$> fromMaybeTX farRightWindow
+ (_, _, "\"") -> (:[]) <$> MaybeT (fromX nextLocation)
+ (_, _, "'") -> (:[]) <$> MaybeT (fromX lastLocation)
+ (_, _, "*") -> fromMaybeTX $ (:[]) <$> (windowLocation =<< masterWindow)
+ (_, _, "-") -> fromMaybeTX $
+ mapM windowLocation =<< lift getAlternateWindows
+ (_, _, "/") -> fromMaybeTX $
+ (:[]) <$> (windowLocation =<< MaybeT askWindowId)
+ (_, _, "%") -> fromMaybeTX $
+ mapM windowLocation =<< lift (withWindowSet (return . W.allWindows))
+ (_, _, "@") ->
+ (mt . windowsInWorkspace . workspaceName) =<< readNextWorkspace
+ (_, _, "!") -> (:[]) <$> (joinMaybe $ head <$> readNextLocationSet)
+ (_, _, ",") -> tail <$> readNextLocationSet
+ (_, _, "~") -> reverse <$> readNextLocationSet
+ (_, _, "?") -> do
+ l1 <- readNextLocationSet
+ l2 <- readNextLocationSet
+ return $ if null l1 then l2 else l1
+
+ (_, _, "&") -> do
+ l1 <- readNextLocationSet
+ l2 <- readNextLocationSet
+ return (l1 ++ l2)
+ (_, _, "\\") -> do
+ l1 <- readNextLocationSet
+ l2 <- readNextLocationSet
+ return $ filter (not . flip elem l2) l1
+
+ _ -> MaybeT (return Nothing)
+ where
+ mt :: (KeyFeeder m) => X a -> MaybeT m a
+ mt = lift . fromX
diff --git a/src/Rahm/Desktop/Lang.hs b/src/Rahm/Desktop/Lang.hs
deleted file mode 100644
index 374500d..0000000
--- a/src/Rahm/Desktop/Lang.hs
+++ /dev/null
@@ -1,127 +0,0 @@
-module Rahm.Desktop.Lang where
-
-import Control.Monad.Trans.Maybe
-import Control.Monad.Trans.Class
-
-import Data.Char (isAlphaNum, isAlpha, isDigit, ord)
-import XMonad.Actions.CopyWindow as CopyWindow
-import XMonad.Util.Run (safeSpawn)
-import qualified XMonad.StackSet as W
-
-import Rahm.Desktop.Common
-import Rahm.Desktop.Keys.Dsl
-import Rahm.Desktop.History
-import Rahm.Desktop.Marking
-import Rahm.Desktop.Workspaces
-import Rahm.Desktop.Submap
-import Rahm.Desktop.Logger
-
-import Text.Printf
-
-import XMonad
-
-data Workspace =
- Workspace {
- moveLocationToWorkspaceFn :: Location -> X ()
- , gotoWorkspaceFn :: X ()
- , workspaceName :: String
- }
-
-justWorkspace :: String -> Workspace
-justWorkspace s =
- Workspace {
- moveLocationToWorkspaceFn = flip moveLocationToWorkspace s
- , gotoWorkspaceFn = gotoWorkspace s
- , workspaceName = s
- }
-
-blackHoleWorkspace :: Workspace
-blackHoleWorkspace =
- Workspace {
- moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow
- , gotoWorkspaceFn = return () -- can't navigate to black hole
- , workspaceName = "blackhole"
- }
-
-alternateWorkspace :: Workspace
-alternateWorkspace =
- Workspace {
- moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do
- logs $ "Moving Location: " ++ show l
- case maybeWin of
- Nothing -> return ()
- Just win -> do
- alter <- getAlternateWorkspace win
- logs $ printf "Moving %s to %s" (show win) (show alter)
- mapM_ (moveLocationToWorkspace l) alter
-
- , gotoWorkspaceFn = do
- (Location _ maybeWin) <- getCurrentLocation
- case maybeWin of
- Nothing -> return ()
- Just win -> do
- mapM_ gotoWorkspace =<< getAlternateWorkspace win
-
- , workspaceName = "@"
- }
-
-readNextWorkspace :: MaybeT X Workspace
-readNextWorkspace =
- mapNextStringWithKeysym $ \mask sym str ->
- case (mask, sym, str) of
- (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch]
- (_, _, "[") -> lift $
- justWorkspace <$>
- (adjacentWorkspaceNotVisible prev =<< getCurrentWorkspace)
- (_, _, "]") -> lift $
- justWorkspace <$>
- (adjacentWorkspaceNotVisible next =<< getCurrentWorkspace)
- (_, _, "(") -> lift $
- justWorkspace <$>
- (adjacentWorkspace prev =<< getCurrentWorkspace)
- (_, _, ")") -> lift $
- justWorkspace <$>
- (adjacentWorkspace next =<< getCurrentWorkspace)
- (_, _, "}") -> lift $ justWorkspace <$> adjacentScreen next
- (_, _, "{") -> lift $ justWorkspace <$> adjacentScreen prev
- (_, _, "^") -> lift $ justWorkspace <$> firstWorkspaceId
- (_, _, "'") -> justWorkspace . locationWorkspace <$> MaybeT lastLocation
- (_, _, ".") -> lift $ justWorkspace <$> getCurrentWorkspace
- (_, _, "$") -> lift $ justWorkspace <$> lastWorkspaceId
- (_, _, "/") -> do
- justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT askWindowId)
- (_, _, " ") -> lift $
- justWorkspace . accompaningWorkspace <$> getCurrentWorkspace
- (_, _, "_") -> return blackHoleWorkspace
- (_, _, "-") -> return alternateWorkspace
- _ -> MaybeT (return Nothing)
-
-readNextLocationSet :: MaybeT X [Location]
-readNextLocationSet =
- mapNextStringWithKeysym $ \mask sym str ->
- case (mask, sym, str) of
- (_, _, [ch]) | isAlpha ch -> lift $ getMarkedLocations [ch]
- (_, _, "0") -> (:[]) <$> MaybeT getMostRecentLocationInHistory
- (_, _, [ch]) | isDigit ch ->
- (:[]) <$> MaybeT (pastHistory (ord ch - 0x30))
- (_, _, ".") -> (:[]) <$> lift getCurrentLocation
- (_, _, "^") -> (:[]) <$> farLeftWindow
- (_, _, "$") -> (:[]) <$> farRightWindow
- (_, _, "\"") -> (:[]) <$> MaybeT nextLocation
- (_, _, "'") -> (:[]) <$> MaybeT lastLocation
- (_, _, "*") -> (:[]) <$> (windowLocation =<< masterWindow)
- (_, _, "-") -> mapM windowLocation =<< lift getAlternateWindows
- (_, _, "/") -> (:[]) <$> (windowLocation =<< MaybeT askWindowId)
- (_, _, "%") ->
- mapM windowLocation =<< lift (withWindowSet (return . W.allWindows))
- (_, _, "@") -> (lift . windowsInWorkspace . workspaceName) =<< readNextWorkspace
- (_, _, "&") -> do
- l1 <- readNextLocationSet
- l2 <- readNextLocationSet
- return (l1 ++ l2)
- (_, _, "\\") -> do
- l1 <- readNextLocationSet
- l2 <- readNextLocationSet
- return $ filter (not . flip elem l2) l1
-
- _ -> MaybeT (return Nothing)
diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs
index 90808cf..1ea9782 100644
--- a/src/Rahm/Desktop/Marking.hs
+++ b/src/Rahm/Desktop/Marking.hs
@@ -1,7 +1,6 @@
module Rahm.Desktop.Marking (
markCurrentWindow,
jumpToMark,
- moveLocationToWorkspace,
setAlternateWindows,
getAlternateWindows,
setAlternateWorkspace,
@@ -131,11 +130,6 @@ swapWithFocused winToSwap stackSet =
mapWindows (
\w -> if w == winToSwap then focused else w) stackSet
-moveLocationToWorkspace :: Location -> WorkspaceId -> X ()
-moveLocationToWorkspace (Location _ (Just win)) wid =
- windows $ shiftWin wid win
-moveLocationToWorkspace _ _ = return ()
-
windowRect :: Window -> X (Maybe Rectangle)
windowRect win = withDisplay $ \dpy -> (do
(_, x, y, w, h, bw, _) <- io $ getGeometry dpy win
generated by cgit (git 2.34.1) at 2026-02-22 23:45:27 +0000