[feat] properly color the borders when swapping windows.

5 files changed, 66 insertions, 34 deletions

diff --git a/src/Rahm/Desktop/BorderColors.hs b/src/Rahm/Desktop/BorderColors.hs
index f81ef06..b0e978c 100644
--- a/src/Rahm/Desktop/BorderColors.hs
+++ b/src/Rahm/Desktop/BorderColors.hs
@@ -3,15 +3,15 @@ module Rahm.Desktop.BorderColors where
 import Control.Monad (when)
 import Control.Monad.Trans (lift)
 import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT, throwE)
-import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
 import Data.Foldable (forM_)
 import Data.Map (Map)
+import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
-import qualified Data.Map as Map
 import Data.Void (absurd)
-import Rahm.Desktop.Common (runMaybeT_)
+import Rahm.Desktop.Common (Xish (..), runMaybeT_)
 import Rahm.Desktop.Hooks.WindowChange (StackChangeHook (StackChangeHook))
+import Rahm.Desktop.Logger (LogLevel (Debug), logs)
 import qualified Rahm.Desktop.StackSet as W
 import XMonad
 import qualified XMonad.Util.ExtensibleState as XS
@@ -37,8 +37,8 @@ stackChangeHook =
         mp <- gets mapped
         (BorderColorsState s) <- XS.get
         XS.put $
-         BorderColorsState $
-           Map.filterWithKey (\k _ -> k `Set.member` mp) s
+          BorderColorsState $
+            Map.filterWithKey (\k _ -> k `Set.member` mp) s
         (BorderColorsState s) <- XS.get
         updateBorderColors $ Map.keys s
     )
@@ -107,14 +107,9 @@ resetBorderColor wins = do
     BorderColorsState $
       foldl (flip Map.delete) mp wins
 
-  updateBorderColors  wins
-
-withBorderColorM :: BorderColor -> [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
+  updateBorderColors wins
 
-withBorderColor :: BorderColor -> [Window] -> X a -> X a
-withBorderColor s ws fn =
-  either absurd id <$> runExceptT (withBorderColorE s ws (lift fn))
+withBorderColor :: (Xish x, Monad x) => BorderColor -> [Window] -> x a -> x a
+withBorderColor s ws fn = do
+  cleanup <- liftFromX (setBorderColor s ws)
+  finallyX fn $ liftFromX cleanup
diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index 6ca3513..f436239 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -29,6 +29,7 @@ where
 import Control.Applicative ((<*))
 import Control.Exception (SomeException (SomeException), catch)
 import Control.Monad (forM_, guard, void, when)
+import Control.Monad.Except (MonadError (catchError, throwError))
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT, throwE)
 import Control.Monad.Trans.Identity (IdentityT (..))
@@ -253,8 +254,26 @@ floatAll ws = do
 
   windows endo
 
-class (Monad m) => Xish m where
+class Xish m where
   liftFromX :: X a -> m a
+  finallyX :: m a -> m () -> m a
 
 instance Xish X where
   liftFromX = id
+  finallyX mt err = do
+    maybe (fail "original action failed.") (\a -> err >> return a)
+      =<< catchX (Just <$> mt) (return Nothing)
+
+instance Xish (MaybeT X) where
+  liftFromX = lift
+  finallyX mt err = MaybeT $ do
+    maybeR <- runMaybeT mt
+    case maybeR of
+      Nothing -> runMaybeT err >> return Nothing
+      Just r -> fmap (r <$) (runMaybeT err)
+
+instance Xish (ExceptT e X) where
+  liftFromX = lift
+  finallyX mt err = do
+    either (\e -> err >> throwError e) (\a -> err >> return a)
+      =<< catchError (Right <$> mt) (return . Left)
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 5fcea5a..ae06b9d 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -45,7 +45,7 @@ import Graphics.X11.ExtraTypes.XF86
     xF86XK_MonBrightnessUp,
   )
 import Graphics.X11.XScreenSaver (XScreenSaverState (ScreenSaverCycle))
-import Rahm.Desktop.BorderColors (BorderColor (BorderColor), withBorderColor, withBorderColorM)
+import Rahm.Desktop.BorderColors (BorderColor (BorderColor), withBorderColor)
 import Rahm.Desktop.Common
   ( Location (..),
     Xish (liftFromX),
@@ -386,17 +386,18 @@ bindings = do
                             logs Debug "No swap buddy for %s" (show current)
                   )
                   $ do
