@@ -43,42 +43,44 @@ import Effectful.Internal.Env
4343import Effectful.Internal.Monad
4444
4545data Error e :: Effect where
46− Error :: Unique -> Error e m r
46+ Error :: ErrorId -> Error e m r
4747
48−-- | TODO: write about possibility of an error escaping the scope of 'runError'
49−-- when misused with 'AsyncE'.
5048runError
5149 :: forall e es a. Typeable e
5250 => Eff (Error e : es) a
5351 -> Eff es (Either (CallStack, e) a)
5452runError m = unsafeEff $ \es0 -> mask $ \release -> do
55− -- A unique tag is picked so that different runError handlers for the same
56− -- type don't catch each other's exceptions.
57− tag <- newUnique
53+ eid <- newErrorId
5854 size0 <- sizeEnv es0
59− es <- unsafeConsEnv (IdE (Error @e tag)) noRelinker es0
60− r <- tryErrorIO tag (release $ unEff m es) `onException` unsafeTailEnv size0 es
55+ es <- unsafeConsEnv (IdE (Error @e eid)) noRelinker es0
56+ r <- tryErrorIO release eid es `onException` unsafeTailEnv size0 es
6157 _ <- unsafeTailEnv size0 es
6258 pure r
59+ where
60+ tryErrorIO release eid es = try (release $ unEff m es) >>= \case
61+ Right a -> pure $ Right a
62+ Left ex -> tryHandler ex eid (\cs e -> Left (cs, e))
63+ $ throwIO ex
6364
6465throwError
6566 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
6667 => e
6768 -> Eff es a
68−throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
69− throwIO $ ErrorEx tag callStack e
69+throwError e = unsafeEff $ \es -> do
70+ IdE (Error eid) <- getEnv @(Error e) es
71+ throwIO $ ErrorEx eid callStack e
7072
7173catchError
7274 :: forall e es a. (Typeable e, Error e :> es)
7375 => Eff es a
7476 -> (CallStack -> e -> Eff es a)
7577 -> Eff es a
76−catchError m handler = do
77− readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do
78− size <- sizeEnv es
79− catchErrorIO tag (unEff m es) $ \cs e -> do
80− checkSizeEnv size es
81− unEff (handler cs e) es
78+catchError m handler = unsafeEff $ \es -> do
79+ IdE (Error eid) <- getEnv @(Error e) es
80+ size <- sizeEnv es
81+ catchErrorIO eid (unEff m es) $ \cs e -> do
82+ checkSizeEnv size es
83+ unEff (handler cs e) es
8284
8385tryError
8486 :: forall e es a. (Typeable e, Error e :> es)
@@ -89,7 +91,28 @@ tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
8991----------------------------------------
9092-- Helpers
9193
92−data ErrorEx e = ErrorEx Unique CallStack e
94+newtype ErrorId = ErrorId Unique
95+ deriving Eq
96+
97+-- | A unique is picked so that distinct 'Error' handlers for the same type
98+-- don't catch each other's exceptions.
99+newErrorId :: IO ErrorId
100+newErrorId = ErrorId <$> newUnique
101+
102+tryHandler
103+ :: Typeable e
104+ => SomeException
105+ -> ErrorId
106+ -> (CallStack -> e -> r)
107+ -> IO r
108+ -> IO r
109+tryHandler ex eid0 handler next = case fromException ex of
110+ Just (ErrorEx eid cs e)
111+ | eid0 == eid -> pure $ handler cs e
112+ | otherwise -> next
113+ Nothing -> next
114+
115+data ErrorEx e = ErrorEx ErrorId CallStack e
93116instance Typeable e => Show (ErrorEx e) where
94117 showsPrec p (ErrorEx _ cs e)
95118 = ("Effectful.Error.ErrorEx (" ++)
@@ -98,12 +121,9 @@ instance Typeable e => Show (ErrorEx e) where
98121 . showsPrec p cs
99122instance Typeable e => Exception (ErrorEx e)
100123
101−catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a
102−catchErrorIO tag m handler = do
124+catchErrorIO :: Typeable e => ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a
125+catchErrorIO eid m handler = do
103126 m `catch` \err@(ErrorEx etag e cs) -> do
104− if tag == etag
127+ if eid == etag
105128 then handler e cs
106129 else throwIO err
107−
108−tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either (CallStack, e) a)
109−tryErrorIO tag m = catchErrorIO tag (Right <$> m) $ \es e -> pure $ Left (es, e)