From 3a5d965333bb2d7a115e4de05d88ada48fd1d677 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 4 Feb 2024 15:20:53 -0700 Subject: Overhaul how Wml is implemented. This adds a new "KeyFeed" monad which is reminiscent of a parsec-type monad. This allows keys like 'g' to be mapped using a subbind and the actual WML part be handled in the catch-all handler. This also significantly cleans up the typing and complexity of the Wml implementation. --- src/Rahm/Desktop/Keys/Dsl2.hs | 56 +++--- src/Rahm/Desktop/Keys/KeyFeed.hs | 109 ++++++++++++ src/Rahm/Desktop/Keys/Wml.hs | 372 +++++++++++++++------------------------ 3 files changed, 276 insertions(+), 261 deletions(-) create mode 100644 src/Rahm/Desktop/Keys/KeyFeed.hs (limited to 'src/Rahm/Desktop/Keys') diff --git a/src/Rahm/Desktop/Keys/Dsl2.hs b/src/Rahm/Desktop/Keys/Dsl2.hs index c9cea83..cd0035a 100644 --- a/src/Rahm/Desktop/Keys/Dsl2.hs +++ b/src/Rahm/Desktop/Keys/Dsl2.hs @@ -23,7 +23,7 @@ module Rahm.Desktop.Keys.Dsl2 where import Control.Applicative ((<|>)) import Control.Monad.Fix (fix) -import Control.Monad.RWS (All (All), MonadTrans (lift), MonadWriter, forM_, when, forM) +import Control.Monad.RWS (All (All), MonadTrans (lift), MonadWriter, forM, forM_, when) import Control.Monad.Reader (Reader, ask, runReader) import Control.Monad.State (MonadTrans, StateT (StateT)) import Control.Monad.Trans.Maybe (MaybeT (..)) @@ -35,13 +35,13 @@ import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) -import Rahm.Desktop.Keys.KeyCodeMapping (setupKeycodeMapping) -import Rahm.Desktop.Keys.Grab import Rahm.Desktop.Common (pointerWindow, runMaybeT_) +import Rahm.Desktop.Keys.Grab +import Rahm.Desktop.Keys.KeyCodeMapping (setupKeycodeMapping) import Rahm.Desktop.Logger (LogLevel (Debug, Info), logs) import Rahm.Desktop.Submap (ButtonOrKeyEvent (ButtonPress, KeyPress, event_keycode, event_mask), getStringForKey, nextButtonOrKeyEvent) import Rahm.Desktop.XMobarLog (spawnXMobar) -import Rahm.Desktop.XMobarLog.PendingBuffer (pushAddPendingBuffer, pushPendingBuffer) +import Rahm.Desktop.XMobarLog.PendingBuffer (pushAddPendingBuffer, pushPendingBuffer, clearPendingBuffer) import XMonad -- | A documented "thing." It is essentially an item with a string attached to @@ -58,10 +58,10 @@ instance Functor Documented where -- | Type family for an action associated with a type. This type family -- indicates what type of action a keytype can be bound to. type family Action t where --- KeySyms are bound to contextless actions with type X () + -- KeySyms are bound to contextless actions with type X () Action KeySymOrKeyCode = X () --- Buttons are associated with actions with type Window -> X (). In other --- words, actions bound to a button have windows associated with it. + -- Buttons are associated with actions with type Window -> X (). In other + -- words, actions bound to a button have windows associated with it. Action Button = Window -> X () class (Bind (Super k)) => LiftBinding k where @@ -248,9 +248,9 @@ resolveBindings :: BindingsMap -> Bindings resolveBindings (BindingsMap keyAndKeyCodeBindings buttonBindings _ _) = Bindings - (\c -> Map.mapWithKey (\k -> pushK k (bindingToX c) . undocument) keyBindings) - (\c -> Map.mapWithKey (\k -> bindingToX c . undocument) keycodeBindings) - (\c -> Map.mapWithKey (\k -> pushB k (bindingToWinX c) . undocument) buttonBindings) + (\c -> Map.mapWithKey (\k v -> pushK k (bindingToX c) (undocument v)) keyBindings) + (\c -> Map.mapWithKey (\k v -> bindingToX c (undocument v)) keycodeBindings) + (\c -> Map.mapWithKey (\k v -> pushB k (bindingToWinX c) (undocument v)) buttonBindings) where (keyBindings, keycodeBindings) = partitionMap @@ -260,17 +260,19 @@ resolveBindings (BindingsMap keyAndKeyCodeBindings buttonBindings _ _) = ) keyAndKeyCodeBindings - pushB (_, b) fn binding win = + pushB (_, b) fn binding win = do if isRepeatOrSubmap binding then pushPendingBuffer ("b" ++ show b ++ " ") $ fn binding win else fn binding win + clearPendingBuffer - pushK (m, k) fn binding = + pushK (m, k) fn binding = do if isRepeatOrSubmap binding then do let s = getStringForKey (m, k) pushPendingBuffer (s ++ " ") $ fn binding else fn binding + clearPendingBuffer bindingToX :: forall l. XConfig l -> Binding KeySymOrKeyCode -> X () bindingToX conf = \case @@ -288,20 +290,22 @@ resolveBindings (BindingsMap keyAndKeyCodeBindings buttonBindings _ _) = doSubmap :: forall l. XConfig l -> BindingsMap -> X () -> X () doSubmap conf (BindingsMap kbind bbind catk catb) after = do - nextPressEvent $ + nextPressEvent $ \str -> \case (ButtonPress m b) -> do win <- pointerWindow case Map.lookup (m, b) bbind of - (Just binding) -> do - bindingToWinX conf (undocument binding) win - after + (Just binding) -> + pushAddPendingBuffer (str ++ " ") $ do + bindingToWinX conf (undocument binding) win + after Nothing -> catb (m, b) win (KeyPress m k c s) -> do case Map.lookup (m, Kc c) kbind <|> Map.lookup (m, Ks k) kbind of - (Just binding) -> do - bindingToX conf (undocument binding) - after + (Just binding) -> + pushAddPendingBuffer (str ++ " ") $ do + bindingToX conf (undocument binding) + after Nothing -> catk (m, k, s) isRepeatOrSubmap = \case @@ -315,8 +319,7 @@ resolveBindings (BindingsMap keyAndKeyCodeBindings buttonBindings _ _) = ButtonPress m b -> "b" ++ show b KeyPress _ _ _ s -> s lift $ - pushAddPendingBuffer (str ++ " ") $ - fn ev + fn str ev -- Create a submap in place of an action. subbind :: Binder () -> Binding t @@ -349,12 +352,11 @@ withBindings :: Binder a -> XConfig l -> XConfig l withBindings b config = let (Bindings keyBinds keycodeBinds buttonBinds) = resolveBindings $ runBinder config b - in - setupKeycodeMapping keycodeBinds $ - config { - keys = keyBinds, - mouseBindings = buttonBinds - } + in setupKeycodeMapping keycodeBinds $ + config + { keys = keyBinds, + mouseBindings = buttonBinds + } documentation :: XConfig l -> Binder () -> String documentation conf binder = diff --git a/src/Rahm/Desktop/Keys/KeyFeed.hs b/src/Rahm/Desktop/Keys/KeyFeed.hs new file mode 100644 index 0000000..c7b08e1 --- /dev/null +++ b/src/Rahm/Desktop/Keys/KeyFeed.hs @@ -0,0 +1,109 @@ +-- Module for the KeyFeed monad. +-- +-- The KeyFeed Monad abstracts control flow over a stream of key presses in RDE. +module Rahm.Desktop.Keys.KeyFeed where + +import Control.Monad (void, when) +import Control.Monad.State (MonadTrans (lift), StateT, evalStateT, modify') +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import Data.List.Safe (head, last) +import Rahm.Desktop.Common (Xish (..)) +import Rahm.Desktop.Submap (mapNextStringWithKeysym) +import Rahm.Desktop.XMobarLog.PendingBuffer (addStringToPendingBuffer, pushAddPendingBuffer, pushPendingBuffer) +import XMonad +import Prelude hiding (head, last) + +-- A key is a mask and a keysym. The string is the string returned from +-- XLookupString. +type Key = (KeyMask, KeySym, String) + +-- A list of keys +type KeyString = [Key] + +-- List of actions which return a key. +type KeyStream = [MaybeT X Key] + +newtype KeyFeed a = KeyFeed (StateT KeyStream (MaybeT X) a) + deriving (Functor, Applicative, Monad) + +instance Xish KeyFeed where + liftFromX = liftXToFeed + +-- Executes a KeyFeed, returning a MaybeT of the result +runKeyFeed :: KeyFeed a -> MaybeT X a +runKeyFeed = runKeyFeedWithStartingKeys [] + +-- Executes a KeyFeed, evaluating down to an X (Maybe a) +runKeyFeedX :: KeyFeed a -> X (Maybe a) +runKeyFeedX = runMaybeT . runKeyFeed + +-- Exceutes a KeyFeed. Does not evaluate the results. +execKeyFeed :: KeyFeed a -> X () +execKeyFeed = void . runMaybeT . runKeyFeed + +-- Executes a KeyFeed, evaluating the keystring first, then evaluating actual +-- key presses. +runKeyFeedWithStartingKeys :: KeyString -> KeyFeed a -> MaybeT X a +runKeyFeedWithStartingKeys st (KeyFeed r) = + evalStateT r $ + (map return st ++) $ + repeat $ do + mapNextStringWithKeysym $ \m s st -> return (m, s, st) + +-- Executes a KeyFeed only on the given key presses. +runKeyFeedWithKeys :: KeyString -> KeyFeed a -> MaybeT X a +runKeyFeedWithKeys st (KeyFeed r) = evalStateT r (toKeyStream st) + +-- Executes a function on the next key read and returns the result. +readNextKey :: ((KeyMask, KeySym, String) -> KeyFeed a) -> KeyFeed a +readNextKey fn = KeyFeed $ do + keyList <- get + nextKeyFn <- upMaybe $ head keyList + nextKey@(_, sym, str) <- lift nextKeyFn + + -- escape always ends a key feed. + when (sym == xK_Escape) $ do + let (KeyFeed r) = feedFail in r + + modify' tail + let (KeyFeed r) = liftFromX (addStringToPendingBuffer str) >> fn nextKey in r + where + upMaybe :: Maybe a -> StateT KeyStream (MaybeT X) a + upMaybe m = lift $ MaybeT (return m) + +-- Lifts a Maybe int o a KeyFeed. +hoistMaybe :: Maybe a -> KeyFeed a +hoistMaybe = KeyFeed . lift . MaybeT . return + +-- Lifts a Maybe int o a KeyFeed. +hoistMaybeT :: MaybeT X a -> KeyFeed a +hoistMaybeT = KeyFeed . lift + +-- Fails a KeyFeed action. +feedFail :: KeyFeed a +feedFail = KeyFeed $ lift (MaybeT $ return Nothing) + +-- Lifts an X action into a KeyFeed action. +liftXToFeed :: X a -> KeyFeed a +liftXToFeed = KeyFeed . lift . lift + +-- Lifts an X action into a KeyFeed action. +liftXMaybe :: X (Maybe a) -> KeyFeed a +liftXMaybe = KeyFeed . lift . MaybeT + +-- Removes a maybe and pushes it into the KeyFeed monad. If the maybe is +-- Nothing, the KeyFeed fails. +absorbMaybe :: KeyFeed (Maybe a) -> KeyFeed a +absorbMaybe fn = hoistMaybe =<< fn + +-- Inserts keys to the beginnig of the KeyFeed buffer. +pushKeys :: KeyString -> KeyFeed () +pushKeys ks = KeyFeed $ modify' (map return ks ++) + +-- Inserts a single key to the beginning of the KeyFeed buffer. +pushKey :: (KeyMask, KeySym, String) -> KeyFeed () +pushKey = pushKeys . (: []) + +-- Converts a string of keys to a stream of keys. +toKeyStream :: KeyString -> KeyStream +toKeyStream = map return diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 675d56e..0c09fd1 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -33,9 +33,6 @@ module Rahm.Desktop.Keys.Wml alternateWorkspace, floatWorkspace, joinMaybe, - feedKeys, - feedKeysT, - workspaceForKeysT, workspaceForKeys, workspaceForStringT, workspaceForString, @@ -43,17 +40,24 @@ module Rahm.Desktop.Keys.Wml locationSetForKeys, readNextWorkspaceName, workspaceName, - withNextWorkspaceOrKey, ) where import Control.Monad (forM_, join, void, when) +-- getMostRecentLocationInHistory, + +-- pastHistory, + +import Control.Monad.Reader (ReaderT (runReaderT)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Maybe (MaybeT (..), mapMaybeT) import Control.Monad.Trans.State as S - ( StateT (StateT), + ( StateT (StateT, runStateT), + evalState, evalStateT, get, + gets, + modify', put, ) import Data.Char (isAlpha, isAlphaNum, isDigit, ord) @@ -72,10 +76,6 @@ import qualified Data.Map as Map import Data.Maybe (catMaybes, fromJust, fromMaybe) import Data.Ord (Down (..)) import Data.Typeable (cast) --- getMostRecentLocationInHistory, - --- pastHistory, - import Data.Void (Void, absurd) import Rahm.Desktop.BorderColors (BorderColor (BorderColor), setBorderColor) import Rahm.Desktop.Common @@ -91,6 +91,7 @@ import Rahm.Desktop.History ( lastLocation, nextLocation, ) +import Rahm.Desktop.Keys.KeyFeed import Rahm.Desktop.Layout.PinWindow (pinnedWindows) import Rahm.Desktop.Logger (LogLevel (Info, Trace), logs) import Rahm.Desktop.Marking @@ -149,8 +150,6 @@ import XMonad.Prompt.ConfirmPrompt (confirmPrompt) import qualified XMonad.Util.ExtensibleState as XS (get, modify, put) import Prelude hiding (head, last) -type KeyString = [(KeyMask, KeySym, String)] - data MaybeMacros = NoMacros | YesMacros Macros deriving (Read, Show) @@ -373,46 +372,9 @@ floatWorkspace ws@Workspace {extraWorkspaceData = d} = 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 fn = mapNextStringWithKeysym $ - \mask sym str -> do - lift $ fromX $ addStringToPendingBuffer str - fn mask sym str - -newtype FeedKeys a = FeedKeys {unFeedKeys :: StateT KeyString X a} - deriving (Monad, Functor, Applicative) - -instance KeyFeeder FeedKeys where - fromX = FeedKeys . lift - - readNextKey fn = do - ls <- lift $ FeedKeys S.get - case ls of - ((mask, sym, str) : t) -> do - lift $ FeedKeys $ S.put t - fn mask sym str - _ -> MaybeT (return Nothing) - -feedKeys :: KeyString -> MaybeT FeedKeys a -> X (Maybe a) -feedKeys s mf = flip evalStateT s . unFeedKeys $ runMaybeT mf - -feedKeysT :: KeyString -> 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. +-- Like the above, but unwrap the MaybeT workspaceForKeysT :: KeyString -> MaybeT X Workspace -workspaceForKeysT str = feedKeysT str readNextWorkspace +workspaceForKeysT str = runKeyFeedWithKeys str readNextWorkspace -- Like the above, but unwrap the MaybeT workspaceForKeys :: KeyString -> X (Maybe Workspace) @@ -429,211 +391,160 @@ workspaceForString = runMaybeT . workspaceForStringT -- Like the above, but unwrap the MaybeT locationSetForKeysT :: KeyString -> MaybeT X [Location] -locationSetForKeysT s = feedKeysT s readNextLocationSet +locationSetForKeysT s = runKeyFeedWithKeys s readNextLocationSet locationSetForKeys :: KeyString -> X [Location] locationSetForKeys s = fromMaybe [] <$> runMaybeT (locationSetForKeysT s) -lift1 :: (KeyFeeder m) => (a -> X b) -> (a -> MaybeT m b) -lift1 = fmap (lift . fromX) +readNextWorkspaceName :: KeyFeed WorkspaceId +readNextWorkspaceName = absorbMaybe $ workspaceName <$> readNextWorkspace -readNextWorkspaceName :: (KeyFeeder m) => MaybeT m WorkspaceId -readNextWorkspaceName = joinMaybe $ workspaceName <$> readNextWorkspace - -readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace -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 +lift1 :: (a -> X b) -> (a -> KeyFeed b) +lift1 fn = liftXToFeed . fn -- 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 -> - fmap Right $ - MaybeT $ return Nothing - -- Macros takes precedence over everything. - (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. +readNextWorkspace :: KeyFeed Workspace +readNextWorkspace = + readNextKey $ \key -> do + macros <- liftXToFeed $ workspaceMacros <$> getMacros + + case key of + (mask, keysym, _) + | (Just macro) <- Map.lookup (mask, keysym) macros -> do + pushKeys macro + readNextWorkspace (_, _, [ch]) | isAlphaNum ch || ch == '*' -> - return $ Right $ justWorkspace [ch] - -- to the non-visible workspace left of the next workspace. + return $ justWorkspace [ch] (_, _, "[") -> - fmap Right $ - justWorkspace - <$> ( lift1 (adjacentWorkspaceNotVisible prev) - =<< readNextWorkspaceName - ) + justWorkspace + <$> ( lift1 (adjacentWorkspaceNotVisible prev) + =<< readNextWorkspaceName + ) -- to the non-visible workspace right of the next workspace (_, _, "]") -> - fmap Right $ - justWorkspace - <$> ( lift1 (adjacentWorkspaceNotVisible next) - =<< readNextWorkspaceName - ) + justWorkspace + <$> ( lift1 (adjacentWorkspaceNotVisible next) + =<< readNextWorkspaceName + ) -- To the left of the next workspace (_, _, "(") -> - fmap Right $ - justWorkspace - <$> ( lift1 (adjacentWorkspace prev) - =<< readNextWorkspaceName - ) + justWorkspace + <$> ( lift1 (adjacentWorkspace prev) + =<< readNextWorkspaceName + ) -- To the right of the next workspace (_, _, ")") -> - fmap Right $ - justWorkspace - <$> ( lift1 (adjacentWorkspace next) - =<< readNextWorkspaceName - ) + justWorkspace + <$> ( lift1 (adjacentWorkspace next) + =<< readNextWorkspaceName + ) -- The workspace on the leftmost screen (_, _, "^") -> - fmap Right $ - mapMaybeT fromX $ - MaybeT $ - withWindowSet $ \ws -> - return $ - ( fmap - ( justWorkspace . W.tag . W.workspace . snd - ) - . head + liftXMaybe $ + withWindowSet $ \ws -> + return $ + ( fmap + ( justWorkspace . W.tag . W.workspace . snd ) - (getHorizontallyOrderedScreens ws) + . head + ) + (getHorizontallyOrderedScreens ws) -- The last workspace in history. (_, _, "'") -> - fmap Right $ - fromMaybeTX $ - justWorkspace . locationWorkspace <$> MaybeT lastLocation + justWorkspace . locationWorkspace <$> liftXMaybe lastLocation -- The current workspace. (_, _, ".") -> - fmap Right $ - mt $ justWorkspace <$> getCurrentWorkspace + liftXToFeed $ justWorkspace <$> getCurrentWorkspace -- The workspace on the rightmost screen - (_, _, "$") -> fmap Right $ - MaybeT $ - fromX $ - withWindowSet $ \ws -> - return $ - (fmap (justWorkspace . W.tag . W.workspace . snd) . last) - (getHorizontallyOrderedScreens ws) + (_, _, "$") -> + liftXMaybe $ + 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). (_, _, ":") -> - fmap Right $ - floatWorkspace <$> readNextWorkspace + floatWorkspace <$> readNextWorkspace -- Workspace to the next screen to the right of the next workspace. - (_, _, ",") -> - fmap Right $ do - ws <- readNextWorkspace - screens <- - mt $ - map (W.tag . W.workspace . snd) - <$> withWindowSet (return . getHorizontallyOrderedScreens) + (_, _, ",") -> do + ws <- readNextWorkspace + screens <- + liftXToFeed $ + 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 <$> hoistMaybe (head $ tail rest) -- Workspace to the next screen to the left of the next workspace. - (_, _, ";") -> - fmap Right $ do - ws <- readNextWorkspace - screens <- - mt $ - map (W.tag . W.workspace . snd) - <$> withWindowSet (return . reverse . getHorizontallyOrderedScreens) + (_, _, ";") -> do + ws <- readNextWorkspace + screens <- + liftXToFeed $ + map (W.tag . W.workspace . snd) + <$> withWindowSet (return . reverse . getHorizontallyOrderedScreens) - let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens) + let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens) - justWorkspace <$> MaybeT (return $ head $ tail rest) + justWorkspace <$> hoistMaybe (head $ tail rest) -- The workspace with the searched for window. (_, _, "/") -> - fmap Right $ - fromMaybeTX $ do - justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT (head <$> askWindowId)) - + justWorkspace + <$> ( (liftXMaybe . workspaceWithWindow) =<< liftXMaybe (head <$> askWindowId) + ) -- The workspace with the next read window on it. - (_, _, "@") -> - 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 + (_, _, "@") -> do + loc <- readNextLocationSet + liftXMaybe $ + 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. (_, _, "~") -> - fmap Right $ - justWorkspace . accompaningWorkspace <$> readNextWorkspaceName + justWorkspace . accompaningWorkspace <$> readNextWorkspaceName -- The accompaning workspace to the current workspace (equivalent to ~.) (_, _, " ") -> - fmap Right $ - mt $ - justWorkspace . accompaningWorkspace <$> getCurrentWorkspace + liftXToFeed $ + justWorkspace . accompaningWorkspace <$> getCurrentWorkspace -- The balck hole workspace (_, _, "_") -> - return $ Right blackHoleWorkspace + return blackHoleWorkspace -- The alternate workspace (_, _, "-") -> - return $ Right alternateWorkspace + return alternateWorkspace -- If the next two read workspaces are equal, go to the third workspace -- otherwise go to the fourth workspace. - (_, _, "=") -> - fmap Right $ do - ws1 <- readNextWorkspace - ws2 <- readNextWorkspace + (_, _, "=") -> do + ws1 <- readNextWorkspace + ws2 <- readNextWorkspace - ws3 <- readNextWorkspace - ws4 <- readNextWorkspace - - return $ - if workspaceName ws1 == workspaceName ws2 - then ws3 - else ws4 + ws3 <- readNextWorkspace + ws4 <- readNextWorkspace + 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. - (_, _, "?") -> - fmap Right $ do - l1 <- readNextLocationSet - - ws1 <- readNextWorkspace - ws2 <- readNextWorkspace + (_, _, "?") -> do + l1 <- readNextLocationSet - mt $ logs Trace "If not empty %s then %s else %s" (show l1) (show $ workspaceName ws1) (show $ workspaceName ws2) + ws1 <- readNextWorkspace + ws2 <- readNextWorkspace - 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 + return $ + if null l1 + then ws2 + else ws1 + _ -> feedFail nonempty :: (Monad m) => m [a] -> MaybeT m [a] nonempty l = MaybeT $ do @@ -643,32 +554,30 @@ nonempty l = MaybeT $ do a -> return (Just a) ) -readNextLocationSet :: (KeyFeeder m) => MaybeT m [Location] +readNextLocationSet :: KeyFeed [Location] readNextLocationSet = do - (WindowSelect mp) <- MaybeT (Just <$> fromX XS.get) + (WindowSelect mp) <- liftXToFeed XS.get case Map.keys mp of [] -> readNextLocationSet' wins -> do - lift $ fromX $ addStringToPendingBuffer " " - fromMaybeTX $ - mapM windowLocation - =<< MaybeT (Just <$> fromX getAndResetWindowSelection) + liftXToFeed $ addStringToPendingBuffer " " + mapM (hoistMaybeT . windowLocation) + =<< liftXToFeed getAndResetWindowSelection -- Like readNextLocationSet, but ignores the window selection. -readNextLocationSet' :: (KeyFeeder m) => MaybeT m [Location] +readNextLocationSet' :: KeyFeed [Location] readNextLocationSet' = - readNextKey $ \mask sym str -> do - macros <- (lift . fromX) $ windowsetMacros <$> getMacros + readNextKey $ \key -> do + macros <- liftXToFeed $ windowsetMacros <$> getMacros - case (mask, sym, str) of - -- Escape returns nothing and aborts reading the next location. - (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing + case key of -- Macros takes precedence. (mask, keysym, _) | (Just macro) <- Map.lookup (mask, keysym) macros -> do - fromMaybeTX $ locationSetForKeysT macro + hoistMaybeT $ locationSetForKeysT macro -- A character is the base-case. Refers to a collection of windows. - (_, _, [ch]) | isAlpha ch -> mt $ getMarkedLocations [ch] + (_, _, [ch]) | isAlpha ch -> liftXToFeed $ getMarkedLocations [ch] + -- Goes to the most recent location in history. -- (_, _, "0") -> (: []) <$> MaybeT (fromX getMostRecentLocationInHistory) -- A Digit goes to the past history. @@ -676,50 +585,47 @@ readNextLocationSet' = -- | isDigit ch -> -- (: []) <$> MaybeT (fromX $ pastHistory (ord ch - 0x30)) -- The current window. - (_, _, ".") -> (: []) <$> mt getCurrentLocation + (_, _, ".") -> (: []) <$> liftXToFeed getCurrentLocation -- The selected windows in the selection set. (_, _, "#") -> - MaybeT . fromX $ Just . map (Location "*" . Just) <$> pinnedWindows + liftXToFeed $ map (Location "*" . Just) <$> pinnedWindows -- The window on the far-left of the screens. - (_, _, "^") -> (: []) <$> fromMaybeTX farLeftWindow + (_, _, "^") -> (: []) <$> hoistMaybeT farLeftWindow -- The windows on the far-right of the screens. - (_, _, "$") -> (: []) <$> fromMaybeTX farRightWindow + (_, _, "$") -> (: []) <$> hoistMaybeT farRightWindow -- The next location in history. - (_, _, "\"") -> (: []) <$> MaybeT (fromX nextLocation) + (_, _, "\"") -> (: []) <$> liftXMaybe nextLocation -- The previous location in history. - (_, _, "'") -> (: []) <$> MaybeT (fromX lastLocation) + (_, _, "'") -> (: []) <$> liftXMaybe lastLocation -- All visible windows. - (_, _, "*") -> mt $ do + (_, _, "*") -> liftXToFeed $ do wins <- withWindowSet $ return . W.allVisibleWindows catMaybes <$> mapM (runMaybeT . windowLocation) wins -- The last referenced windows. (_, _, "-") -> - fromMaybeTX $ + hoistMaybeT $ mapM windowLocation =<< lift getAlternateWindows -- Search for the windows. (_, _, "/") -> - fromMaybeTX $ + hoistMaybeT $ mapM windowLocation =<< nonempty askWindowId -- All windows. - (_, _, "%") -> fromMaybeTX $ do - ret <- mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows)) - lift $ logs Info "allWindows %s" (intercalate "\n" (map show ret)) - return ret - + (_, _, "%") -> hoistMaybeT $ + mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows)) -- Windows in a workspace (_, _, s) | s == "\t" || s == "@" || s == "\n" -> - (mt . windowsInWorkspace) =<< readNextWorkspaceName + (liftXToFeed . windowsInWorkspace) =<< readNextWorkspaceName -- The first window in the next window set. - (_, _, "!") -> (: []) <$> joinMaybe (head <$> readNextLocationSet) + (_, _, "!") -> (: []) <$> absorbMaybe (head <$> readNextLocationSet) -- The windows except the first in a window set. (_, _, ",") -> tail <$> readNextLocationSet -- The next window set, but reversed (_, _, "~") -> reverse <$> readNextLocationSet -- All the floating windows (_, _, ":") -> - mt $ + liftXToFeed $ withWindowSet $ fmap catMaybes . mapM (runMaybeT . windowLocation) @@ -751,7 +657,5 @@ readNextLocationSet' = l1 <- readNextLocationSet l2 <- readNextLocationSet return $ filter (`elem` l2) l1 - _ -> MaybeT (return Nothing) - where - mt :: (KeyFeeder m) => X a -> MaybeT m a - mt = lift . fromX + + _ -> feedFail -- cgit