-                    l1 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet
-                    liftFromX $ addStringToPendingBuffer " "
-                    l2 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet
-                    let (l1', l2') =
-                          if length l1 > length l2
-                            then (l1, l2)
-                            else (l2, l1)
-                        l1'' = filter (not . (`elem` l2')) l1'
-                     in liftFromX $ do
-                          setAlternateWindows (l1'' ++ l2')
-                          swapWindows l1'' l2'
+                    l1 <- mapMaybe locationWindow <$> readNextLocationSet
+                    withBorderColor selectedWindowsColor l1 $ do
+                      liftFromX $ addStringToPendingBuffer " "
+                      l2 <- mapMaybe locationWindow <$> readNextLocationSet
+                      let (l1', l2') =
+                            if length l1 > length l2
+                              then (l1, l2)
+                              else (l2, l1)
+                          l1'' = filter (not . (`elem` l2')) l1'
+                       in liftFromX $ do
+                            setAlternateWindows (l1'' ++ l2')
+                            swapWindows l1'' l2'
 
     -- let doExec :: KeyFeed a -> KeyFeed a -> KeyFeed a
     --     doExec ifDouble notDouble =
@@ -431,7 +432,7 @@ bindings = do
         runMaybeT_ $ do
           w1 <- runKeyFeed readNextWorkspaceName
           wins <- lift $ W.windowsOnWorkspace w1 <$> gets windowset
-          withBorderColorM selectedWindowsColor wins $ do
+          withBorderColor selectedWindowsColor wins $ do
             lift $ addStringToPendingBuffer " "
             w2 <- runKeyFeed readNextWorkspaceName
             lift $ windows $ W.swapWorkspaces w1 w2
@@ -834,7 +835,7 @@ bindings = do
           $ do
             stackset <- lift $ X.windowset <$> X.get
             selection <- mapMaybe locationWindow <$> runKeyFeed readNextLocationSet
-            (allMovements, finalSwap) <- withBorderColorM selectedWindowsColor selection $ do
+            (allMovements, finalSwap) <- withBorderColor selectedWindowsColor selection $ do
               lift $ addStringToPendingBuffer " "
               ws <- runKeyFeed readNextWorkspace
               finalSwap <-
diff --git a/src/Rahm/Desktop/Keys/KeyFeed.hs b/src/Rahm/Desktop/Keys/KeyFeed.hs
index 46a2520..5b00af9 100644
--- a/src/Rahm/Desktop/Keys/KeyFeed.hs
+++ b/src/Rahm/Desktop/Keys/KeyFeed.hs
@@ -4,7 +4,7 @@
 module Rahm.Desktop.Keys.KeyFeed where
 
 import Control.Monad (void, when)
-import Control.Monad.State (MonadTrans (lift), StateT, evalStateT, modify')
+import Control.Monad.State (MonadTrans (lift), StateT (..), evalStateT, modify')
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
 import Data.List.Safe (head, last)
 import Linear.V (reifyDim)
@@ -28,7 +28,24 @@ newtype KeyFeed a = KeyFeed (StateT KeyStream (MaybeT X) a)
   deriving (Functor, Applicative, Monad)
 
 instance Xish KeyFeed where
-  liftFromX = liftXToFeed
+  liftFromX = KeyFeed . lift . lift
+
+  finallyX (KeyFeed mt) (KeyFeed err) =
+    KeyFeed $ do
+      r <- recover mt
+      case r of
+        Nothing -> do
+          err
+          let (KeyFeed r) = feedFail in r
+        Just a -> err >> pure a
+    where
+      recover fn = StateT $ \s -> MaybeT $ do
+        r <- runMaybeT (runStateT fn s)
+        pure $
+          Just $
+            case r of
+              Nothing -> (Nothing, s)
+              Just (a, s') -> (Just a, s')
 
 -- Executes a KeyFeed, returning a MaybeT of the result
 runKeyFeed :: KeyFeed a -> MaybeT X a
diff --git a/src/Rahm/Desktop/XMobarLog/PendingBuffer.hs b/src/Rahm/Desktop/XMobarLog/PendingBuffer.hs
index 67ae6a3..c8e7c75 100644
--- a/src/Rahm/Desktop/XMobarLog/PendingBuffer.hs
+++ b/src/Rahm/Desktop/XMobarLog/PendingBuffer.hs
@@ -55,13 +55,13 @@ clearPendingBuffer = do
 getPendingBuffer :: X [Char]
 getPendingBuffer = unPendingBuffer <$> XS.get
 
-pushPendingBuffer :: (Xish x) => String -> x a -> x a
+pushPendingBuffer :: (Xish x, Monad x) => String -> x a -> x a
 pushPendingBuffer newPendingBuffer fn = do
   saved <- liftFromX getPendingBuffer
   liftFromX $ setPendingBuffer newPendingBuffer
   fn <* liftFromX (setPendingBuffer saved)
 
-pushAddPendingBuffer :: (Xish x) => String -> x a -> x a
+pushAddPendingBuffer :: (Xish x, Monad x) => String -> x a -> x a
 pushAddPendingBuffer toAdd fn = do
   saved <- liftFromX getPendingBuffer
   liftFromX $ setPendingBuffer (saved ++ toAdd)