git.iko.soy/effectful
on 2681dce help sign in
effectful/src/Effectful/Error.hs
87 lines 2.5 kB history raw
1-- | Support for checked exceptions.
2module Effectful.Error
3 ( Error
4 , runError
5 , throwError
6 , catchError
7 , tryError
9 -- * Re-exports
10 , Exception
11 ) where
13import Control.Exception
14import Data.Typeable
15import Data.Unique
16import GHC.Stack
18import Effectful.Internal.Effect
19import Effectful.Internal.Env
20import Effectful.Internal.Monad
22data Error e :: Effect where
23 Error :: Unique -> Error e m r
25-- | TODO: write about possibility of an error escaping the scope of 'runError'
26-- when misused with 'AsyncE'.
27runError
28 :: forall e es a. Typeable e
29 => Eff (Error e : es) a
30 -> Eff es (Either (CallStack, e) a)
31runError (Eff m) = unsafeEff $ \es0 -> mask $ \release -> do
32 -- A unique tag is picked so that different runError handlers for the same
33 -- type don't catch each other's exceptions.
34 tag <- newUnique
35 size0 <- sizeEnv es0
36 es <- unsafeConsEnv (IdE (Error @e tag)) noRelinker es0
37 r <- tryErrorIO tag (release $ m es) `onException` unsafeTailEnv size0 es
38 _ <- unsafeTailEnv size0 es
39 pure r
41throwError
42 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
43 => e
44 -> Eff es a
45throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
46 throwIO $ WrapErr tag callStack e
48catchError
49 :: forall e es a. (Typeable e, Error e :> es)
50 => Eff es a
51 -> (CallStack -> e -> Eff es a)
52 -> Eff es a
53catchError (Eff m) handler = do
54 readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do
55 size <- sizeEnv es
56 catchErrorIO tag (m es) $ \cs e -> do
57 checkSizeEnv size es
58 unEff (handler cs e) es
60tryError
61 :: forall e es a. (Typeable e, Error e :> es)
62 => Eff es a
63 -> Eff es (Either (CallStack, e) a)
64tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
66----------------------------------------
67-- Helpers
69data WrapErr e = WrapErr Unique CallStack e
71instance Typeable e => Show (WrapErr e) where
72 showsPrec p (WrapErr _ cs e)
73 = showsPrec p "Effectful.Error.WrapErr ("
74 . showsPrec p (typeOf e)
75 . showsPrec p ") "
76 . showsPrec p cs
77instance Typeable e => Exception (WrapErr e)
79catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a
80catchErrorIO tag m handler = do
81 m `catch` \err@(WrapErr etag e cs) -> do
82 if tag == etag
83 then handler e cs
84 else throwIO err
86tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either (CallStack, e) a)
87tryErrorIO tag m = catchErrorIO tag (Right <$> m) $ \es e -> pure $ Left (es, e)