From 904b5d31224aaa14fcab522d10de1c6b1d898f68 Mon Sep 17 00:00:00 2001
From: David Roundy <droundy@darcs.net>
Date: Tue, 12 Jun 2007 17:42:53 +0200
Subject: add catchX to catch exceptions.

darcs-hash:20070612154253-72aca-b2c7e24b5e70a09feaebccd443aebbe37b568efa
---
 Operations.hs |  7 ++++---
 XMonad.hs     | 13 ++++++++++++-
 2 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/Operations.hs b/Operations.hs
index e03c0fd..fd85106 100644
--- a/Operations.hs
+++ b/Operations.hs
@@ -153,7 +153,7 @@ windows f = do
 
         -- just the tiled windows:
         -- now tile the windows on this workspace, modified by the gap
-        rs <- runLayout l viewrect tiled -- `mplus` doLayout full viewrect tiled
+        rs <- runLayout l viewrect tiled `catchX` runLayout full viewrect tiled
         mapM_ (uncurry tileWindow) rs
 
         -- now the floating windows:
@@ -353,7 +353,7 @@ switchLayout = do
 sendMessage :: Message a => a -> X ()
 sendMessage a = do n <- (W.tag . W.workspace . W.current) `fmap` gets windowset
                    Just (l,ls) <- M.lookup n `fmap` gets layouts
-                   ml' <- modifyLayout l (SomeMessage a)
+                   ml' <- modifyLayout l (SomeMessage a) `catchX` return (Just l)
                    whenJust ml' $ \l' -> do modify $ \s -> s { layouts = M.insert n (l',ls) (layouts s) }
                                             refresh
 
@@ -362,7 +362,8 @@ sendMessage a = do n <- (W.tag . W.workspace . W.current) `fmap` gets windowset
 broadcastMessage :: Message a => a -> X ()
 broadcastMessage a = do
     ol <- gets layouts
-    nl <- T.forM ol $ \ (l,ls) -> maybe (l,ls) (flip (,) ls) `fmap` modifyLayout l (SomeMessage a)
+    nl <- T.forM ol $ \ (l,ls) -> maybe (l,ls) (flip (,) ls) `fmap`
+          (modifyLayout l (SomeMessage a) `catchX` return (Just l))
     modify $ \s -> s { layouts = nl }
 
 instance Message Event
diff --git a/XMonad.hs b/XMonad.hs
index b296a38..49c577e 100644
--- a/XMonad.hs
+++ b/XMonad.hs
@@ -17,7 +17,7 @@
 module XMonad (
     X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), XConf(..), Layout(..),
     Typeable, Message, SomeMessage(..), fromMessage, runLayout,
-    runX, io, catchIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX,
+    runX, catchX, io, catchIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX,
     atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW
   ) where
 
@@ -76,6 +76,17 @@ newtype X a = X (ReaderT XConf (StateT XState IO) a)
 runX :: XConf -> XState -> X a -> IO ()
 runX c st (X a) = runStateT (runReaderT a c) st >> return ()
 
+-- | Run in the X monad, and in case of exception, and catch it and log it
+-- to stderr, and run the error case.
+catchX :: X a -> X a -> X a
+catchX (X job) (X errcase) =
+    do st <- get
+       c <- ask
+       (a,s') <- io ((runStateT (runReaderT job c) st) `catch`
+                     \e -> (do hPutStrLn stderr (show e); runStateT (runReaderT errcase c) st))
+       put s'
+       return a
+
 -- ---------------------------------------------------------------------
 -- Convenient wrappers to state
 
-- 
cgit v1.2.3