diff options
Diffstat (limited to 'src/Rahm')
| -rw-r--r-- | src/Rahm/Desktop/Common.hs | 63 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Keys.hs | 30 |
2 files changed, 71 insertions, 22 deletions
diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 0ac41a7..01fa35b 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -6,6 +6,8 @@ module Rahm.Desktop.Common askWindowId, windowJump, withBorderColor, + withBorderColorE, + withBorderColorM, withBorderWidth, getCurrentScreen, gotoWorkspace, @@ -17,12 +19,18 @@ module Rahm.Desktop.Common ) where +import Data.Void (absurd, Void (..)) +import Data.Either (either) +import Control.Applicative ((<*)) import Control.Monad (forM_, void, when) import Control.Monad.Trans.Maybe (MaybeT (..)) +import Control.Monad.Trans.Identity (IdentityT (..)) +import Control.Monad.Trans.Except (runExceptT, ExceptT (..), catchE, throwE) +import Control.Monad.Trans.Class import Data.Char (toLower) import Data.List (concatMap, head, isInfixOf, map, (++)) import qualified Data.Map as Map (fromListWith) -import Data.Maybe (Maybe (..)) +import Data.Maybe (Maybe (..), maybe) import Rahm.Desktop.DMenu (runDMenuPromptWithMap) import qualified Rahm.Desktop.StackSet as S ( Screen (Screen, workspace), @@ -116,31 +124,48 @@ askWindowId = do windowJump :: X () windowJump = mapM_ (focus . head) =<< askWindowId --- Temporarily set the border color of the given windows. -withBorderColor :: String -> [Window] -> X a -> X a -withBorderColor color wins fn = do - d <- asks display - px <- stringToPixel d color - oPx <- stringToPixel d =<< asks (normalBorderColor . config) - fPx <- stringToPixel d =<< asks (focusedBorderColor . config) +-- Have to add a definition because Stack uses an ancient version of +-- transformers for some reason. +myFinallyE :: Monad m => ExceptT e m a -> ExceptT e m () -> ExceptT e m a +myFinallyE m closer = catchE (m <* closer) (\e -> closer >> throwE e) - colorName <- io (pixelToString d px) - oColorName <- io (pixelToString d oPx) - fColorName <- io (pixelToString d fPx) +-- Temporarily set the border color of the given windows. +withBorderColorE :: String -> [Window] -> ExceptT e X a -> ExceptT e X a +withBorderColorE color wins fn = do + d <- lift $ asks display + (px, oPx, fPx) <- lift $ + (,,) + <$> stringToPixel d color + <*> (stringToPixel d =<< asks (normalBorderColor . config)) + <*> (stringToPixel d =<< asks (focusedBorderColor . config)) + + (colorName, oColorName, fColorName) <- lift $ + (,,) + <$> io (pixelToString d px) + <*> io (pixelToString d oPx) + <*> io (pixelToString d fPx) forM_ wins $ \w -> - setWindowBorderWithFallback d w colorName px + lift $ setWindowBorderWithFallback d w colorName px - ret <- fn + myFinallyE fn $ + lift $ + withFocused $ \fw -> do + forM_ wins $ \w -> + when (w /= fw) $ + setWindowBorderWithFallback d w oColorName oPx - withFocused $ \fw -> do - forM_ wins $ \w -> - when (w /= fw) $ - setWindowBorderWithFallback d w oColorName oPx + setWindowBorderWithFallback d fw fColorName fPx - setWindowBorderWithFallback d fw fColorName fPx +withBorderColorM :: String -> [Window] -> MaybeT X a -> MaybeT X a +withBorderColorM s ws fn = toMaybeT $ withBorderColorE s ws (toExceptT fn) + where + toExceptT (MaybeT fn) = ExceptT $ maybe (Left ()) Right <$> fn + toMaybeT (ExceptT fn) = MaybeT $ either (const Nothing) Just <$> fn - return ret +withBorderColor :: String -> [Window] -> X a -> X a +withBorderColor s ws fn = + either absurd id <$> runExceptT (withBorderColorE s ws (lift fn)) withBorderWidth :: Int -> [Window] -> X a -> X a withBorderWidth width ws fn = do diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 518977e..49f0ebf 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -46,6 +46,8 @@ import Rahm.Desktop.Common locationWorkspace, runMaybeT_, withBorderColor, + withBorderColorM, + Location(..), ) import Rahm.Desktop.DMenu (runDMenu) import Rahm.Desktop.History @@ -255,6 +257,17 @@ keyBindingToKeymap bindings config = Map.mapWithKey bindingToX (bindings config) mapping ) +mapWindows :: (Ord b) => (a -> b) -> W.StackSet i l a s sd -> W.StackSet i l b s sd +mapWindows fn (W.StackSet cur vis hidden float) = + W.StackSet + (mapScreen fn cur) + (map (mapScreen fn) vis) + (map (mapWorkspace fn) hidden) + (Map.mapKeys fn float) + where + mapScreen fn (W.Screen ws s sd) = W.Screen (mapWorkspace fn ws) s sd + mapWorkspace fn (W.Workspace t l s) = W.Workspace t l (fmap (fmap fn) s) + keymap :: XConfig l -> KeyBindings keymap = runKeys $ do config <- getConfig @@ -262,16 +275,27 @@ keymap = runKeys $ do let subkeys keysM = Submap (runKeys keysM config) repeatable keysM = Repeat (runKeys keysM config) - forM_ [("' ", xK_apostrophe), ("w ", xK_w)] $ \(buf, k) -> bind k $ do + bind xK_apostrophe $ justMod $ - doc "Jumps between marks." $ - pushPendingBuffer buf $ do + doc "Jump to a window" $ + pushPendingBuffer "' " $ do runMaybeT_ $ do l <- readNextLocationSet case l of (h : _) -> lift (focusLocation h) _ -> return () + bind xK_w $ do + justMod $ + doc "Swap windows with other windows" $ + pushPendingBuffer "w " $ do + runMaybeT_ $ do + l1 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet + withBorderColorM "#00ffff" l1 $ do + l2 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet + let rewriteMap = Map.fromList $ zip l1 l2 ++ zip l2 l1 + lift $ windows $ mapWindows (\w -> fromMaybe w (Map.lookup w rewriteMap)) + bind xK_BackSpace $ do -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if -- something goes wrong with the keyboard layout and for first-time boots |