@@ -12,6 +12,7 @@ module Effectful.Error
1212
1313import Control.Exception
1414import Data.Typeable
15+import Data.Unique
1516import GHC.Stack
1617
1718import Effectful.Internal.Effect
@@ -20,48 +21,68 @@ import Effectful.Internal.Monad
2021import Effectful.Internal.Utils
2122
2223data Error e :: Effect where
23− Error :: Error e m r
24+ Error :: Unique -> Error e m r
2425
26+-- | TODO: write about possibility of an error escaping the scope of 'runError'
27+-- when misused with 'AsyncE'.
2528runError
2629 :: forall e es a. Typeable e
2730 => Eff (Error e : es) a
2831 -> Eff es (Either ([String], e) a)
2932runError (Eff m) = unsafeEff $ \es0 -> mask $ \release -> do
33+ -- A unique tag is picked so that different runError handlers for the same
34+ -- type don't catch each other's exceptions.
35+ tag <- newUnique
3036 size0 <- sizeEnv es0
31− es <- unsafeConsEnv (IdE (Error @e)) noRelinker es0
32− try (release $ m es) >>= \case
33− Right a -> Right a <$ unsafeTailEnv size0 es
34− Left (WrapErr cs e) -> Left (cs, e) <$ unsafeTailEnv size0 es
37+ es <- unsafeConsEnv (IdE (Error @e tag)) noRelinker es0
38+ r <- tryErrorIO tag (release $ m es) `onException` unsafeTailEnv size0 es
39+ _ <- unsafeTailEnv size0 es
40+ pure r
3541
3642throwError
37− :: (HasCallStack, Typeable e, Error e :> es)
43+ :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
3844 => e
3945 -> Eff es a
40−throwError e = unsafeEff_ $ do
41− throwIO $ WrapErr (ppCallStack <$> getCallStack callStack) e
46+throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
47+ throwIO $ WrapErr tag (ppCallStack <$> getCallStack callStack) e
4248
4349catchError
44− :: (Typeable e, Error e :> es)
50+ :: forall e es a. (Typeable e, Error e :> es)
4551 => Eff es a
4652 -> ([String] -> e -> Eff es a)
4753 -> Eff es a
48−catchError (Eff m) handler = unsafeEff $ \es -> do
49− size <- sizeEnv es
50− m es `catch` \(WrapErr e cs) -> do
51− checkSizeEnv size es
52− unEff (handler e cs) es
54+catchError (Eff m) handler = do
55+ readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do
56+ size <- sizeEnv es
57+ catchErrorIO tag (m es) $ \cs e -> do
58+ checkSizeEnv size es
59+ unEff (handler cs e) es
5360
5461tryError
55− :: (Typeable e, Error e :> es)
62+ :: forall e es a. (Typeable e, Error e :> es)
5663 => Eff es a
5764 -> Eff es (Either ([String], e) a)
58−tryError m = (Right <$> m) `catchError` \es e -> pure (Left (es, e))
65+tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
5966
6067----------------------------------------
61−-- WrapE
68+-- Helpers
6269
63−data WrapErr e = WrapErr [String] e
70+data WrapErr e = WrapErr Unique [String] e
6471
6572instance Typeable e => Show (WrapErr e) where
66− show (WrapErr _ e) = "WrapErr " ++ show (typeOf e)
73+ showsPrec p (WrapErr _ cs e)
74+ = showsPrec p "Effectful.Error.WrapErr ("
75+ . showsPrec p (typeOf e)
76+ . showsPrec p ") "
77+ . showsPrec p cs
6778instance Typeable e => Exception (WrapErr e)
79+
80+catchErrorIO :: Typeable e => Unique -> IO a -> ([String] -> e -> IO a) -> IO a
81+catchErrorIO tag m handler = do
82+ m `catch` \err@(WrapErr etag e cs) -> do
83+ if tag == etag
84+ then handler e cs
85+ else throwIO err
86+
87+tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either ([String], e) a)
88+tryErrorIO tag m = catchErrorIO tag (Right <$> m) $ \es e -> pure $ Left (es, e)