aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Rahm/Desktop/BorderColors.hs25
-rw-r--r--src/Rahm/Desktop/Common.hs21
-rw-r--r--src/Rahm/Desktop/Keys.hs29
-rw-r--r--src/Rahm/Desktop/Keys/KeyFeed.hs21
-rw-r--r--src/Rahm/Desktop/XMobarLog/PendingBuffer.hs4
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)
generated by cgit (git 2.34.1) at 2026-10-19 11:32:12 +0000