error-context (empty) → 0.1.0.0

raw patch · 8 files changed

+589/−0 lines, 8 filesdep +basedep +eitherdep +error-contextsetup-changed

Dependencies added: base, either, error-context, exceptions, monad-logger, mtl, resourcet, safe-exceptions, tasty, tasty-hunit, text, unliftio-core

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +50/−0
Setup.hs +2/−0
error-context.cabal +72/−0
src/Control/Error/Context.hs +291/−0
test/Control/Error/Context/Test.hs +131/−0
test/Spec.hs +10/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for error-context++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Moritz Clasmeier (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Moritz Schulte nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,50 @@+# !! This is experimental work-in-progress !!++Welcome to *error-context*! This is a library providing context-aware+error and exception handling for Haskell.++## What problem does *error-context* attempt to solve?++Good error handling is hard. Sometimes it happens that when+propagating errors some context is lost. Call traces sometimes help,+but the current solutions in Haskell-land for accessing call traces+are rather limited. Furthermore, sometimes call traces that at written+by and for humans are more convenient to read.++The *error-context* library allows you to easily attach call traces+('error contexts') to errors, in particular to exceptions. Special+catch-functions are provided for accessing these contexts.++## How to use it?++Add an `ErrorContextT` layer to your monad transformer stack by adding+`runErrorContextT` to the transformer unwrapping code.++The `ErrorContextT` transformer provides the context-enriching logic+via special implementations of `MonadThrow`, `MonadCatch` and+`MonadIO`.++## Examples++See https://github.com/mtesseract/error-context/blob/master/test/Control/Error/Context/Test.hs.++## What about "pure" exceptions?++The `ErrorContextT` transformer implements `MonadThrow` and `MonadIO`,+therefore exceptions thrown by `throwM` and via `liftIO` are+automatically context-enriched. But the story for exceptional values+created via++```haskell+throw :: Exception e => e -> a+```++are not context-enriched. But there is a workaround for this use-case:++```haskell+ensureExceptionContext :: (MonadCatch m, MonadErrorContext m) => m a -> m a+```++This function provides context-aware enriching for any exceptions+thrown within some monadic value, including those thrown by evaluating+values created by `throw`.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ error-context.cabal view

@@ -0,0 +1,72 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 73e6d19a6c9cb2896dc6e9b9b7465b7a556008ed26855c87123649feea1d426b++name:           error-context+version:        0.1.0.0+synopsis:       Provides API for enriching errors with contexts+description:    Please see the README on Github at <https://github.com/mtesseract/error-context#readme>+category:       Control, Error Handling+homepage:       https://github.com/mtesseract/error-context#readme+bug-reports:    https://github.com/mtesseract/error-context/issues+author:         Moritz Clasmeier+maintainer:     mtesseract@silverratio.net+copyright:      (c) 2018 Moritz Clasmeier+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/mtesseract/error-context++library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , either+    , exceptions+    , monad-logger+    , mtl+    , resourcet+    , safe-exceptions+    , text+    , unliftio-core+  exposed-modules:+      Control.Error.Context+  other-modules:+      Paths_error_context+  default-language: Haskell2010++test-suite error-context-tests+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -Wall -g -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , either+    , error-context+    , exceptions+    , monad-logger+    , mtl+    , resourcet+    , safe-exceptions+    , tasty+    , tasty-hunit+    , text+    , unliftio-core+  other-modules:+      Control.Error.Context.Test+      Paths_error_context+  default-language: Haskell2010

+ src/Control/Error/Context.hs view

@@ -0,0 +1,291 @@+{-|+Module      : Control.Error.Context+Description : API for enriching errors with contexts+Copyright   : (c) Moritz Clasmeier 2018+License     : BSD3+Maintainer  : mtesseract@silverratio.net+Stability   : experimental+Portability : POSIX++Provides an API for enriching errors with contexts.+-}++{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE UndecidableInstances       #-}++module Control.Error.Context+  ( ErrorContext(..)+  , ErrorContextT+  , MonadErrorContext(..)+  , ErrorWithContext(..)+  , runErrorContextT+  , errorContextualize+  , errorContextForget+  , errorWithContextDump+  , catchWithoutContext+  , catchWithContext+  , tryWithContext+  , tryAnyWithContext+  , catchJustWithContext+  , catchAnyWithContext+  , ensureExceptionContext+  )+  where++import           Control.Exception.Safe       (SomeException (..), catchAny,+                                               catchJust, try, tryAny)+import           Control.Monad.Catch          (Exception (..), MonadCatch (..),+                                               MonadThrow, throwM)+import           Control.Monad.IO.Unlift+import           Control.Monad.Reader+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++-- | Monad type class providing contextualized errors.+class (Monad m, MonadThrow m) => MonadErrorContext m where+  errorContextCollect :: m ErrorContext     -- ^ Return the current error context.+  withErrorContext    :: Text -> m a -> m a -- ^ Execute a monadic action while having the+                                            -- provided 'Text' being pushed to the error context.++-- | Data type implementing 'MonadErrorContext'.+newtype ErrorContextT m a =+  ErrorContextT { _runErrorContextT :: ReaderT ErrorContext m a+                } deriving ( Functor+                           , Applicative+                           , Monad+                           , MonadTrans+                           , MonadState s+                           , MonadWriter w )++-- | Boundles an error with an 'ErrorContext'.+data ErrorWithContext e =+  ErrorWithContext ErrorContext e+  deriving (Show)++instance Functor ErrorWithContext where+  fmap f (ErrorWithContext ctx e) = ErrorWithContext ctx (f e)++-- | An @ErrorWithContext e@ can be used as an exception.+instance Exception e => Exception (ErrorWithContext e) where+  toException exn = SomeException exn+  fromException (SomeException someExn) =+    case cast someExn :: Maybe (ErrorWithContext e) of+      Just (exnWithCtx @ (ErrorWithContext _ctx _exn)) ->+        Just exnWithCtx+      Nothing ->+        Nothing+  displayException (ErrorWithContext ctx exn) = do+    "Exception: " <> displayException exn <> "\n" <> errorContextAsString ctx++-- | Unwrap an 'ErrorContextT'. Exceptions of type @e@ thrown in the+-- provided action via 'throwM' will cause an @'ErrorWithContext' e@+-- exception to be propagated upwards.+runErrorContextT+  :: ErrorContextT m a+  -> m a+runErrorContextT ctx =+  runReaderT (_runErrorContextT ctx) (ErrorContext [])++instance (MonadCatch m, MonadIO m) => MonadIO (ErrorContextT m) where+  liftIO m = do+    ctx <- errorContextCollect+    lift $ errorContextualizeIO ctx m++    where errorContextualizeIO ctx io = liftIO $+            catchAny io $ \ (SomeException exn) -> throwM (ErrorWithContext ctx exn)++-- | Implement 'MonadErrorContext' for 'ErrorContextT'.+instance MonadThrow m => MonadErrorContext (ErrorContextT m) where+  errorContextCollect = ErrorContextT ask+  withErrorContext layer (ErrorContextT m) =+    ErrorContextT (local (errorContextPush layer) m)++-- | Implement 'MonadThrow' for 'ErrorContextT'.+instance MonadThrow m => MonadThrow (ErrorContextT m) where+  throwM e = do+    case fromException (toException e) :: Maybe (ErrorWithContext SomeException) of+      Just exnWithCtx ->+        lift $ throwM exnWithCtx+      Nothing -> do+        ctx <- errorContextCollect+        lift $ throwM (ErrorWithContext ctx (SomeException e))++-- | Implement 'MonadCatch' for 'ErrorContextT'.+instance MonadCatch m => MonadCatch (ErrorContextT m) where+  catch (ErrorContextT (ReaderT m)) c =+    ErrorContextT . ReaderT $+    \ r -> m r `catchWithoutContext` \ exn -> runReaderT (_runErrorContextT (c exn)) r++-- | Like 'catch', but the handler is required to be context-aware. Is+-- also able to catch exceptions of type 'e' (without context).+catchWithContext+  :: (MonadCatch m, Exception e) -- , MonadErrorContext m)+  => m a+  -> (ErrorWithContext e -> m a)+  -> m a+catchWithContext m handler = catchJust pre m handler+  where pre :: Exception e => SomeException -> Maybe (ErrorWithContext e)+        pre someExn =+          -- First we check if the exception is of the type+          -- 'ErrorWithContext e'. If so, provide it to the handler+          -- directly.+          case fromException someExn of+            Just (ErrorWithContext ctx someExnWithoutCtx :: ErrorWithContext SomeException) ->+              case fromException someExnWithoutCtx of+                Just exn -> Just (ErrorWithContext ctx exn)+                Nothing  -> Nothing+            Nothing  ->+              -- Then we check if the exception is of the type 'e',+              -- (without context). In this case we convert it into an+              -- 'ErrorWithContext e' by adding an empty context and+              -- provide the wrapped exception with context to the+              -- handler.+              case fromException someExn of+                Just exn ->+                  Just (ErrorWithContext (ErrorContext []) exn)+                Nothing ->+                  Nothing++-- | Like 'catch', but the handler is required to be context-unaware.+-- Is also able to catch exceptions with context, in which case the+-- context will be forgotten before the exception will be provided to+-- the handler.+catchWithoutContext+  :: forall a e m+   . (MonadCatch m, Exception e) -- , MonadErrorContext m)+  => m a+  -> (e -> m a)+  -> m a+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+            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+                Nothing  ->+                  Nothing++tryAnyWithContext+  :: (MonadErrorContext m, MonadCatch m)+  => m a+  -> m (Either (ErrorWithContext SomeException) a)+tryAnyWithContext m =+  mapLeft (ErrorWithContext (ErrorContext [])) <$> tryAny m++tryWithContext+  :: (MonadErrorContext m, MonadCatch m, Exception e)+  => m a+  -> m (Either (ErrorWithContext e) a)+tryWithContext m =+  mapLeft (ErrorWithContext (ErrorContext [])) <$> try m++-- | Implement 'MonadResource' for 'ErrorContextT'.+instance (MonadCatch m, MonadResource m) => MonadResource (ErrorContextT m) where+  liftResourceT = lift . liftResourceT++-- | Implement 'MonadReader' for 'ErrorContextT'.+instance MonadReader r m => MonadReader r (ErrorContextT m) where+  ask = ErrorContextT (lift ask)+  local f (ErrorContextT (ReaderT m)) =+    ErrorContextT (ReaderT (\ errCtx -> local f (m errCtx)))++-- | Encapsulates the error context — essentially a stack of 'Text'+-- values.+data ErrorContext = ErrorContext [Text] deriving (Show, Eq)++-- | Push a context layer (a 'Text') onto the provided 'ErrorContext'.+errorContextPush+  :: Text+  -> ErrorContext+  -> ErrorContext+errorContextPush layer (ErrorContext layers) =+  ErrorContext (layer : layers)++errorContextAsString :: ErrorContext -> String+errorContextAsString (ErrorContext layers) =+  concat $ map (\ layer -> "  caused by: " <> Text.unpack layer <> "\n") layers++-- | Dump an error with context to stdout.+errorWithContextDump+  :: (Show e, MonadIO m)+  => ErrorWithContext e+  -> m ()+errorWithContextDump (ErrorWithContext ctx err) = do+  liftIO . putStrLn $ "Error: " <> show err+  liftIO . putStrLn . errorContextAsString $ ctx++-- | Enrich an error value with an error context.+errorContextualize+  :: MonadErrorContext m+  => e+  -> m (ErrorWithContext e)+errorContextualize e = do+  ctx <- errorContextCollect+  pure $ ErrorWithContext ctx e++-- | Forgets the context from an enriched error.+errorContextForget+  :: 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+  :: MonadCatch m+  => m a+  -> (ErrorWithContext SomeException -> m a)+  -> m a+catchAnyWithContext m handler = catchJust pre m handler+  where pre :: SomeException -> Maybe (ErrorWithContext SomeException)+        pre someExn =+          case fromException someExn :: Maybe (ErrorWithContext SomeException) of+            Just exn ->+              Just exn+            Nothing ->+              Just (ErrorWithContext (ErrorContext []) someExn)++ensureExceptionContext :: (MonadCatch m, MonadErrorContext m) => m a -> m a+ensureExceptionContext m =+  catchAny m $ \ someExn ->+  case fromException someExn :: Maybe (ErrorWithContext SomeException) of+    Just exnWithCtx ->+      throwM exnWithCtx+    Nothing -> do+      ctx <- errorContextCollect+      throwM $ ErrorWithContext ctx someExn

+ test/Control/Error/Context/Test.hs view

@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}++module Control.Error.Context.Test (tests) where++import           Control.Error.Context+import           Control.Exception      (Exception (..), throw, throwIO)+import           Control.Monad+import           Control.Monad.Catch    (catch, throwM, try)+import           Control.Monad.IO.Class+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests =+  testGroup+    "Tests"+    [ 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"+        testContextualizeErrorValue+    , testCase "Forgetting error context"+        testForgetErrorContext+    , testCase "Dumping error context"+        testDumpErrorContext+    , testCase "Throw and catch"+        testThrowAndCatch+    , testCase "Catch non-contextualized exception with context"+        testNonContextualizedCatchWithContext+    , testCase "ensureExceptionContext"+        testEnsureExceptionContext+    ]++data TestException = TestException deriving (Show, Eq)++instance Exception TestException++testContextualizeIOException :: Assertion+testContextualizeIOException = do+  Left (ErrorWithContext (ErrorContext ctx) TestException) <- try . runErrorContextT $+    withErrorContext "A" $+    withErrorContext "B" $+    liftIO failingIOException+  ["B", "A"] @=? ctx++  where failingIOException :: IO ()+        failingIOException =+          throwIO TestException++testCatchWithoutContext :: Assertion+testCatchWithoutContext = do+  TestException <- runErrorContextT $+    withErrorContext "A" $+    withErrorContext "B" $+    catchWithoutContext (throwM TestException) $ \ (exn :: TestException) -> do+      pure exn+  pure ()++testContextualizeErrorValue :: Assertion+testContextualizeErrorValue = do+  ErrorWithContext (ErrorContext ctx) TestException <- runErrorContextT $+    withErrorContext "A" $+    withErrorContext "B" $+    errorContextualize TestException+  ["B", "A"] @=? ctx++testForgetErrorContext :: Assertion+testForgetErrorContext = do+  errWithCtx @ (ErrorWithContext _ctx TestException) <- runErrorContextT $+    withErrorContext "A" $+    withErrorContext "B" $+    errorContextualize TestException+  TestException @=? errorContextForget errWithCtx++testDumpErrorContext :: Assertion+testDumpErrorContext = do+  errWithCtx @ (ErrorWithContext _ctx _exn) <- runErrorContextT $+    withErrorContext "A" $+    withErrorContext "B" $+    errorContextualize TestException+  errorWithContextDump errWithCtx++testThrowAndCatch :: Assertion+testThrowAndCatch = do+  void . runErrorContextT $+    catch (throwM TestException) $ \ TestException -> pure ()++testThrow :: Assertion+testThrow = do+  catch (runErrorContextT (throwM TestException)) $ \ someExn -> do+    let Just (ErrorWithContext _ctx someInnerExn) = fromException someExn+    liftIO $ Just TestException @=? fromException someInnerExn++testCatchAnyWithContext :: Assertion+testCatchAnyWithContext = do+  catchAnyWithContext (runErrorContextT (throwM TestException)) $+    \ (ErrorWithContext _ctx someExn) -> do+      Just TestException @=? fromException someExn++testNonContextualizedCatchWithContext :: Assertion+testNonContextualizedCatchWithContext = do+  ErrorWithContext (ErrorContext ctx) TestException <- runErrorContextT $+    withErrorContext "A" $+    withErrorContext "B" $ do+    catchWithContext throwPureException $ \ (exn :: ErrorWithContext TestException) -> do+      pure exn+  [] @=? ctx++  where throwPureException = throw TestException++testEnsureExceptionContext :: Assertion+testEnsureExceptionContext = do+  Left someExn <- try . runErrorContextT $+    withErrorContext "A" $+    withErrorContext "B" $ do+    ensureExceptionContext $ do+      throw TestException+  let Just (ErrorWithContext ctx someExnWithoutCtx) = fromException someExn+  Just TestException @=? fromException someExnWithoutCtx+  ErrorContext ["B", "A"] @=? ctx

+ test/Spec.hs view

@@ -0,0 +1,10 @@+import qualified Control.Error.Context.Test+import           Test.Tasty+++main :: IO ()+main = do+  defaultMain $+    testGroup "Test Suite"+    [ Control.Error.Context.Test.tests+    ]