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/Common.hs | 7 + src/Rahm/Desktop/Keys.hs | 444 ++++++++++++++-------------- src/Rahm/Desktop/Keys/Dsl2.hs | 56 ++-- src/Rahm/Desktop/Keys/KeyFeed.hs | 109 +++++++ src/Rahm/Desktop/Keys/Wml.hs | 372 +++++++++-------------- src/Rahm/Desktop/XMobarLog/PendingBuffer.hs | 17 +- 6 files changed, 507 insertions(+), 498 deletions(-) create mode 100644 src/Rahm/Desktop/Keys/KeyFeed.hs (limited to 'src') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 125d651..ae4f531 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -20,6 +20,7 @@ module Rahm.Desktop.Common pointerWindow, getDisplayAndRoot, Location (..), + Xish(..), ) where @@ -246,3 +247,9 @@ duplWindow = runQuery $ do (a : (init -> as)) -> X.safeSpawn a as _ -> return () Left err -> logs Info "%s" (err :: String) + +class (Monad m) => Xish m where + liftFromX :: X a -> m a + +instance Xish X where + liftFromX = id diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index a4415da..a29f080 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -63,26 +63,9 @@ import Rahm.Desktop.History jumpToLastLocation, ) import Rahm.Desktop.Keys.Dsl2 -import Rahm.Desktop.Keys.Grab (KeySymOrKeyCode(..)) +import Rahm.Desktop.Keys.Grab (KeySymOrKeyCode (..)) +import Rahm.Desktop.Keys.KeyFeed (execKeyFeed, liftXToFeed, pushKey, runKeyFeed, runKeyFeedX) import Rahm.Desktop.Keys.Wml - ( addWindowToSelection, - clearWindowSelection, - getAndResetWindowSelection, - gotoWorkspaceFn, - moveWindowToWorkspaceFn, - readNextLocationSet, - readNextLocationSet', - readNextWorkspace, - readNextWorkspaceName, - readWindowsetMacro, - readWorkspaceMacro, - removeWindowFromSelection, - toggleWindowInSelection, - withNextWorkspaceOrKey, - workspaceForString, - workspaceForStringT, - workspaceName, - ) import Rahm.Desktop.Layout (nLayouts) import Rahm.Desktop.Layout.ConsistentMosaic ( expandPositionAlt, @@ -276,13 +259,13 @@ bindings = do ifM D.isDragging (D.finishDrag >> withFocused D.sinkByWindowUnderCursor) - $ pushPendingBuffer "' " $ - do - runMaybeT_ $ do - l <- readNextLocationSet' - case l of - (h : _) -> lift (focusLocation h) - _ -> return () + $ pushPendingBuffer "' " + $ do + runMaybeT_ $ do + l <- runKeyFeed readNextLocationSet' + case l of + (h : _) -> lift (focusLocation h) + _ -> return () shiftMod $ doc "Drag workspace to another." D.dragWindow @@ -296,10 +279,10 @@ bindings = do doc "Swap windows with other windows" $ pushPendingBuffer "w " $ do runMaybeT_ $ do - l1 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet + l1 <- mapMaybe (\(Location _ w) -> w) <$> runKeyFeed readNextLocationSet withBorderColorM selectedWindowsColor l1 $ do lift $ addStringToPendingBuffer " " - l2 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet + l2 <- mapMaybe (\(Location _ w) -> w) <$> runKeyFeed readNextLocationSet let (l1', l2') = if length l1 > length l2 then (l1, l2) @@ -309,20 +292,20 @@ bindings = do lift $ do setAlternateWindows (l1'' ++ l2') windows $ W.swapWindows $ zip l1'' l2' ++ zip l2' l1'' - shiftMod $ - doc + shiftMod + $ doc "Swap two workspaces (or rename the current one). \ \(only works on normal workspaces)." - $ pushPendingBuffer "W " $ - do - logs Debug "%s" . W.dbgStackSet =<< gets windowset - runMaybeT_ $ do - w1 <- readNextWorkspaceName - wins <- lift $ W.windowsOnWorkspace w1 <$> gets windowset - withBorderColorM selectedWindowsColor wins $ do - lift $ addStringToPendingBuffer " " - w2 <- readNextWorkspaceName - lift $ windows $ W.swapWorkspaces w1 w2 + $ pushPendingBuffer "W " + $ do + logs Debug "%s" . W.dbgStackSet =<< gets windowset + runMaybeT_ $ do + w1 <- runKeyFeed readNextWorkspaceName + wins <- lift $ W.windowsOnWorkspace w1 <$> gets windowset + withBorderColorM selectedWindowsColor wins $ do + lift $ addStringToPendingBuffer " " + w2 <- runKeyFeed readNextWorkspaceName + lift $ windows $ W.swapWorkspaces w1 w2 bind xK_BackSpace $ do -- Moves xmobar to different monitors. @@ -350,12 +333,12 @@ bindings = do ++ documentation config bindings bind xK_F1 $ do - justMod $ - doc + justMod + $ doc "Print this documentation" - $ do - doc <- getDoc - safeSpawn "gxmessage" ["-fn", "Source Code Pro", doc] + $ do + doc <- getDoc + safeSpawn "gxmessage" ["-fn", "Source Code Pro", doc] bind xK_F7 $ do justMod $ @@ -406,14 +389,15 @@ bindings = do doc "Kill the current window" CopyWindow.kill1 bind xK_f $ do - justMod $ - doc + justMod + $ doc "Focus (non-greedily) a workspace. Useful for focusing between \ \screens with ',.', '$', '^', etc." - $ pushPendingBuffer "f " $ do - runMaybeT_ $ do - ws <- readNextWorkspaceName - lift $ windows $ W.view ws + $ pushPendingBuffer "f " + $ do + runMaybeT_ $ do + ws <- runKeyFeed readNextWorkspaceName + lift $ windows $ W.view ws bind xK_a $ do justMod $ @@ -431,8 +415,8 @@ bindings = do lift $ windows $ W.view ws bind xK_g $ do - justMod $ - doc + justMod + $ doc "Goto To a workspace\n\n\t\ \Workspacs are alphanumeric characters. So if the next key typed is an\n\t\ \alphanumeric character, that's the workspace to operate on\n\n\ @@ -451,66 +435,70 @@ bindings = do \_: Black hole. Sending a window here closes it.\n\n\t\ \Other keybindings starting with H-g\n\t\t\ \F1: display this help.\n\n\t" - $ pushPendingBuffer "g " $ - runMaybeT_ $ - withNextWorkspaceOrKey - gotoWorkspaceFn - ( \case - (_, s, _) | s == xK_F1 -> do - doc <- getDoc - safeSpawn "gxmessage" ["-fn", "Source Code Pro", doc] - (_, s, _) | s == xK_F5 -> do - spawnX "xmonad --recompile && xmonad --restart" - _ -> return () - ) - shiftMod $ - doc + $ subbind + $ do + bind xK_F1 $ + (noMod -|- justMod) $ do + doc <- getDoc + safeSpawn "gxmessage" ["-fn", "Source Code Pro", doc] + + bind xK_F5 $ + (noMod -|- justMod) $ + spawnX "xmonad --recompile && xmonad --restart" + + bindOtherKeys $ \key -> execKeyFeed $ do + pushKey key + ws <- readNextWorkspace + liftXToFeed $ gotoWorkspaceFn ws + + shiftMod + $ doc "Switch a workspace with another workspace. \ \This is a more powerful version of the 'g' command, which does not\ \assume the current workspace.\ \which takes two workspaces as arguments and switches them whereas\ \the 'g' command operates only on the current workspace (.).\ \thereby G. is the same as g" - $ do - pushPendingBuffer "G " $ do - runMaybeT_ $ do - w1 <- readNextWorkspaceName - lift $ addStringToPendingBuffer " " - w2 <- readNextWorkspaceName - lift $ windows $ W.switchWorkspaces w1 w2 + $ do + pushPendingBuffer "G " $ do + runMaybeT_ $ do + w1 <- runKeyFeed readNextWorkspaceName + lift $ addStringToPendingBuffer " " + w2 <- runKeyFeed readNextWorkspaceName + lift $ windows $ W.switchWorkspaces w1 w2 bind xK_d $ justMod $ doc "Record (define) macros." $ subbind $ do - bind xK_w $ - noMod $ - doc - "Record a windowset macro.\n\n\t\ - \To record a 'windowset' macro, type w and then\n\t\ - \type a character sequence followed by Enter. Now can\n\t\ - \be used anywhere a 'windowset' is required and that macro\n\t\ - \will be used.\n\n\t\ - \For example, if one wants to define '+' as 'all windows \n\t\ - \not on the current workspace, one can type:\n\n\t\ - \w+\\%@.\n" - $ pushPendingBuffer "Win Macro " $ - runMaybeT_ readWindowsetMacro - - bind xK_t $ - noMod $ - doc - "Record a workspace macro\n\n\t\ - \To record a 'workspace' macro, type t and then\n\t\ - \type a character sequence followed by Enter. Now can\n\t\ - \be used anywhere a 'workspace' is required and that macro\n\t\ - \will be used.\n\n\t\ - \For example, if one wants to define '' as 'the workspace with\n\t\ - \the window 's' on it or the last workspace if already on that \n\t\ - \workspace (more useful that one would think):\n\n\t\ - \t?&s@.'s\n" - $ pushPendingBuffer "Wksp Macro " $ - runMaybeT_ readWorkspaceMacro + bind xK_w + $ noMod + $ doc + "Record a windowset macro.\n\n\t\ + \To record a 'windowset' macro, type w and then\n\t\ + \type a character sequence followed by Enter. Now can\n\t\ + \be used anywhere a 'windowset' is required and that macro\n\t\ + \will be used.\n\n\t\ + \For example, if one wants to define '+' as 'all windows \n\t\ + \not on the current workspace, one can type:\n\n\t\ + \w+\\%@.\n" + $ pushPendingBuffer "Win Macro " + $ runMaybeT_ readWindowsetMacro + + bind xK_t + $ noMod + $ doc + "Record a workspace macro\n\n\t\ + \To record a 'workspace' macro, type t and then\n\t\ + \type a character sequence followed by Enter. Now can\n\t\ + \be used anywhere a 'workspace' is required and that macro\n\t\ + \will be used.\n\n\t\ + \For example, if one wants to define '' as 'the workspace with\n\t\ + \the window 's' on it or the last workspace if already on that \n\t\ + \workspace (more useful that one would think):\n\n\t\ + \t?&s@.'s\n" + $ pushPendingBuffer "Wksp Macro " + $ runMaybeT_ readWorkspaceMacro bind xK_h $ do justMod $ @@ -570,24 +558,24 @@ bindings = do pushPendingBuffer "p " $ runMaybeT_ $ do - windows <- mapMaybe locationWindow <$> readNextLocationSet + windows <- mapMaybe locationWindow <$> runKeyFeed readNextLocationSet lift $ mapM_ pinWindow windows shiftMod $ doc "Unpin a windowset" $ pushPendingBuffer "P " $ runMaybeT_ $ do - windows <- mapMaybe locationWindow <$> readNextLocationSet + windows <- mapMaybe locationWindow <$> runKeyFeed readNextLocationSet lift $ mapM_ unpinWindow windows bind xK_minus $ do - justMod $ - doc + justMod + $ doc "Decrease the number of windows in the master region, or decrease\n\t\ \the size of the master region if the current layout cannot have more\n\t\ \than one window in the master region." - $ sendMessage $ - IncMasterN (-1) + $ sendMessage + $ IncMasterN (-1) shiftMod $ doc "For mosaic layout, shrink the size-share of the current window" $ @@ -611,7 +599,7 @@ bindings = do doc d $ pushPendingBuffer ch $ do runMaybeT_ $ do - locset <- readNextLocationSet' + locset <- runKeyFeed readNextLocationSet' lift $ forM_ locset $ \(Location _ mWin) -> mapM_ fn mWin @@ -622,34 +610,35 @@ bindings = do flip whenJust toggleWindowInSelection =<< withWindowSet (return . W.peek) bind xK_m $ do - rawMask mod2Mask + rawMask + mod2Mask (logs Info "Testing Mod2Mask" :: X ()) - justMod $ - doc + justMod + $ doc "Mark the windows described by the window set with a given character.\n\n\t\ \For example, to mark the current window use .. That window\n\n\t\ \can then be recalled anywhere that requires a WML window.\n" - $ do - pushPendingBuffer "m " $ do - locs <- fromMaybe [] <$> runMaybeT readNextLocationSet - let wins = mapMaybe locationWindow locs - unless (null wins) $ do - withBorderColor selectedWindowsColor wins $ do - runMaybeT_ $ do - mapNextString $ \_ str -> lift $ - case str of - [ch] | isAlpha ch -> markAllLocations str locs - _ -> return () + $ do + pushPendingBuffer "m " $ do + locs <- fromMaybe [] <$> runKeyFeedX readNextLocationSet + let wins = mapMaybe locationWindow locs + unless (null wins) $ do + withBorderColor selectedWindowsColor wins $ do + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> markAllLocations str locs + _ -> return () bind xK_plus $ do - justMod $ - doc + justMod + $ doc "Increase the number of windows in the master region, or increase\n\t\ \the size of the master region if the current layout cannot have more\n\t\ \than one window in the master region.\n" - $ sendMessage $ - IncMasterN 1 + $ sendMessage + $ IncMasterN 1 shiftMod $ doc "For mosaic layout, increase the size-share of the current window." $ @@ -673,8 +662,8 @@ bindings = do (ShiftAndFollow, controlMod) ] $ \(shiftType, f) -> - f $ - doc + f + $ doc ( case shiftType of ShiftAndFollow -> "Shift-and-follow: Like shift-and-swap with the implicit \ @@ -686,54 +675,54 @@ bindings = do \Note that this command will only work with normal workspaces." JustShift -> "Shift a windowset to a workspace" ) - $ pushPendingBuffer - ( case shiftType of - ShiftAndSwap -> "S " - JustShift -> "s " - ShiftAndFollow -> "^s " - ) - $ runMaybeT_ $ - do - stackset <- lift $ X.windowset <$> X.get - selection <- mapMaybe locationWindow <$> readNextLocationSet - withBorderColorM selectedWindowsColor selection $ do + $ pushPendingBuffer + ( case shiftType of + ShiftAndSwap -> "S " + JustShift -> "s " + ShiftAndFollow -> "^s " + ) + $ runMaybeT_ + $ do + stackset <- lift $ X.windowset <$> X.get + selection <- mapMaybe locationWindow <$> runKeyFeed readNextLocationSet + withBorderColorM selectedWindowsColor selection $ do + lift $ addStringToPendingBuffer " " + ws <- runKeyFeed readNextWorkspace + finalSwap <- + case shiftType of + ShiftAndSwap -> do lift $ addStringToPendingBuffer " " - ws <- readNextWorkspace - finalSwap <- - case shiftType of - ShiftAndSwap -> do - lift $ addStringToPendingBuffer " " - wsName <- MaybeT . return $ workspaceName ws - W.switchWorkspaces wsName <$> readNextWorkspaceName - _ -> return id - - lift $ do - (Endo allMovements) <- - mconcat - <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection - - setAlternateWindows selection - - forM_ selection $ \win -> do - mapM_ - ( \t -> do - logs Debug "Set alternate workspace %s -> %s" (show win) t - setAlternateWorkspace win t - ) - (W.findTag win stackset) - - withWindowsUnpinned selection $ - windows $ - finalSwap - . ( \ss -> - case shiftType of - ShiftAndFollow - | (w : _) <- selection, - Just ws <- W.findTag w ss -> - W.greedyView ws ss - _ -> ss - ) - . allMovements + wsName <- MaybeT . return $ workspaceName ws + W.switchWorkspaces wsName <$> runKeyFeed readNextWorkspaceName + _ -> return id + + lift $ do + (Endo allMovements) <- + mconcat + <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection + + setAlternateWindows selection + + forM_ selection $ \win -> do + mapM_ + ( \t -> do + logs Debug "Set alternate workspace %s -> %s" (show win) t + setAlternateWorkspace win t + ) + (W.findTag win stackset) + + withWindowsUnpinned selection $ + windows $ + finalSwap + . ( \ss -> + case shiftType of + ShiftAndFollow + | (w : _) <- selection, + Just ws <- W.findTag w ss -> + W.greedyView ws ss + _ -> ss + ) + . allMovements altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" @@ -743,7 +732,8 @@ bindings = do sendMessage ToggleStruts shiftMod $ doc "Remove the border from the focused window" $ - withFocused $ setBorderWidth 0 . (: []) + withFocused $ + setBorderWidth 0 . (: []) bind xK_space $ do justMod $ @@ -789,25 +779,25 @@ bindings = do doc "Jump to the middle layout." $ sendMessage (toIndexedLayout (nLayouts `div` 2)) - bind xK_g $ - (noMod -|- justMod) $ - doc - "Switch to a different theater.\n\n\t\ - \Theaters are like super-workspaces. They are used for different\n\t\ - \'contexts'. Theaters share all the windows with eachother, but\n\t\ - \but each theater has its own mappings for window -> workspace. i.e.\n\t\ - \one theater can have window 'x' on workspace 'y', but another might\n\t\ - \have 'x' on 'z' instead. If a theater does explicity place a window,\n\t\ - \the window is placed in the hidden workspace (which is '*')\n" - $ do - addStringToPendingBuffer " g " - runMaybeT_ $ - do - mapNextString $ \_ str -> lift $ - case str of - [ch] | isAlpha ch -> restoreTheater (Just [ch]) - [' '] -> restoreTheater Nothing - _ -> return () + bind xK_g + $ (noMod -|- justMod) + $ doc + "Switch to a different theater.\n\n\t\ + \Theaters are like super-workspaces. They are used for different\n\t\ + \'contexts'. Theaters share all the windows with eachother, but\n\t\ + \but each theater has its own mappings for window -> workspace. i.e.\n\t\ + \one theater can have window 'x' on workspace 'y', but another might\n\t\ + \have 'x' on 'z' instead. If a theater does explicity place a window,\n\t\ + \the window is placed in the hidden workspace (which is '*')\n" + $ do + addStringToPendingBuffer " g " + runMaybeT_ $ + do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> restoreTheater (Just [ch]) + [' '] -> restoreTheater Nothing + _ -> return () bind xK_x $ do shiftMod $ @@ -859,10 +849,6 @@ bindings = do doc "Spawn a floating terminal" $ spawnX =<< asks ((++ " -t Floating\\ Term") . terminal . config) - bind xK_i $ do - justMod $ do - logs Info "Numlock mask: %s" =<< (gets (show . numberlockMask)) :: X () - bind xK_z $ do justMod $ doc "Less often used keybindings." $ @@ -933,8 +919,8 @@ bindings = do sendMessage togglePop bind xK_F8 $ do - justMod $ - doc + justMod + $ doc "Set the log level.\n\ \Log levels are, in order\n\n\t\ \Trace\n\t\ @@ -944,15 +930,15 @@ bindings = do \Error\n\t\ \Fatal\n\n\ \Log is sent to stdout." - $ do - ll <- getLogLevel - let next = if minBound == ll then maxBound else pred ll + $ do + ll <- getLogLevel + let next = if minBound == ll then maxBound else pred ll - safeSpawnX - "notify-send" - ["-t", "2000", printf "LogLevel set to %s" (show next)] - setLogLevel next - logs next "LogLevel set to %s." (show next) + safeSpawnX + "notify-send" + ["-t", "2000", printf "LogLevel set to %s" (show next)] + setLogLevel next + logs next "LogLevel set to %s." (show next) bind xF86XK_Calculator $ do noMod $ @@ -1220,25 +1206,25 @@ bindings = do forM_ [(button7, ",.", "right"), (button6, ";.", "left")] $ \(b, mot, d) -> do - bind b $ - noMod $ - doc - ( "Move the selected windows to the workspace on the \ - \screen to the " - ++ d - ) - $ noWindow $ - do - wins <- getAndResetWindowSelection - runMaybeT_ $ do - ws' <- workspaceForStringT mot - ws <- MaybeT . return $ workspaceName ws' - lift $ - let f = - appEndo - ( mconcat (map (Endo . W.shiftWin ws) wins) - ) - in windows f >> escape + bind b + $ noMod + $ doc + ( "Move the selected windows to the workspace on the \ + \screen to the " + ++ d + ) + $ noWindow + $ do + wins <- getAndResetWindowSelection + runMaybeT_ $ do + ws' <- workspaceForStringT mot + ws <- MaybeT . return $ workspaceName ws' + lift $ + let f = + appEndo + ( mconcat (map (Endo . W.shiftWin ws) wins) + ) + in windows f >> escape -- Keycode Bindings. -- 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 diff --git a/src/Rahm/Desktop/XMobarLog/PendingBuffer.hs b/src/Rahm/Desktop/XMobarLog/PendingBuffer.hs index 28ba9a8..67ae6a3 100644 --- a/src/Rahm/Desktop/XMobarLog/PendingBuffer.hs +++ b/src/Rahm/Desktop/XMobarLog/PendingBuffer.hs @@ -8,6 +8,7 @@ module Rahm.Desktop.XMobarLog.PendingBuffer ) where +import Rahm.Desktop.Common import Data.Default (Default (..)) import XMonad (X) import qualified XMonad as X @@ -54,14 +55,14 @@ clearPendingBuffer = do getPendingBuffer :: X [Char] getPendingBuffer = unPendingBuffer <$> XS.get -pushPendingBuffer :: String -> X a -> X a +pushPendingBuffer :: (Xish x) => String -> x a -> x a pushPendingBuffer newPendingBuffer fn = do - saved <- getPendingBuffer - setPendingBuffer newPendingBuffer - fn <* setPendingBuffer saved + saved <- liftFromX getPendingBuffer + liftFromX $ setPendingBuffer newPendingBuffer + fn <* liftFromX (setPendingBuffer saved) -pushAddPendingBuffer :: String -> X a -> X a +pushAddPendingBuffer :: (Xish x) => String -> x a -> x a pushAddPendingBuffer toAdd fn = do - saved <- getPendingBuffer - setPendingBuffer (saved ++ toAdd) - fn <* setPendingBuffer saved + saved <- liftFromX getPendingBuffer + liftFromX $ setPendingBuffer (saved ++ toAdd) + fn <* liftFromX (setPendingBuffer saved) -- cgit