git.iko.soy/effectful
on e519afb help sign in
effectful/src/Effectful/Error.hs
109 lines 3.3 kB history raw
1{- | Support for checked exceptions.
3 The `Error` effect provided by this module is a suitable replacement for the
4 `Control.Monad.Except.ExceptT` monad transformer found in the mtl library.
5 It is __not__ intended to be a general mechanism for catching errors like
6 the functions of the 'exceptions' package. For example, if you want to catch
7 an unchecked exception like `Control.Exception.SomeException` or
8 `Control.Exception.ErrorCall` you could rely on `Control.Monad.catch`:
10 >>> :{
11 let boom :: Eff '[IOE] String
12 boom = error "BOOM!"
13 in
14 runIOE $ boom `Control.Monad.Catch.catch` \(e :: ErrorCall) ->
15 return "caught some error"
16 :}
17 "caught some error"
18-}
19module Effectful.Error
20 ( Error
21 , runError
22 , throwError
23 , catchError
24 , tryError
26 -- * Re-exports
27 , Exception
28 ) where
30import Control.Exception
31import Data.Typeable
32import Data.Unique
33import GHC.Stack
35import Effectful.Internal.Effect
36import Effectful.Internal.Env
37import Effectful.Internal.Monad
39-- $setup
40-- >>> import Control.Monad.Catch
41-- >>> import Control.Monad.IO.Class
42-- >>> import Effectful.Interpreter
44data Error e :: Effect where
45 Error :: Unique -> Error e m r
47-- | TODO: write about possibility of an error escaping the scope of 'runError'
48-- when misused with 'AsyncE'.
49runError
50 :: forall e es a. Typeable e
51 => Eff (Error e : es) a
52 -> Eff es (Either (CallStack, e) a)
53runError (Eff m) = unsafeEff $ \es0 -> mask $ \release -> do
54 -- A unique tag is picked so that different runError handlers for the same
55 -- type don't catch each other's exceptions.
56 tag <- newUnique
57 size0 <- sizeEnv es0
58 es <- unsafeConsEnv (IdE (Error @e tag)) noRelinker es0
59 r <- tryErrorIO tag (release $ m es) `onException` unsafeTailEnv size0 es
60 _ <- unsafeTailEnv size0 es
61 pure r
63throwError
64 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
65 => e
66 -> Eff es a
67throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
68 throwIO $ WrapErr tag callStack e
70catchError
71 :: forall e es a. (Typeable e, Error e :> es)
72 => Eff es a
73 -> (CallStack -> e -> Eff es a)
74 -> Eff es a
75catchError (Eff m) handler = do
76 readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do
77 size <- sizeEnv es
78 catchErrorIO tag (m es) $ \cs e -> do
79 checkSizeEnv size es
80 unEff (handler cs e) es
82tryError
83 :: forall e es a. (Typeable e, Error e :> es)
84 => Eff es a
85 -> Eff es (Either (CallStack, e) a)
86tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
88----------------------------------------
89-- Helpers
91data WrapErr e = WrapErr Unique CallStack e
93instance Typeable e => Show (WrapErr e) where
94 showsPrec p (WrapErr _ cs e)
95 = showsPrec p "Effectful.Error.WrapErr ("
96 . showsPrec p (typeOf e)
97 . showsPrec p ") "
98 . showsPrec p cs
99instance Typeable e => Exception (WrapErr e)
101catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a
102catchErrorIO tag m handler = do
103 m `catch` \err@(WrapErr etag e cs) -> do
104 if tag == etag
105 then handler e cs
106 else throwIO err
108tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either (CallStack, e) a)
109tryErrorIO tag m = catchErrorIO tag (Right <$> m) $ \es e -> pure $ Left (es, e)