2681dce · effectful · git.iko.soy

git.iko.soy/effectful

on master help sign in

Pass CallStack to error handlers (#7)

2681dceMann mit Hut5 years ago

effectful.cabal−1

compare with master

unifiedsplit

@@ -74,7 +74,6 @@ library

74 Effectful.Internal.Effect

75 Effectful.Internal.Env

76 Effectful.Internal.Monad

77− Effectful.Internal.Utils

78 Effectful.Interpreter

77 Effectful.Interpreter

79 Effectful.Monad

78 Effectful.Monad

80 Effectful.Reader

79 Effectful.Reader

src/Effectful/Error.hs+7−8

@@ -18,7 +18,6 @@ import GHC.Stack

18import Effectful.Internal.Effect

19import Effectful.Internal.Env

20import Effectful.Internal.Monad

21−import Effectful.Internal.Utils

23data Error e :: Effect where

22data Error e :: Effect where

24 Error :: Unique -> Error e m r

23 Error :: Unique -> Error e m r

@@ -28,7 +27,7 @@ data Error e :: Effect where

28runError

27runError

29 :: forall e es a. Typeable e

28 :: forall e es a. Typeable e

30 => Eff (Error e : es) a

29 => Eff (Error e : es) a

31− -> Eff es (Either ([String], e) a)

30+ -> Eff es (Either (CallStack, e) a)

32runError (Eff m) = unsafeEff $ \es0 -> mask $ \release -> do

31runError (Eff m) = unsafeEff $ \es0 -> mask $ \release -> do

33 -- A unique tag is picked so that different runError handlers for the same

32 -- A unique tag is picked so that different runError handlers for the same

34 -- type don't catch each other's exceptions.

33 -- type don't catch each other's exceptions.

@@ -44,12 +43,12 @@ throwError

44 => e

43 => e

45 -> Eff es a

44 -> Eff es a

46throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do

45throwError e = readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff_ $ do

47− throwIO $ WrapErr tag (ppCallStack <$> getCallStack callStack) e

46+ throwIO $ WrapErr tag callStack e

49catchError

48catchError

50 :: forall e es a. (Typeable e, Error e :> es)

49 :: forall e es a. (Typeable e, Error e :> es)

51 => Eff es a

50 => Eff es a

52− -> ([String] -> e -> Eff es a)

51+ -> (CallStack -> e -> Eff es a)

53 -> Eff es a

52 -> Eff es a

54catchError (Eff m) handler = do

53catchError (Eff m) handler = do

55 readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do

54 readerEffectM @(Error e) $ \(IdE (Error tag)) -> unsafeEff $ \es -> do

@@ -61,13 +60,13 @@ catchError (Eff m) handler = do

61tryError

60tryError

62 :: forall e es a. (Typeable e, Error e :> es)

61 :: forall e es a. (Typeable e, Error e :> es)

63 => Eff es a

62 => Eff es a

64− -> Eff es (Either ([String], e) a)

63+ -> Eff es (Either (CallStack, e) a)

65tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)

64tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)

67----------------------------------------

66----------------------------------------

68-- Helpers

67-- Helpers

70−data WrapErr e = WrapErr Unique [String] e

69+data WrapErr e = WrapErr Unique CallStack e

72instance Typeable e => Show (WrapErr e) where

71instance Typeable e => Show (WrapErr e) where

73 showsPrec p (WrapErr _ cs e)

72 showsPrec p (WrapErr _ cs e)

@@ -77,12 +76,12 @@ instance Typeable e => Show (WrapErr e) where

77 . showsPrec p cs

76 . showsPrec p cs

78instance Typeable e => Exception (WrapErr e)

77instance Typeable e => Exception (WrapErr e)

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

81catchErrorIO tag m handler = do

80catchErrorIO tag m handler = do

82 m `catch` \err@(WrapErr etag e cs) -> do

81 m `catch` \err@(WrapErr etag e cs) -> do

83 if tag == etag

82 if tag == etag

84 then handler e cs

83 then handler e cs

85 else throwIO err

84 else throwIO err

87−tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either ([String], e) a)

86+tryErrorIO :: Typeable e => Unique -> IO a -> IO (Either (CallStack, e) a)

88tryErrorIO tag m = catchErrorIO tag (Right <$> m) $ \es e -> pure $ Left (es, e)

87tryErrorIO 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 @@

1module Main (main) where

3import Control.Monad.IO.Class

4−import Data.List (isPrefixOf)

5import Test.Tasty

4import Test.Tasty

6import Test.Tasty.HUnit

5import Test.Tasty.HUnit

7import qualified Control.Monad.Catch as E

6import qualified Control.Monad.Catch as E

8import qualified Control.Exception.Lifted as LE

7import qualified Control.Exception.Lifted as LE

8+import GHC.Stack (getCallStack)

9import qualified UnliftIO.Exception as UE

11import Effectful.Async

@@ -127,7 +127,7 @@ test_errorFromInterpret = runIOE $ do

127 runError @String nestedErr

128 liftIO $ case result of

129 Left (cs, _) -> assertBool "stack trace points to the correct action" $

130− "nestedErr" `isPrefixOf` last cs

130+ "nestedErr" == fst (last $ getCallStack cs)

131 Right _ -> assertFailure "error caught by the wrong (inner) handler"

132

133----------------------------------------