git.iko.soy/effectful
on 043bffe help sign in
effectful/src/Effectful/Error.hs
103 lines 3.1 kB history raw
1{- | Support for checked exceptions.
3The 'Error' effect provided by this module is a suitable replacement for the
4'Control.Monad.Except.ExceptT' monad transformer found in the @mtl@ library. It
5is __not__ intended to be a general mechanism for catching errors, that's what
6functions from the "Control.Monad.Catch" module are for.
8For example, if you want to catch an unchecked exception like
9'Control.Exception.SomeException' or 'Control.Exception.ErrorCall' you could use
10'Control.Monad.Catch.catch':
12>>> import qualified Control.Monad.Catch as E
13>>> :{
14 let boom :: Eff es String
15 boom = error "BOOM!"
16 in
17 runIOE $ boom `E.catch` \(e :: ErrorCall) -> pure "caught some error"
18:}
19"caught some error"
21-}
22module Effectful.Error
23 ( Error
24 , runError
25 , throwError
26 , catchError
27 , tryError
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
39data Error e :: Effect where
40 Error :: Unique -> Error e m r
42-- | TODO: write about possibility of an error escaping the scope of 'runError'
43-- when misused with 'AsyncE'.
44runError
45 :: forall e es a. Typeable e
46 => Eff (Error e : es) a
47 -> Eff es (Either (CallStack, e) a)
48runError m = unsafeEff $ \es0 -> mask $ \release -> do
49 -- A unique tag is picked so that different runError handlers for the same
50 -- type don't catch each other's exceptions.
51 tag <- newUnique
52 size0 <- sizeEnv es0
53 es <- unsafeConsEnv (IdE (Error @e tag)) noRelinker es0
54 r <- tryErrorIO tag (release $ unEff m es) `onException` unsafeTailEnv size0 es
55 _ <- unsafeTailEnv size0 es
56 pure r
58throwError
59 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
60 => e
61 -> Eff es a
62throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
63 throwIO $ ErrorEx tag callStack e
65catchError
66 :: forall e es a. (Typeable e, Error e :> es)
67 => Eff es a
68 -> (CallStack -> e -> Eff es a)
69 -> Eff es a
70catchError m handler = do
71 readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do
72 size <- sizeEnv es
73 catchErrorIO tag (unEff m es) $ \cs e -> do
74 checkSizeEnv size es
75 unEff (handler cs e) es
77tryError
78 :: forall e es a. (Typeable e, Error e :> es)
79 => Eff es a
80 -> Eff es (Either (CallStack, e) a)
81tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
83----------------------------------------
84-- Helpers
86data ErrorEx e = ErrorEx Unique CallStack e
87instance Typeable e => Show (ErrorEx e) where
88 showsPrec p (ErrorEx _ cs e)
89 = ("Effectful.Error.ErrorEx (" ++)
90 . showsPrec p (typeOf e)
91 . (") " ++)
92 . showsPrec p cs
93instance Typeable e => Exception (ErrorEx e)
95catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a
96catchErrorIO tag m handler = do
97 m `catch` \err@(ErrorEx etag e cs) -> do
98 if tag == etag
99 then handler e cs
100 else throwIO err
102tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either (CallStack, e) a)
103tryErrorIO tag m = catchErrorIO tag (Right <$> m) $ \es e -> pure $ Left (es, e)