Generalize catchSTM

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 2e3247f..d08ccf2 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -58,7 +58,7 @@ module GHC.Conc
         , atomically    -- :: STM a -> IO a
         , retry         -- :: STM a
         , orElse        -- :: STM a -> STM a -> STM a
-        , catchSTM      -- :: STM a -> (Exception -> STM a) -> STM a
+        , catchSTM      -- :: Exception e => STM a -> (e -> STM a) -> STM a
         , alwaysSucceeds -- :: STM a -> STM ()
         , always        -- :: STM Bool -> STM ()
         , TVar(..)

diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs
index 9b7415d..38717e6 100644 (file)
--- a/GHC/Conc/Sync.lhs
+++ b/GHC/Conc/Sync.lhs
@@ -52,7 +52,7 @@ module GHC.Conc.Sync
         , atomically    -- :: STM a -> IO a
         , retry         -- :: STM a
         , orElse        -- :: STM a -> STM a -> STM a
-        , catchSTM      -- :: STM a -> (Exception -> STM a) -> STM a
+        , catchSTM      -- :: Exception e => STM a -> (e -> STM a) -> STM a
         , alwaysSucceeds -- :: STM a -> STM ()
         , always        -- :: STM Bool -> STM ()
         , TVar(..)
@@ -510,8 +510,12 @@ orElse :: STM a -> STM a -> STM a
 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 
 -- |Exception handling within STM actions.
-catchSTM :: STM a -> (SomeException -> STM a) -> STM a
-catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
+catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
+catchSTM (STM m) handler = STM $ catchSTM# m handler'
+    where
+      handler' e = case fromException e of
+                     Just e' -> unSTM (handler e')
+                     Nothing -> raiseIO# e
 
 -- | Low-level primitive on which always and alwaysSucceeds are built.
 -- checkInv differs form these in that (i) the invariant is not