git.iko.soy/effectful
on master help sign in
Adjustments to Error effect
85015a4Andrzej Rybczak
src/Effectful/Async.hs+2
compare with master
unifiedsplit
@@ -88,6 +88,8 @@ import Effectful.Internal.Monad
88--
88--
89-- /Note:/ thread local state changes in 'Eff' operations run asynchronously
89-- /Note:/ thread local state changes in 'Eff' operations run asynchronously
90-- will not affect the parent thread.
90-- will not affect the parent thread.
91+--
92+-- /TODO:/ write about 'AsyncE' not respecting scoped operations.
91data AsyncE :: Effect where
93data AsyncE :: Effect where
92 AsyncE :: AsyncE m r
94 AsyncE :: AsyncE m r
93
95
src/Effectful/Error.hs+43−23
@@ -43,42 +43,44 @@ import Effectful.Internal.Env
43import Effectful.Internal.Monad
43import Effectful.Internal.Monad
44
44
45data Error e :: Effect where
45data Error e :: Effect where
46− Error :: Unique -> Error e m r
46+ Error :: ErrorId -> Error e m r
47
47
48−-- | TODO: write about possibility of an error escaping the scope of 'runError'
49−-- when misused with 'AsyncE'.
50runError
48runError
51 :: forall e es a. Typeable e
49 :: forall e es a. Typeable e
52 => Eff (Error e : es) a
50 => Eff (Error e : es) a
53 -> Eff es (Either (CallStack, e) a)
51 -> Eff es (Either (CallStack, e) a)
54runError m = unsafeEff $ \es0 -> mask $ \release -> do
52runError m = unsafeEff $ \es0 -> mask $ \release -> do
55− -- A unique tag is picked so that different runError handlers for the same
53+ eid <- newErrorId
56− -- type don't catch each other's exceptions.
57− tag <- newUnique
58 size0 <- sizeEnv es0
54 size0 <- sizeEnv es0
59− es <- unsafeConsEnv (IdE (Error @e tag)) noRelinker es0
55+ es <- unsafeConsEnv (IdE (Error @e eid)) noRelinker es0
60− r <- tryErrorIO tag (release $ unEff m es) `onException` unsafeTailEnv size0 es
56+ r <- tryErrorIO release eid es `onException` unsafeTailEnv size0 es
61 _ <- unsafeTailEnv size0 es
57 _ <- unsafeTailEnv size0 es
62 pure r
58 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
63
64
64throwError
65throwError
65 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
66 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
66 => e
67 => e
67 -> Eff es a
68 -> Eff es a
68−throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
69+throwError e = unsafeEff $ \es -> do
70+ IdE (Error eid) <- getEnv @(Error e) es
69− throwIO $ ErrorEx tag callStack e
71+ throwIO $ ErrorEx eid callStack e
70
72
71catchError
73catchError
72 :: forall e es a. (Typeable e, Error e :> es)
74 :: forall e es a. (Typeable e, Error e :> es)
73 => Eff es a
75 => Eff es a
74 -> (CallStack -> e -> Eff es a)
76 -> (CallStack -> e -> Eff es a)
75 -> Eff es a
77 -> Eff es a
76−catchError m handler = do
78+catchError m handler = unsafeEff $ \es -> do
77− readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do
79+ IdE (Error eid) <- getEnv @(Error e) es
78− size <- sizeEnv es
80+ size <- sizeEnv es
79− catchErrorIO tag (unEff m es) $ \cs e -> do
81+ catchErrorIO eid (unEff m es) $ \cs e -> do
80− checkSizeEnv size es
82+ checkSizeEnv size es
81− unEff (handler cs e) es
83+ unEff (handler cs e) es
82
84
83tryError
85tryError
84 :: forall e es a. (Typeable e, Error e :> es)
86 :: forall e es a. (Typeable e, Error e :> es)
@@ -89,7 +91,28 @@ tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
89----------------------------------------
91----------------------------------------
90-- Helpers
92-- Helpers
91
93
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
93instance Typeable e => Show (ErrorEx e) where
116instance Typeable e => Show (ErrorEx e) where
94 showsPrec p (ErrorEx _ cs e)
117 showsPrec p (ErrorEx _ cs e)
95 = ("Effectful.Error.ErrorEx (" ++)
118 = ("Effectful.Error.ErrorEx (" ++)
@@ -98,12 +121,9 @@ instance Typeable e => Show (ErrorEx e) where
98 . showsPrec p cs
121 . showsPrec p cs
99instance Typeable e => Exception (ErrorEx e)
122instance Typeable e => Exception (ErrorEx e)
100
123
101−catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a
124+catchErrorIO :: Typeable e => ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a
102−catchErrorIO tag m handler = do
125+catchErrorIO eid m handler = do
103 m `catch` \err@(ErrorEx etag e cs) -> do
126 m `catch` \err@(ErrorEx etag e cs) -> do
104− if tag == etag
127+ if eid == etag
105 then handler e cs
128 then handler e cs
106 else throwIO err
129 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)