git.iko.soy/effectful
on 01bdb2a help sign in
effectful/src/Effectful/Error.hs
88 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
21import Effectful.Internal.Utils
23data Error e :: Effect where
24 Error :: Unique -> Error e m r
26-- | TODO: write about possibility of an error escaping the scope of 'runError'
27-- when misused with 'AsyncE'.
28runError
29 :: forall e es a. Typeable e
30 => Eff (Error e : es) a
31 -> Eff es (Either ([String], e) a)
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
36 size0 <- sizeEnv es0
37 es <- unsafeConsEnv (IdE (Error @e tag)) noRelinker es0
38 r <- tryErrorIO tag (release $ m es) `onException` unsafeTailEnv size0 es
39 _ <- unsafeTailEnv size0 es
40 pure r
42throwError
43 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
44 => e
45 -> Eff es a
46throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
47 throwIO $ WrapErr tag (ppCallStack <$> getCallStack callStack) e
49catchError
50 :: forall e es a. (Typeable e, Error e :> es)
51 => Eff es a
52 -> ([String] -> e -> Eff es a)
53 -> Eff es a
54catchError (Eff m) handler = do
55 readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do
56 size <- sizeEnv es
57 catchErrorIO tag (m es) $ \cs e -> do
58 checkSizeEnv size es
59 unEff (handler cs e) es
61tryError
62 :: forall e es a. (Typeable e, Error e :> es)
63 => Eff es a
64 -> Eff es (Either ([String], e) a)
65tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
67----------------------------------------
68-- Helpers
70data WrapErr e = WrapErr Unique [String] e
72instance Typeable e => Show (WrapErr e) where
73 showsPrec p (WrapErr _ cs e)
74 = showsPrec p "Effectful.Error.WrapErr ("
75 . showsPrec p (typeOf e)
76 . showsPrec p ") "
77 . showsPrec p cs
78instance Typeable e => Exception (WrapErr e)
80catchErrorIO :: Typeable e => Unique -> IO a -> ([String] -> e -> IO a) -> IO a
81catchErrorIO 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
87tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either ([String], e) a)
88tryErrorIO tag m = catchErrorIO tag (Right <$> m) $ \es e -> pure $ Left (es, e)