diff options
Diffstat (limited to 'src/Rahm/Desktop/Keys')
| -rw-r--r-- | src/Rahm/Desktop/Keys/Wml.hs | 233 |
1 files changed, 142 insertions, 91 deletions
diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 5565c31..61c19b2 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -43,6 +43,7 @@ module Rahm.Desktop.Keys.Wml locationSetForKeys, readNextWorkspaceName, workspaceName, + withNextWorkspaceOrKey, ) where @@ -75,6 +76,7 @@ import Data.Typeable (cast) -- pastHistory, +import Data.Void (Void, absurd) import Rahm.Desktop.BorderColors (BorderColor (BorderColor), setBorderColor) import Rahm.Desktop.Common ( Location (..), @@ -438,148 +440,197 @@ lift1 = fmap (lift . fromX) readNextWorkspaceName :: (KeyFeeder m) => MaybeT m WorkspaceId readNextWorkspaceName = joinMaybe $ workspaceName <$> readNextWorkspace --- Returns the next workspaces associated with the next set of keystrokes. readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace -readNextWorkspace = +readNextWorkspace = unEither <$> readNextWorkspaceWithHandler (const doNothing) + where + doNothing :: (Monad m) => MaybeT m Void + doNothing = MaybeT (return Nothing) + + unEither :: Either Void a -> a + unEither = either absurd id + +withNextWorkspaceOrKey :: + (KeyFeeder m) => + (Workspace -> m ()) -> + ((KeyMask, KeySym, String) -> m ()) -> + MaybeT m () +withNextWorkspaceOrKey wFn kFn = + either (lift . kFn) (lift . wFn) =<< readNextWorkspaceWithHandler return + +-- Returns the next workspaces associated with the next set of keystrokes, or +-- invokes the handler if the next stroke is not associated with WML command. +readNextWorkspaceWithHandler :: (KeyFeeder m) => ((KeyMask, KeySym, String) -> MaybeT m b) -> MaybeT m (Either b Workspace) +readNextWorkspaceWithHandler handle = readNextKey $ \mask sym str -> do macros <- (lift . fromX) $ workspaceMacros <$> getMacros case (mask, sym, str) of -- Escape kills the "readNextWorkspace" and returns nothing. - (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing + (_, e, _) + | e == xK_Escape -> + fmap Right $ + MaybeT $ return Nothing -- Macros takes precedence over everything. - (mask, keysym, _) | (Just macro) <- Map.lookup (mask, keysym) macros -> do - fromMaybeTX $ workspaceForKeysT macro + (mask, keysym, _) | (Just macro) <- Map.lookup (mask, keysym) macros -> + fmap Right $ do + fromMaybeTX $ workspaceForKeysT macro -- A single alphanumeric character is the atomic reference to a workspace. - (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch] + (_, _, [ch]) + | isAlphaNum ch || ch == '*' -> + return $ Right $ justWorkspace [ch] -- to the non-visible workspace left of the next workspace. (_, _, "[") -> - justWorkspace - <$> ( lift1 (adjacentWorkspaceNotVisible prev) - =<< readNextWorkspaceName - ) + fmap Right $ + justWorkspace + <$> ( lift1 (adjacentWorkspaceNotVisible prev) + =<< readNextWorkspaceName + ) -- to the non-visible workspace right of the next workspace (_, _, "]") -> - justWorkspace - <$> ( lift1 (adjacentWorkspaceNotVisible next) - =<< readNextWorkspaceName - ) + fmap Right $ + justWorkspace + <$> ( lift1 (adjacentWorkspaceNotVisible next) + =<< readNextWorkspaceName + ) -- To the left of the next workspace (_, _, "(") -> - justWorkspace - <$> ( lift1 (adjacentWorkspace prev) - =<< readNextWorkspaceName - ) + fmap Right $ + justWorkspace + <$> ( lift1 (adjacentWorkspace prev) + =<< readNextWorkspaceName + ) -- To the right of the next workspace (_, _, ")") -> - justWorkspace - <$> ( lift1 (adjacentWorkspace next) - =<< readNextWorkspaceName - ) + fmap Right $ + justWorkspace + <$> ( lift1 (adjacentWorkspace next) + =<< readNextWorkspaceName + ) -- The workspace on the leftmost screen - (_, _, "^") -> mapMaybeT fromX $ - MaybeT $ - withWindowSet $ \ws -> - return $ - ( fmap - ( justWorkspace . W.tag . W.workspace . snd + (_, _, "^") -> + fmap Right $ + mapMaybeT fromX $ + MaybeT $ + withWindowSet $ \ws -> + return $ + ( fmap + ( justWorkspace . W.tag . W.workspace . snd + ) + . head ) - . head - ) - (getHorizontallyOrderedScreens ws) + (getHorizontallyOrderedScreens ws) -- The last workspace in history. - (_, _, "'") -> fromMaybeTX $ justWorkspace . locationWorkspace <$> MaybeT lastLocation + (_, _, "'") -> + fmap Right $ + fromMaybeTX $ + justWorkspace . locationWorkspace <$> MaybeT lastLocation -- The current workspace. - (_, _, ".") -> mt $ justWorkspace <$> getCurrentWorkspace + (_, _, ".") -> + fmap Right $ + mt $ justWorkspace <$> getCurrentWorkspace -- The workspace on the rightmost screen - (_, _, "$") -> MaybeT $ - fromX $ - withWindowSet $ \ws -> - return $ - (fmap (justWorkspace . W.tag . W.workspace . snd) . last) - (getHorizontallyOrderedScreens ws) + (_, _, "$") -> fmap Right $ + MaybeT $ + fromX $ + withWindowSet $ \ws -> + return $ + (fmap (justWorkspace . W.tag . W.workspace . snd) . last) + (getHorizontallyOrderedScreens ws) -- Modify the next workspace as a "floating" workspace. (Windows sent to -- it will float). - (_, _, ":") -> floatWorkspace <$> readNextWorkspace + (_, _, ":") -> + fmap Right $ + floatWorkspace <$> readNextWorkspace -- Workspace to the next screen to the right of the next workspace. - (_, _, ",") -> do - ws <- readNextWorkspace - screens <- - mt $ - map (W.tag . W.workspace . snd) - <$> withWindowSet (return . getHorizontallyOrderedScreens) + (_, _, ",") -> + fmap Right $ do + ws <- readNextWorkspace + screens <- + mt $ + map (W.tag . W.workspace . snd) + <$> withWindowSet (return . getHorizontallyOrderedScreens) - let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens) + let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens) - justWorkspace <$> MaybeT (return $ head $ tail rest) + justWorkspace <$> MaybeT (return $ head $ tail rest) -- Workspace to the next screen to the left of the next workspace. - (_, _, ";") -> do - ws <- readNextWorkspace - screens <- - mt $ - map (W.tag . W.workspace . snd) - <$> withWindowSet (return . getHorizontallyOrderedScreens) + (_, _, ";") -> + fmap Right $ do + ws <- readNextWorkspace + screens <- + mt $ + map (W.tag . W.workspace . snd) + <$> withWindowSet (return . getHorizontallyOrderedScreens) - let (front, _) = break ((== workspaceName ws) . Just) (screens ++ screens) + let (front, _) = break ((== workspaceName ws) . Just) (screens ++ screens) - justWorkspace <$> MaybeT (return $ last front) + justWorkspace <$> MaybeT (return $ last front) -- The workspace with the searched for window. - (_, _, "/") -> fromMaybeTX $ do - justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT (head <$> askWindowId)) + (_, _, "/") -> + fmap Right $ + fromMaybeTX $ do + justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT (head <$> askWindowId)) -- The workspace with the next read window on it. - (_, _, "@") -> do - loc <- readNextLocationSet - MaybeT $ - fromX $ - withWindowSet $ \ws -> return $ do - win <- locationWindow =<< head loc - winLocation <- W.findWindow ws win - justWorkspaceWithPreferredWindow win . W.tag <$> W.getLocationWorkspace winLocation + (_, _, "@") -> + fmap Right $ do + loc <- readNextLocationSet + MaybeT $ + fromX $ + withWindowSet $ \ws -> return $ do + win <- locationWindow =<< head loc + winLocation <- W.findWindow ws win + justWorkspaceWithPreferredWindow win . W.tag <$> W.getLocationWorkspace winLocation -- The accompaning worksapce to the next read workspace. (_, _, "~") -> - justWorkspace . accompaningWorkspace <$> readNextWorkspaceName + fmap Right $ + justWorkspace . accompaningWorkspace <$> readNextWorkspaceName -- The accompaning workspace to the current workspace (equivalent to ~.) (_, _, " ") -> - mt $ - justWorkspace . accompaningWorkspace <$> getCurrentWorkspace + fmap Right $ + mt $ + justWorkspace . accompaningWorkspace <$> getCurrentWorkspace -- The balck hole workspace - (_, _, "_") -> return blackHoleWorkspace + (_, _, "_") -> + return $ Right blackHoleWorkspace -- The alternate workspace - (_, _, "-") -> return alternateWorkspace + (_, _, "-") -> + return $ Right alternateWorkspace -- If the next two read workspaces are equal, go to the third workspace -- otherwise go to the fourth workspace. - (_, _, "=") -> do - ws1 <- readNextWorkspace - ws2 <- readNextWorkspace + (_, _, "=") -> + fmap Right $ do + ws1 <- readNextWorkspace + ws2 <- readNextWorkspace - ws3 <- readNextWorkspace - ws4 <- readNextWorkspace + ws3 <- readNextWorkspace + ws4 <- readNextWorkspace - return $ - if workspaceName ws1 == workspaceName ws2 - then ws3 - else ws4 + return $ + if workspaceName ws1 == workspaceName ws2 + then ws3 + else ws4 -- If the next read location set is not empty, go to the next read -- workspace, otherwise go to the next-next read workspace. - (_, _, "?") -> do - l1 <- readNextLocationSet + (_, _, "?") -> + fmap Right $ do + l1 <- readNextLocationSet - ws1 <- readNextWorkspace - ws2 <- readNextWorkspace + ws1 <- readNextWorkspace + ws2 <- readNextWorkspace - mt $ logs Trace "If not empty %s then %s else %s" (show l1) (show $ workspaceName ws1) (show $ workspaceName ws2) + mt $ logs Trace "If not empty %s then %s else %s" (show l1) (show $ workspaceName ws1) (show $ workspaceName ws2) - return $ - if null l1 - then ws2 - else ws1 - _ -> MaybeT (return Nothing) + return $ + if null l1 + then ws2 + else ws1 + _ -> Left <$> handle (mask, sym, str) where mt :: (KeyFeeder m) => X a -> MaybeT m a mt = lift . fromX @@ -659,7 +710,7 @@ readNextLocationSet' = -- Windows in a workspace (_, _, s) | s == "\t" || s == "@" || s == "\n" -> - (mt . windowsInWorkspace) =<< readNextWorkspaceName + (mt . windowsInWorkspace) =<< readNextWorkspaceName -- The first window in the next window set. (_, _, "!") -> (: []) <$> joinMaybe (head <$> readNextLocationSet) -- The windows except the first in a window set. |