From: Bas van Dijk <v.dijk.bas@gmail.com>
Date: Sun, 26 Sep 2010 19:21:06 +0000 (+0000)
Subject: Generalize catchSTM
X-Git-Tag: ghc-darcs-git-switchover~105
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0b899bbe17a448fa5f96d2c24ff198bd29ef6e61;p=ghc-base.git

Generalize catchSTM
---

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 2e3247f..d08ccf2 100644
--- 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
--- 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