git.iko.soy/effectful
on master help sign in
Pass CallStack to error handlers (#7)
commit2681dce52f7d940fe9eaa725eb379aea64887278 authorMann mit Hut <mmhat@users.noreply.github.com> dateSat 26 Jun 2021, 00:06 (5 years ago) parent3f36be7
4 files changed+9−27
compare with master
unifiedsplit
effectful.cabal−1 src/Effectful/Error.hs+7−8 src/Effectful/Internal/Utils.hs−16 tests/Main.hs+2−2
effectful.cabal−1
@@ -74,7 +74,6 @@ library
7474 Effectful.Internal.Effect
7575 Effectful.Internal.Env
7676 Effectful.Internal.Monad
77− Effectful.Internal.Utils
7877 Effectful.Interpreter
7978 Effectful.Monad
8079 Effectful.Reader
src/Effectful/Error.hs+7−8
@@ -18,7 +18,6 @@ import GHC.Stack
1818import Effectful.Internal.Effect
1919import Effectful.Internal.Env
2020import Effectful.Internal.Monad
21−import Effectful.Internal.Utils
2221
2322data Error e :: Effect where
2423 Error :: Unique -> Error e m r
@@ -28,7 +27,7 @@ data Error e :: Effect where
2827runError
2928 :: forall e es a. Typeable e
3029 => Eff (Error e : es) a
31− -> Eff es (Either ([String], e) a)
30+ -> Eff es (Either (CallStack, e) a)
3231runError (Eff m) = unsafeEff $ \es0 -> mask $ \release -> do
3332 -- A unique tag is picked so that different runError handlers for the same
3433 -- type don't catch each other's exceptions.
@@ -44,12 +43,12 @@ throwError
4443 => e
4544 -> Eff es a
4645throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do
47− throwIO $ WrapErr tag (ppCallStack <$> getCallStack callStack) e
46+ throwIO $ WrapErr tag callStack e
4847
4948catchError
5049 :: forall e es a. (Typeable e, Error e :> es)
5150 => Eff es a
52− -> ([String] -> e -> Eff es a)
51+ -> (CallStack -> e -> Eff es a)
5352 -> Eff es a
5453catchError (Eff m) handler = do
5554 readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do
@@ -61,13 +60,13 @@ catchError (Eff m) handler = do
6160tryError
6261 :: forall e es a. (Typeable e, Error e :> es)
6362 => Eff es a
64− -> Eff es (Either ([String], e) a)
63+ -> Eff es (Either (CallStack, e) a)
6564tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
6665
6766----------------------------------------
6867-- Helpers
6968
70−data WrapErr e = WrapErr Unique [String] e
69+data WrapErr e = WrapErr Unique CallStack e
7170
7271instance Typeable e => Show (WrapErr e) where
7372 showsPrec p (WrapErr _ cs e)
@@ -77,12 +76,12 @@ instance Typeable e => Show (WrapErr e) where
7776 . showsPrec p cs
7877instance Typeable e => Exception (WrapErr e)
7978
80−catchErrorIO :: Typeable e => Unique -> IO a -> ([String] -> e -> IO a) -> IO a
79+catchErrorIO :: Typeable e => Unique -> IO a -> (CallStack -> e -> IO a) -> IO a
8180catchErrorIO tag m handler = do
8281 m `catch` \err@(WrapErr etag e cs) -> do
8382 if tag == etag
8483 then handler e cs
8584 else throwIO err
8685
87−tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either ([String], e) a)
86+tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either (CallStack, e) a)
8887tryErrorIO tag m = catchErrorIO tag (Right <$> m) $ \es e -> pure $ Left (es, e)
src/Effectful/Internal/Utils.hsdeleted−16
@@ -1,16 +0,0 @@
1−{-# OPTIONS_HADDOCK not-home #-}
2−-- | Miscellaneous functions.
3−--
4−-- This module is intended for internal use only, and may change without warning
5−-- in subsequent releases.
6−module Effectful.Internal.Utils
7− ( ppCallStack
8− ) where
9−
10−import GHC.Stack.Types
11−
12−-- | Pretty print a position from a 'CallStack'.
13−ppCallStack :: (String, SrcLoc) -> String
14−ppCallStack (fun, SrcLoc {..}) = fun ++ " at " ++ srcLocFile
15− ++ ":" ++ show srcLocStartLine ++ ":" ++ show srcLocStartCol
16− ++ " in " ++ srcLocPackage ++ ":" ++ srcLocModule
tests/Main.hs+2−2
@@ -1,11 +1,11 @@
11module Main (main) where
22
33import Control.Monad.IO.Class
4−import Data.List (isPrefixOf)
54import Test.Tasty
65import Test.Tasty.HUnit
76import qualified Control.Monad.Catch as E
87import qualified Control.Exception.Lifted as LE
8+import GHC.Stack (getCallStack)
99import qualified UnliftIO.Exception as UE
1010
1111import Effectful.Async
@@ -127,7 +127,7 @@ test_errorFromInterpret = runIOE $ do
127127 runError @String nestedErr
128128 liftIO $ case result of
129129 Left (cs, _) -> assertBool "stack trace points to the correct action" $
130− "nestedErr" `isPrefixOf` last cs
130+ "nestedErr" == fst (last $ getCallStack cs)
131131 Right _ -> assertFailure "error caught by the wrong (inner) handler"
132132
133133----------------------------------------