git.iko.soy/effectful
on master help sign in
Ditinguish between different Error handlers for the same type
7a1d6f9Andrzej Rybczak
src/Effectful/Error.hs+40−19
compare with master
unifiedsplit
@@ -12,6 +12,7 @@ module Effectful.Error
12
12
13import Control.Exception
13import Control.Exception
14import Data.Typeable
14import Data.Typeable
15+import Data.Unique
15import GHC.Stack
16import GHC.Stack
16
17
17import Effectful.Internal.Effect
18import Effectful.Internal.Effect
@@ -20,48 +21,68 @@ import Effectful.Internal.Monad
20import Effectful.Internal.Utils
21import Effectful.Internal.Utils
21
22
22data Error e :: Effect where
23data Error e :: Effect where
23− Error :: Error e m r
24+ Error :: Unique -> Error e m r
24
25
26+-- | TODO: write about possibility of an error escaping the scope of 'runError'
27+-- when misused with 'AsyncE'.
25runError
28runError
26 :: forall e es a. Typeable e
29 :: forall e es a. Typeable e
27 => Eff (Error e : es) a
30 => Eff (Error e : es) a
28 -> Eff es (Either ([String], e) a)
31 -> Eff es (Either ([String], e) a)
29runError (Eff m) = unsafeEff $ \es0 -> mask $ \release -> do
32runError (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
30 size0 <- sizeEnv es0
36 size0 <- sizeEnv es0
31− es <- unsafeConsEnv (IdE (Error @e)) noRelinker es0
37+ es <- unsafeConsEnv (IdE (Error @e tag)) noRelinker es0
32− try (release $ m es) >>= \case
33− Right a -> Right a <$ unsafeTailEnv size0 es
38+ r <- tryErrorIO tag (release $ m es) `onException` unsafeTailEnv size0 es
34− Left (WrapErr cs e) -> Left (cs, e) <$ unsafeTailEnv size0 es
39+ _ <- unsafeTailEnv size0 es
40+ pure r
35
41
36throwError
42throwError
37− :: (HasCallStack, Typeable e, Error e :> es)
43+ :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
38 => e
44 => e
39 -> Eff es a
45 -> Eff es a
40−throwError e = unsafeEff_ $ do
46+throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
41− throwIO $ WrapErr (ppCallStack <$> getCallStack callStack) e
47+ throwIO $ WrapErr tag (ppCallStack <$> getCallStack callStack) e
42
48
43catchError
49catchError
44− :: (Typeable e, Error e :> es)
50+ :: forall e es a. (Typeable e, Error e :> es)
45 => Eff es a
51 => Eff es a
46 -> ([String] -> e -> Eff es a)
52 -> ([String] -> e -> Eff es a)
47 -> Eff es a
53 -> Eff es a
48−catchError (Eff m) handler = unsafeEff $ \es -> do
54+catchError (Eff m) handler = do
55+ readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do
49− size <- sizeEnv es
56+ size <- sizeEnv es
50− m es `catch` \(WrapErr e cs) -> do
57+ catchErrorIO tag (m es) $ \cs e -> do
51− checkSizeEnv size es
58+ checkSizeEnv size es
52− unEff (handler e cs) es
59+ unEff (handler cs e) es
53
60
54tryError
61tryError
55− :: (Typeable e, Error e :> es)
62+ :: forall e es a. (Typeable e, Error e :> es)
56 => Eff es a
63 => Eff es a
57 -> Eff es (Either ([String], e) a)
64 -> 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)
59
66
60----------------------------------------
67----------------------------------------
61−-- WrapE
68+-- Helpers
62
69
63−data WrapErr e = WrapErr [String] e
70+data WrapErr e = WrapErr Unique [String] e
64
71
65instance Typeable e => Show (WrapErr e) where
72instance 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
67instance Typeable e => Exception (WrapErr e)
78instance 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)
tests/Main.hs+32−7
@@ -1,6 +1,7 @@
1module Main (main) where
1module Main (main) where
2
2
3import Control.Monad.IO.Class
3import Control.Monad.IO.Class
4+import Data.List (isPrefixOf)
4import Test.Tasty
5import Test.Tasty
5import Test.Tasty.HUnit
6import Test.Tasty.HUnit
6import qualified Control.Monad.Catch as E
7import qualified Control.Monad.Catch as E
@@ -8,6 +9,7 @@ import qualified Control.Exception.Lifted as LE
8import qualified UnliftIO.Exception as UE
9import qualified UnliftIO.Exception as UE
9
10
10import Effectful.Async
11import Effectful.Async
12+import Effectful.Error
11import Effectful.Interpreter
13import Effectful.Interpreter
12import Effectful.State.Dynamic
14import Effectful.State.Dynamic
13import Effectful.Monad
15import Effectful.Monad
@@ -22,6 +24,7 @@ main = defaultMain $ testGroup "effectful"
22 , testCase "exceptions" test_exceptions
24 , testCase "exceptions" test_exceptions
23 , testCase "concurrency" test_concurrentState
25 , testCase "concurrency" test_concurrentState
24 , testCase "local effects" test_localEffects
26 , testCase "local effects" test_localEffects
27+ , testCase "error from interpret" test_errorFromInterpret
25 ]
28 ]
26 ]
29 ]
27
30
@@ -118,12 +121,28 @@ test_localEffects = runIOE $ do
118 getInt
121 getInt
119 assertEqual_ "correct x" 4 x
122 assertEqual_ "correct x" 4 x
120
123
121−runHasInt :: Int -> Eff (HasInt : es) a -> Eff es a
124+test_errorFromInterpret :: Assertion
122−runHasInt n =
125+test_errorFromInterpret = runIOE $ do
123− -- reinterpret with redundant local effects
126+ result <- runError @String . runNestedErr $ do
124− reinterpret (evalState () . evalState n . evalState True) $ \case
127+ runError @String nestedErr
125− GetInt -> get
128+ liftIO $ case result of
126− PutInt i -> put i
129+ Left (cs, _) -> assertBool "stack trace points to the correct action" $
130+ "nestedErr" `isPrefixOf` last cs
131+ Right _ -> assertFailure "error caught by the wrong (inner) handler"
132+
133+----------------------------------------
134+-- Helpers
135+
136+data NestedErr :: Effect where
137+ NestedErr :: NestedErr m ()
138+
139+nestedErr :: (HasCallStack, NestedErr :> es) => Eff es ()
140+nestedErr = send NestedErr
141+
142+runNestedErr :: Error String :> es => Eff (NestedErr : es) a -> Eff es a
143+runNestedErr = interpret $ \NestedErr -> throwError "nested error"
144+
145+----------------------------------------
127
146
128data HasInt :: Effect where
147data HasInt :: Effect where
129 GetInt :: HasInt m Int
148 GetInt :: HasInt m Int
@@ -135,8 +154,14 @@ getInt = send GetInt
135putInt :: HasInt :> es => Int -> Eff es ()
154putInt :: HasInt :> es => Int -> Eff es ()
136putInt = send . PutInt
155putInt = send . PutInt
137
156
157+runHasInt :: Int -> Eff (HasInt : es) a -> Eff es a
158+runHasInt n =
159+ -- reinterpret with redundant local effects
160+ reinterpret (evalState () . evalState n . evalState True) $ \case
161+ GetInt -> get
162+ PutInt i -> put i
163+
138----------------------------------------
164----------------------------------------
139−-- Helpers
140
165
141data Ex = Ex deriving (Eq, Show)
166data Ex = Ex deriving (Eq, Show)
142instance E.Exception Ex
167instance E.Exception Ex