diff --git a/error-context.cabal b/error-context.cabal --- a/error-context.cabal +++ b/error-context.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 73e6d19a6c9cb2896dc6e9b9b7465b7a556008ed26855c87123649feea1d426b +-- hash: 369905ea93b6cf094576c09b64bd7e22102e1f70d9b188d9386b7b6171d00077 name: error-context -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Provides API for enriching errors with contexts description: Please see the README on Github at category: Control, Error Handling @@ -33,7 +33,6 @@ ghc-options: -Wall build-depends: base >=4.7 && <5 - , either , exceptions , monad-logger , mtl @@ -55,7 +54,6 @@ ghc-options: -Wall -g -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , either , error-context , exceptions , monad-logger diff --git a/src/Control/Error/Context.hs b/src/Control/Error/Context.hs --- a/src/Control/Error/Context.hs +++ b/src/Control/Error/Context.hs @@ -31,16 +31,16 @@ , errorWithContextDump , catchWithoutContext , catchWithContext - , tryWithContext - , tryAnyWithContext - , catchJustWithContext , catchAnyWithContext , ensureExceptionContext - ) - where + , tryAnyWithContext + , tryAnyWithoutContext + , tryWithContext + , tryWithoutContext + ) where import Control.Exception.Safe (SomeException (..), catchAny, - catchJust, try, tryAny) + catchJust) import Control.Monad.Catch (Exception (..), MonadCatch (..), MonadThrow, throwM) import Control.Monad.IO.Unlift @@ -48,7 +48,6 @@ import Control.Monad.State import Control.Monad.Trans.Resource import Control.Monad.Writer -import Data.Either.Combinators (mapLeft) import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable @@ -171,41 +170,53 @@ catchWithoutContext m handler = catchJust pre m handler where pre :: SomeException -> Maybe e pre someExn = - -- First we check if the exception is of the type 'e' - -- (without context). If so, provide it to the handler - -- directly. - case fromException someExn :: Maybe e of - Just exn -> - Just exn + -- First we check if the exception is of the type + -- 'ErrorWithContext e'. In this case we forget the context + -- and provide the exception without context to the handler. + case fromException someExn :: Maybe (ErrorWithContext SomeException) of + Just (ErrorWithContext _ctx someExnWithoutContext) -> + case fromException someExnWithoutContext :: Maybe e of + Just exn -> + Just exn + Nothing -> + Nothing Nothing -> - -- Then we check if the exception is of the type - -- 'ErrorWithContext e'. In this case we forget the - -- context and provide the exception without context to - -- the handler. - case fromException someExn :: Maybe (ErrorWithContext SomeException) of - Just (ErrorWithContext _ctx someExnWithoutContext) -> - case fromException someExnWithoutContext :: Maybe e of - Just exn -> - Just exn - Nothing -> - Nothing + -- Then we check if the exception is of type 'e'. If so, + -- provide it to the handler directly. + case fromException someExn :: Maybe e of + Just exn -> + Just exn Nothing -> Nothing tryAnyWithContext - :: (MonadErrorContext m, MonadCatch m) + :: MonadCatch m => m a -> m (Either (ErrorWithContext SomeException) a) tryAnyWithContext m = - mapLeft (ErrorWithContext (ErrorContext [])) <$> tryAny m + catchWithContext (Right `liftM` m) (return . Left) +tryAnyWithoutContext + :: MonadCatch m + => m a + -> m (Either SomeException a) +tryAnyWithoutContext m = + catchWithoutContext (Right `liftM` m) (return . Left) + tryWithContext - :: (MonadErrorContext m, MonadCatch m, Exception e) + :: (MonadCatch m, Exception e) => m a -> m (Either (ErrorWithContext e) a) tryWithContext m = - mapLeft (ErrorWithContext (ErrorContext [])) <$> try m + catchWithContext (Right `liftM` m) (return . Left) +tryWithoutContext + :: (MonadCatch m, Exception e) + => m a + -> m (Either e a) +tryWithoutContext m = + catchWithoutContext (Right `liftM` m) (return . Left) + -- | Implement 'MonadResource' for 'ErrorContextT'. instance (MonadCatch m, MonadResource m) => MonadResource (ErrorContextT m) where liftResourceT = lift . liftResourceT @@ -255,15 +266,6 @@ :: ErrorWithContext e -> e errorContextForget (ErrorWithContext _ctx e) = e - -catchJustWithContext - :: (MonadCatch m, Exception e) - => (e -> Maybe b) - -> m a - -> (b -> m a) - -> m a -catchJustWithContext f a b = - a `catch` \ exn -> maybe (throwM exn) b $ f exn -- | Context aware version of 'catchAny'. catchAnyWithContext diff --git a/test/Control/Error/Context/Test.hs b/test/Control/Error/Context/Test.hs --- a/test/Control/Error/Context/Test.hs +++ b/test/Control/Error/Context/Test.hs @@ -18,14 +18,13 @@ tests = testGroup "Tests" - [ testCase "Contextualize IO Exception" + [ + testCase "Contextualize IO Exception" testContextualizeIOException , testCase "throwM" testThrow , testCase "catchAnyWithContext" testCatchAnyWithContext - -- , testCase "catchJustWithContext" - -- testCatchJustWithContext , testCase "Catch context-enriched exception without context" testCatchWithoutContext , testCase "Contextualize error value" @@ -40,6 +39,18 @@ testNonContextualizedCatchWithContext , testCase "ensureExceptionContext" testEnsureExceptionContext + , testCase "catch head exception" + testCatchHeadException + , testCase "tryAnyWithoutContext" + testTryAnyWithoutContext + , testCase "tryAnyWithContext" + testTryAnyWithContext + , testCase "tryWithContext" + testTryWithContext + , testCase "tryWithoutContext" + testTryWithoutContext + , testCase "Throw and catch" + testThrowAndCatch ] data TestException = TestException deriving (Show, Eq) @@ -129,3 +140,46 @@ let Just (ErrorWithContext ctx someExnWithoutCtx) = fromException someExn Just TestException @=? fromException someExnWithoutCtx ErrorContext ["B", "A"] @=? ctx + +testCatchHeadException :: Assertion +testCatchHeadException = do + Left errWithCtx <- tryAnyWithContext . runErrorContextT $ do + withErrorContext "Here I am, calling head on an empty list!" $ + ensureExceptionContext $ seq (head []) (pure ()) + let (ErrorWithContext _ctx _exnWithoutCtx) = errWithCtx + putStrLn . displayException $ errWithCtx + +testTryAnyWithContext :: Assertion +testTryAnyWithContext = do + Left (ErrorWithContext _ctx someExn) <- tryAnyWithContext . runErrorContextT $ do + void $ throwM TestException + pure () + Just TestException @=? fromException someExn + +testTryAnyWithoutContext :: Assertion +testTryAnyWithoutContext = do + Left someExn <- tryAnyWithoutContext . runErrorContextT $ do + void $ throwM TestException + pure () + Just TestException @=? fromException someExn + +testTryWithContext :: Assertion +testTryWithContext = do + Left (ErrorWithContext _ctx exn) <- tryWithContext . runErrorContextT $ do + void $ throwM TestException + pure () + TestException @=? exn + +testTryWithoutContext :: Assertion +testTryWithoutContext = do + Left exn <- tryWithoutContext . runErrorContextT $ do + void $ throwM TestException + pure () + TestException @=? exn + +-- testTryAnyWithoutContext :: Assertion +-- testTryAnyWithoutContext = do +-- Left someExn <- tryAnyWithoutContext . runErrorContextT $ do +-- void $ throwM TestException +-- pure () +-- Just TestException @=? fromException someExn