From 73216dfd16231e90950c43a76d12529af77e5c83 Mon Sep 17 00:00:00 2001
From: Josh Rahm <rahm@google.com>
Date: Thu, 30 Nov 2023 13:06:11 -0700
Subject: Change win+w to a swap windows command.

---
 src/Rahm/Desktop/Common.hs | 63 ++++++++++++++++++++++++++++++++--------------
 1 file changed, 44 insertions(+), 19 deletions(-)

(limited to 'src/Rahm/Desktop/Common.hs')

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
-- 
cgit