error-context 0.1.2.0 → 0.2.0.0

raw patch · 9 files changed

+695/−369 lines, 9 filesdep +aesondep +bytestringdep +katipPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, bytestring, katip, unordered-containers

API changes (from Hackage documentation)

Files

• README.md +32/−2
• error-context.cabal +16/−4
• src/Control/Error/Context.hs +16/−239
• src/Control/Error/Context/Exception.hs +135/−0
• src/Control/Error/Context/Katip.hs +101/−0
• src/Control/Error/Context/Simple.hs +101/−0
• src/Control/Error/Context/Types.hs +102/−0
• test/Control/Error/Context/Test.hs +190/−124
• test/Spec.hs +2/−0

@@ -1,7 +1,14 @@+# error-context [![Hackage version](https://img.shields.io/hackage/v/error-context.svg?label=Hackage)](https://hackage.haskell.org/package/error-context) [![Stackage version](https://www.stackage.org/package/error-context/badge/lts?label=Stackage)](https://www.stackage.org/package/error-context) [![Build Status](https://travis-ci.org/mtesseract/error-context.svg?branch=master)](https://travis-ci.org/mtesseract/error-context)+ # !! This is experimental work-in-progress !!  Welcome to *error-context*! This is a library providing context-aware-error and exception handling for Haskell.+error and exception handling for Haskell. It has built-in support for+the [Katip logging+package](https://hackage.haskell.org/package/katip). This means that+in combination with Katip, *error-context* can transparently use the+context (key-value pairs and namespace hierarchy) maintained by+`KatipContext` monads.  ## What problem does *error-context* attempt to solve? @@ -26,7 +33,30 @@  ## Examples -See https://github.com/mtesseract/error-context/blob/master/test/Control/Error/Context/Test.hs.+Consider this IO action:++```haskell+testExample :: IO ()+testExample = do+  Left errWithCtx <- tryAnyWithContext . runErrorContextT $ do+    withErrorNamespace "middle-earth" $+      withErrorNamespace "mordor" $+      withErrorContext "ring-carrier" ("Frodo" :: Text) $ +      throwM TestException+  putStrLn . displayException $ errWithCtx+```++When run, it produces the following output:++```+Exception: TestException+           ring-carrier: "Frodo"+  caused by: middle-earth+  caused by: mordor+```++For more examples, see+https://github.com/mtesseract/error-context/blob/master/test/Control/Error/Context/Test.hs.  ## What about "pure" exceptions? 

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f55dae8d67d5460e15eb0ff2f407d2c336439b95b1e21c8573a1458bb40350fd+-- hash: 38188d7be27013ba6b735436e08a57a19e64d2e3cb1239df11b552e4c93bea50  name:           error-context-version:        0.1.2.0+version:        0.2.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@@ -32,16 +32,24 @@       src   ghc-options: -Wall   build-depends:-      base >=4.7 && <5+      aeson+    , base >=4.7 && <5+    , bytestring     , exceptions+    , katip     , monad-logger     , mtl     , resourcet     , safe-exceptions     , text     , unliftio-core+    , unordered-containers   exposed-modules:       Control.Error.Context+      Control.Error.Context.Exception+      Control.Error.Context.Katip+      Control.Error.Context.Simple+      Control.Error.Context.Types   other-modules:       Paths_error_context   default-language: Haskell2010@@ -53,9 +61,12 @@       test   ghc-options: -Wall -g -threaded -rtsopts -with-rtsopts=-N   build-depends:-      base >=4.7 && <5+      aeson+    , base >=4.7 && <5+    , bytestring     , error-context     , exceptions+    , katip     , monad-logger     , mtl     , resourcet@@ -64,6 +75,7 @@     , tasty-hunit     , text     , unliftio-core+    , unordered-containers   other-modules:       Control.Error.Context.Test       Paths_error_context

@@ -21,11 +21,12 @@ {-# LANGUAGE UndecidableInstances       #-}  module Control.Error.Context-  ( ErrorContext(..)+  ( MonadErrorContext(..)+  , ErrorContext(..)   , ErrorContextT-  , MonadErrorContext(..)-  , ErrorWithContext(..)   , runErrorContextT+  , ErrorContextKatipT(..)+  , ErrorWithContext(..)   , errorContextualize   , errorContextForget   , errorWithContextDump@@ -40,209 +41,18 @@   , tryWithoutContext   ) where -import           Control.Exception.Safe       (SomeException (..), catchAny,-                                               catchJust)-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.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-          -- '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 type 'e'. If so,-              -- provide it to the handler directly.-              case fromException someExn :: Maybe e of-                Just exn ->-                  Just exn-                Nothing  ->-                  Nothing--tryAnyWithContext-  :: MonadCatch m-  => m a-  -> m (Either (ErrorWithContext SomeException) a)-tryAnyWithContext 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-  :: (MonadCatch m, Exception e)-  => m a-  -> m (Either (ErrorWithContext e) a)-tryWithContext 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---- | 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)+import           Control.Error.Context.Katip+import           Control.Error.Context.Simple+import           Control.Error.Context.Types --- | Push a context layer (a 'Text') onto the provided 'ErrorContext'.-errorContextPush-  :: Text-  -> ErrorContext-  -> ErrorContext-errorContextPush layer (ErrorContext layers) =-  ErrorContext (layer : layers)+import           Control.Error.Context.Exception+import           Control.Exception.Safe          (SomeException (..), catchAny)+import           Control.Monad.Catch             (Exception (..),+                                                  MonadCatch (..), throwM)+import           Control.Monad.IO.Class+import           Data.Monoid -errorContextAsString :: ErrorContext -> String-errorContextAsString (ErrorContext layers) =-  concat $ map (\ layer -> "  caused by: " <> Text.unpack layer <> "\n") layers+--------------------------------------------------------------------------------  -- | Dump an error with context to stdout. errorWithContextDump@@ -262,43 +72,10 @@   ctx <- errorContextCollect   pure $ ErrorWithContext ctx e --- | Forgets the context from an enriched error.-errorContextForget-  :: ErrorWithContext e-  -> e-errorContextForget (ErrorWithContext _ctx e) = e---- | Context aware version of 'catchAny'.-catchAnyWithContext-  :: MonadCatch m+ensureExceptionContext+  :: (MonadCatch m, MonadErrorContext 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)---- | Context aware version of 'catchAny'.-catchAnyWithoutContext-  :: MonadCatch m-  => m a-  -> (SomeException -> m a)-  -> m a-catchAnyWithoutContext m handler = catchJust pre m handler-  where pre :: SomeException -> Maybe SomeException-        pre someExn =-          case fromException someExn :: Maybe (ErrorWithContext SomeException) of-            Just (ErrorWithContext _ctx exnWithoutContext) ->-              Just exnWithoutContext-            Nothing ->-              Just someExn--ensureExceptionContext :: (MonadCatch m, MonadErrorContext m) => m a -> m a ensureExceptionContext m =   catchAny m $ \ someExn ->   case fromException someExn :: Maybe (ErrorWithContext SomeException) of

@@ -0,0 +1,135 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Control.Error.Context.Exception where++import           Control.Error.Context.Types++import           Control.Exception.Safe      (SomeException (..), catchJust)+import           Control.Monad+import           Control.Monad.Catch         (Exception (..), MonadCatch (..))++-- | 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)+  => 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 mempty 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)+  => 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+          -- '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 type 'e'. If so,+              -- provide it to the handler directly.+              case fromException someExn :: Maybe e of+                Just exn ->+                  Just exn+                Nothing  ->+                  Nothing++tryAnyWithContext+  :: MonadCatch m+  => m a+  -> m (Either (ErrorWithContext SomeException) a)+tryAnyWithContext 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+  :: (MonadCatch m, Exception e)+  => m a+  -> m (Either (ErrorWithContext e) a)+tryWithContext 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)++-- | Forgets the context from an enriched error.+errorContextForget+  :: ErrorWithContext e+  -> e+errorContextForget (ErrorWithContext _ctx e) = e++-- | 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 mempty someExn)++-- | Context aware version of 'catchAny'.+catchAnyWithoutContext+  :: MonadCatch m+  => m a+  -> (SomeException -> m a)+  -> m a+catchAnyWithoutContext m handler = catchJust pre m handler+  where pre :: SomeException -> Maybe SomeException+        pre someExn =+          case fromException someExn :: Maybe (ErrorWithContext SomeException) of+            Just (ErrorWithContext _ctx exnWithoutContext) ->+              Just exnWithoutContext+            Nothing ->+              Just someExn

@@ -0,0 +1,101 @@+{-|+Module      : Control.Error.Context.Katip+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.Katip (ErrorContextKatipT(..)) where++import           Control.Error.Context.Exception+import           Control.Error.Context.Types+import           Control.Exception.Safe          (SomeException (..), catchAny)+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           Katip++-- | Data type implementing 'MonadErrorContext'.+newtype ErrorContextKatipT m a =+  ErrorContextKatipT { runErrorContextKatipT :: m a+                } deriving ( Functor+                           , Applicative+                           , Monad+                           -- , MonadTrans+                           , MonadState s+                           , MonadWriter w )++instance MonadTrans ErrorContextKatipT where+  lift = ErrorContextKatipT++instance (MonadCatch m, KatipContext m, MonadIO m, Katip m) => Katip (ErrorContextKatipT m) where+  getLogEnv = ErrorContextKatipT getLogEnv+  localLogEnv f (ErrorContextKatipT m) = ErrorContextKatipT (localLogEnv f m)++instance (MonadCatch m, KatipContext m) => KatipContext (ErrorContextKatipT m) where+  getKatipContext = ErrorContextKatipT getKatipContext+  localKatipContext f (ErrorContextKatipT m) = ErrorContextKatipT (localKatipContext f m)+  getKatipNamespace = ErrorContextKatipT getKatipNamespace+  localKatipNamespace f (ErrorContextKatipT m) = ErrorContextKatipT (localKatipNamespace f m)++instance (KatipContext m, MonadCatch m, MonadIO m) => MonadIO (ErrorContextKatipT m) where+  liftIO m = do+    context   <- toObject <$> lift getKatipContext+    namespace <- lift getKatipNamespace+    let ctx = ErrorContext context (unNamespace namespace)+    lift $ errorContextualizeIO ctx m++    where errorContextualizeIO ctx io = liftIO $+            catchAny io $ \ (SomeException exn) -> throwM (ErrorWithContext ctx exn)++instance (KatipContext m, MonadCatch m) => MonadThrow (ErrorContextKatipT 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))++instance (MonadCatch m, KatipContext m) => MonadErrorContext (ErrorContextKatipT m) where+  errorContextCollect = do+    context   <- toObject <$> lift getKatipContext+    namespace <- lift getKatipNamespace+    pure $ ErrorContext context (unNamespace namespace)+  withErrorNamespace label =+    katipAddNamespace (Namespace [label])+  withErrorContext label val =+    katipAddContext (sl label val)++instance (KatipContext m, MonadCatch m) => MonadCatch (ErrorContextKatipT m) where+  catch (ErrorContextKatipT m) c =+    ErrorContextKatipT $+    m `catchWithoutContext` \ exn -> runErrorContextKatipT (c exn)++instance (KatipContext m, MonadCatch m, MonadResource m) => MonadResource (ErrorContextKatipT m) where+  liftResourceT = liftResourceT++instance MonadReader r m => MonadReader r (ErrorContextKatipT m) where+  ask = ErrorContextKatipT ask+  local f (ErrorContextKatipT m) =+    ErrorContextKatipT (local f m)

@@ -0,0 +1,101 @@+{-|+Module      : Control.Error.Context.Simple+Description : API for enriching errors with contexts+Copyright   : (c) Moritz Clasmeier 2018+License     : BSD3+Maintainer  : mtesseract@silverratio.net+Stability   : experimental+Portability : POSIX+-}++{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE UndecidableInstances       #-}++module Control.Error.Context.Simple+  ( ErrorContextT(..)+  , runErrorContextT+  ) where++import           Control.Error.Context.Types+import           Data.Aeson++import           Control.Error.Context.Exception+import           Control.Exception.Safe          (SomeException (..), catchAny)+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 qualified Data.HashMap.Strict             as HashMap+import           Data.Text                       (Text)++-- | Data type implementing 'MonadErrorContext'.+newtype ErrorContextT m a =+  ErrorContextT { _runErrorContextT :: ReaderT ErrorContext m a+                } deriving ( Functor+                           , Applicative+                           , Monad+                           , MonadTrans+                           , MonadState s+                           , MonadWriter w )++runErrorContextT :: ErrorContextT m a -> m a+runErrorContextT =+  flip runReaderT mempty . _runErrorContextT++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)++instance (MonadCatch 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))++errorNamespacePush :: Text -> ErrorContext -> ErrorContext+errorNamespacePush label ctx =+  let currentNamespace = errorContextNamespace ctx+  in ctx { errorContextNamespace = currentNamespace ++ [label] }++errorContextAdd :: Text -> Value -> ErrorContext -> ErrorContext+errorContextAdd label val ctx =+  let currentKVs = errorContextKVs ctx+  in ctx { errorContextKVs = HashMap.insert label val currentKVs }++instance (MonadCatch m) => MonadErrorContext (ErrorContextT m) where+  errorContextCollect = ErrorContextT ask+  withErrorNamespace layer (ErrorContextT m) =+    ErrorContextT (local (errorNamespacePush layer) m)+  withErrorContext label val (ErrorContextT m) =+    ErrorContextT (local (errorContextAdd label (toJSON val)) m)++instance (MonadCatch m) => MonadCatch (ErrorContextT m) where+  catch (ErrorContextT m) c =+    ErrorContextT $+    m `catchWithoutContext` \ exn -> _runErrorContextT (c exn)++instance (MonadCatch m, MonadResource m) => MonadResource (ErrorContextT m) where+  liftResourceT = liftResourceT++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)))

@@ -0,0 +1,102 @@+{-|+Module      : Control.Error.Context.Types+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.Types+  ( ErrorContext(..)+  , ErrorWithContext(..)+  , errorContextAsString+  , MonadErrorContext(..)+  ) where++import           Control.Exception+import           Control.Monad.Catch  (MonadThrow)+import           Data.Aeson+import qualified Data.ByteString.Lazy as ByteString.Lazy+import           Data.Function        ((&))+import           Data.HashMap.Strict  (HashMap)+import qualified Data.HashMap.Strict  as HashMap+import           Data.Monoid+import           Data.Text            (Text)+import qualified Data.Text            as Text+import qualified Data.Text.Encoding   as Text+import           Data.Typeable++-- | Boundles an error with an 'ErrorContext'.+data ErrorWithContext e =+  ErrorWithContext ErrorContext e++instance Show e => Show (ErrorWithContext e) where+  show (ErrorWithContext _ctx e) = show e++instance Functor ErrorWithContext where+  fmap f (ErrorWithContext ctx e) = ErrorWithContext ctx (f e)++data ErrorContext =+  ErrorContext { errorContextKVs       :: HashMap Text Value+               , errorContextNamespace :: [Text] }++instance Monoid ErrorContext where+  mempty = ErrorContext mempty mempty+  (ErrorContext kvs namespace) `mappend` (ErrorContext kvs' namespace') =+    ErrorContext (kvs <> kvs') (namespace <> namespace')++-- | 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) =+    "Exception: " <> displayException exn <> "\n"+    <> errorContextAsString ctx++errorContextAsString :: ErrorContext -> String+errorContextAsString (ErrorContext hashmap layers) =+  concat $ prettyPrintKvs ++ prettyPrintCauses++  where prettyPrintKvs =+          hashmap+          & HashMap.toList+          & (map $ \ (label, val) ->+                     let labelS = label+                                  & Text.unpack+                         valS   = val+                                  & encode+                                  & ByteString.Lazy.toStrict+                                  & Text.decodeUtf8+                                  & Text.unpack+                     in "           " <> labelS <> ": " <> valS <> "\n")++        prettyPrintCauses =+          layers+          & (map $ \ layer ->+                     let layerS = Text.unpack layer+                     in "  caused by: " <> layerS <> "\n")++-- | Monad type class providing contextualized errors.+class (Monad m, MonadThrow m) => MonadErrorContext m where+  errorContextCollect :: m ErrorContext     -- ^ Return the current error context.+  withErrorContext :: ToJSON v => Text -> v -> m a -> m a+  withErrorNamespace :: Text -> m a -> m a

@@ -1,241 +1,307 @@ {-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell     #-}  module Control.Error.Context.Test (tests) where +import Data.Aeson import           Control.Error.Context-import           Control.Exception      (Exception (..), throw, throwIO)+import           Control.Exception           (Exception (..), throw, throwIO) import           Control.Monad-import           Control.Monad.Catch    (catch, throwM, try)+import           Control.Monad.Catch         (MonadCatch, catch, throwM, try) import           Control.Monad.IO.Class+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import           Data.Text                   (Text)+import           Katip import           Test.Tasty import           Test.Tasty.HUnit  tests :: TestTree-tests =-  testGroup-    "Tests"-    [-      testCase "Contextualize IO Exception"-        testContextualizeIOException+tests = testGroup "Tests" $+  [ testGroup "Simple (ErrorContextT)" (testsWithConf testConfSimple)+  , testGroup "Katip (ErrorContextKatipT)" (testsWithConf testConfKatip)+  , testGroup "Test Examples" testExamples+  ]++testExamples :: [TestTree]+testExamples = +  [ testCase "simpleExample" testExample ]++testsWithConf :: TestConf -> [TestTree]+testsWithConf conf =+    [ testCase "Contextualize IO Exception"+        (testContextualizeIOException conf)     , testCase "throwM"-        testThrow+        (testThrow conf)     , testCase "catchAnyWithContext"-        testCatchAnyWithContext+        (testCatchAnyWithContext conf)     , testCase "catchAnyWithContext/pure"-        testCatchAnyWithContextPure+        (testCatchAnyWithContextPure conf)     , testCase "catchAnyWithoutContext"-        testCatchAnyWithoutContext+        (testCatchAnyWithoutContext conf)     , testCase "catchAnyWithoutContext/pure"-        testCatchAnyWithoutContextPure+        (testCatchAnyWithoutContextPure conf)     , testCase "Catch context-enriched exception without context"-        testCatchWithoutContext+        (testCatchWithoutContext conf)     , testCase "Contextualize error value"-        testContextualizeErrorValue+        (testContextualizeErrorValue conf)     , testCase "Forgetting error context"-        testForgetErrorContext+        (testForgetErrorContext conf)     , testCase "Dumping error context"-        testDumpErrorContext+        (testDumpErrorContext conf)     , testCase "Throw and catch"-        testThrowAndCatch+        (testThrowAndCatch conf)     , testCase "Catch non-contextualized exception with context"-        testNonContextualizedCatchWithContext+        (testNonContextualizedCatchWithContext conf)     , testCase "ensureExceptionContext"-        testEnsureExceptionContext+        (testEnsureExceptionContext conf)     , testCase "catch head exception"-        testCatchHeadException+        (testCatchHeadException conf)     , testCase "tryAnyWithoutContext"-        testTryAnyWithoutContext+        (testTryAnyWithoutContext conf)     , testCase "tryAnyWithoutContext/pure"-        testTryAnyWithoutContextPure+        (testTryAnyWithoutContextPure conf)     , testCase "tryAnyWithContext"-        testTryAnyWithContext+        (testTryAnyWithContext conf)     , testCase "tryAnyWithContext/pure"-        testTryAnyWithContextPure+        (testTryAnyWithContextPure conf)     , testCase "tryWithContext"-        testTryWithContext+        (testTryWithContext conf)     , testCase "tryWithContext/pure"-        testTryWithContextPure+        (testTryWithContextPure conf)     , testCase "tryWithoutContext"-        testTryWithoutContext+        (testTryWithoutContext conf)     , testCase "tryWithoutContext/pure"-        testTryWithoutContextPure+        (testTryWithoutContextPure conf)     , testCase "Throw and catch"-        testThrowAndCatch+        (testThrowAndCatch conf)+    , testCase "contextKvRetrieval"+        (testContextKv conf)+    , testCase "contextKvOverwrite"+        (testContextKvOverwrite conf)     ]  data TestException = TestException deriving (Show, Eq)  instance Exception TestException -testContextualizeIOException :: Assertion-testContextualizeIOException = do-  Left (ErrorWithContext (ErrorContext ctx) TestException) <- try . runErrorContextT $-    withErrorContext "A" $-    withErrorContext "B" $+data TestConf where+  TestConf :: forall m. (MonadIO m, MonadCatch m, MonadErrorContext m) =>+              { runStackT         :: forall a. m a -> IO a }+           -> TestConf++testConfKatip :: TestConf+testConfKatip =+  TestConf { runStackT = \ m -> do+               logEnv <- liftIO $ initLogEnv "test-suite" "test"+               runKatipContextT logEnv () (Namespace []) $ runErrorContextKatipT m+           }++testConfSimple :: TestConf+testConfSimple =+  TestConf { runStackT = runErrorContextT }++extractKVs :: ErrorContext -> HashMap Text Value+extractKVs (ErrorContext kvs _namespace) =+  kvs++testContextualizeIOException :: TestConf -> Assertion+testContextualizeIOException TestConf { .. } = do+  Left (ErrorWithContext ctx TestException) <- try . runStackT $+    withErrorNamespace "A" $+    withErrorNamespace "B" $     liftIO failingIOException-  ["B", "A"] @=? ctx+  ["A", "B"] @=? errorContextNamespace ctx    where failingIOException :: IO ()         failingIOException =           throwIO TestException -testCatchWithoutContext :: Assertion-testCatchWithoutContext = do-  TestException <- runErrorContextT $-    withErrorContext "A" $-    withErrorContext "B" $+testThrow :: TestConf -> Assertion+testThrow TestConf { .. } = do+  catch (runStackT (throwM TestException)) $ \ someExn -> do+    let Just (ErrorWithContext _ctx someInnerExn) = fromException someExn+    liftIO $ Just TestException @=? fromException someInnerExn++testCatchWithoutContext :: TestConf -> Assertion+testCatchWithoutContext TestConf { .. } = do+  TestException <- runStackT $+    withErrorNamespace "A" $+    withErrorNamespace "B" $     catchWithoutContext (throwM TestException) $ \ (exn :: TestException) -> do       pure exn   pure () -testContextualizeErrorValue :: Assertion-testContextualizeErrorValue = do-  ErrorWithContext (ErrorContext ctx) TestException <- runErrorContextT $-    withErrorContext "A" $-    withErrorContext "B" $+testContextualizeErrorValue :: TestConf -> Assertion+testContextualizeErrorValue TestConf { .. } = do+  ErrorWithContext ctx TestException <- runStackT $+    withErrorNamespace "A" $+    withErrorNamespace "B" $     errorContextualize TestException-  ["B", "A"] @=? ctx+  ["A", "B"] @=? errorContextNamespace ctx -testForgetErrorContext :: Assertion-testForgetErrorContext = do-  errWithCtx @ (ErrorWithContext _ctx TestException) <- runErrorContextT $-    withErrorContext "A" $-    withErrorContext "B" $+testForgetErrorContext :: TestConf -> Assertion+testForgetErrorContext TestConf { .. } = do+  errWithCtx @ (ErrorWithContext _ctx TestException) <- runStackT $+    withErrorNamespace "A" $+    withErrorNamespace "B" $     errorContextualize TestException   TestException @=? errorContextForget errWithCtx -testDumpErrorContext :: Assertion-testDumpErrorContext = do-  errWithCtx @ (ErrorWithContext _ctx _exn) <- runErrorContextT $-    withErrorContext "A" $-    withErrorContext "B" $+testDumpErrorContext :: TestConf -> Assertion+testDumpErrorContext TestConf { .. } = do+  errWithCtx @ (ErrorWithContext _ctx _exn) <- runStackT $+    withErrorNamespace "A" $+    withErrorNamespace "B" $     errorContextualize TestException   errorWithContextDump errWithCtx -testThrowAndCatch :: Assertion-testThrowAndCatch = do-  void . runErrorContextT $+testThrowAndCatch :: TestConf -> Assertion+testThrowAndCatch TestConf { .. } = do+  void . runStackT $     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)) $+testCatchAnyWithContext :: TestConf -> Assertion+testCatchAnyWithContext TestConf { .. } = do+  catchAnyWithContext (runStackT (throwM TestException)) $     \ (ErrorWithContext _ctx someExn) -> do       Just TestException @=? fromException someExn -testCatchAnyWithContextPure :: Assertion-testCatchAnyWithContextPure = do-  catchAnyWithContext (runErrorContextT (throw TestException)) $+testCatchAnyWithContextPure :: TestConf -> Assertion+testCatchAnyWithContextPure TestConf { .. } = do+  catchAnyWithContext (runStackT (throw TestException)) $     \ (ErrorWithContext _ctx someExn) -> do       Just TestException @=? fromException someExn -testCatchAnyWithoutContext :: Assertion-testCatchAnyWithoutContext = do-  catchAnyWithoutContext (runErrorContextT (throwM TestException)) $+testCatchAnyWithoutContext :: TestConf -> Assertion+testCatchAnyWithoutContext TestConf { .. } = do+  catchAnyWithoutContext (runStackT (throwM TestException)) $     \ someExn -> do       Just TestException @=? fromException someExn -testCatchAnyWithoutContextPure :: Assertion-testCatchAnyWithoutContextPure = do-  catchAnyWithoutContext (runErrorContextT (throw TestException)) $+testCatchAnyWithoutContextPure :: TestConf -> Assertion+testCatchAnyWithoutContextPure TestConf { .. } = do+  catchAnyWithoutContext (runStackT (throw TestException)) $     \ someExn -> do       Just TestException @=? fromException someExn -testNonContextualizedCatchWithContext :: Assertion-testNonContextualizedCatchWithContext = do-  ErrorWithContext (ErrorContext ctx) TestException <- runErrorContextT $-    withErrorContext "A" $-    withErrorContext "B" $ do+testNonContextualizedCatchWithContext :: TestConf -> Assertion+testNonContextualizedCatchWithContext TestConf { .. } = do+  ErrorWithContext ctx TestException <- runStackT $+    withErrorNamespace "A" $+    withErrorNamespace "B" $ do     catchWithContext throwPureException $ \ (exn :: ErrorWithContext TestException) -> do       pure exn-  [] @=? ctx+  [] @=? errorContextNamespace ctx    where throwPureException = throw TestException -testEnsureExceptionContext :: Assertion-testEnsureExceptionContext = do-  Left someExn <- try . runErrorContextT $-    withErrorContext "A" $-    withErrorContext "B" $ do+testEnsureExceptionContext :: TestConf -> Assertion+testEnsureExceptionContext TestConf { .. } = do+  Left someExn <- try . runStackT $+    withErrorNamespace "A" $+    withErrorNamespace "B" $ do     ensureExceptionContext $ do       throw TestException   let Just (ErrorWithContext ctx someExnWithoutCtx) = fromException someExn   Just TestException @=? fromException someExnWithoutCtx-  ErrorContext ["B", "A"] @=? ctx+  ["A", "B"] @=? errorContextNamespace ctx -testCatchHeadException :: Assertion-testCatchHeadException = do-  Left errWithCtx <- tryAnyWithContext . runErrorContextT $ do-    withErrorContext "Here I am, calling head on an empty list!" $+testCatchHeadException :: TestConf -> Assertion+testCatchHeadException TestConf { .. } = do+  Left errWithCtx <- tryAnyWithContext . runStackT $ do+    withErrorNamespace "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+testTryAnyWithContext :: TestConf -> Assertion+testTryAnyWithContext TestConf { .. } = do+  Left (ErrorWithContext _ctx someExn) <- tryAnyWithContext . runStackT $ do     void $ throwM TestException     pure ()   Just TestException @=? fromException someExn -testTryAnyWithContextPure :: Assertion-testTryAnyWithContextPure = do-  Left (ErrorWithContext _ctx someExn) <- tryAnyWithContext . runErrorContextT $+testTryAnyWithContextPure :: TestConf -> Assertion+testTryAnyWithContextPure TestConf { .. } = do+  Left (ErrorWithContext _ctx someExn) <- tryAnyWithContext . runStackT $     seq (throw TestException) (pure ())   Just TestException @=? fromException someExn -testTryAnyWithoutContext :: Assertion-testTryAnyWithoutContext = do-  Left someExn <- tryAnyWithoutContext . runErrorContextT $ do+testTryAnyWithoutContext :: TestConf -> Assertion+testTryAnyWithoutContext TestConf { .. } = do+  Left someExn <- tryAnyWithoutContext . runStackT $ do     void $ throwM TestException     pure ()   Just TestException @=? fromException someExn -testTryAnyWithoutContextPure :: Assertion-testTryAnyWithoutContextPure = do-  Left someExn <- tryAnyWithoutContext . runErrorContextT $+testTryAnyWithoutContextPure :: TestConf -> Assertion+testTryAnyWithoutContextPure TestConf { .. } = do+  Left someExn <- tryAnyWithoutContext . runStackT $     seq (throw TestException) (pure ())   Just TestException @=? fromException someExn -testTryWithContext :: Assertion-testTryWithContext = do-  Left (ErrorWithContext _ctx exn) <- tryWithContext . runErrorContextT $ do+testTryWithContext :: TestConf -> Assertion+testTryWithContext TestConf { .. } = do+  Left (ErrorWithContext _ctx exn) <- tryWithContext . runStackT $ do     void $ throwM TestException     pure ()   TestException @=? exn -testTryWithContextPure :: Assertion-testTryWithContextPure = do-  Left (ErrorWithContext _ctx exn) <- tryWithContext . runErrorContextT $+testTryWithContextPure :: TestConf -> Assertion+testTryWithContextPure TestConf { .. } = do+  Left (ErrorWithContext _ctx exn) <- tryWithContext . runStackT $     seq (throw TestException) (pure ())   TestException @=? exn -testTryWithoutContext :: Assertion-testTryWithoutContext = do-  Left exn <- tryWithoutContext . runErrorContextT $ do+testTryWithoutContext :: TestConf -> Assertion+testTryWithoutContext TestConf { .. } = do+  Left exn <- tryWithoutContext . runStackT $ do     void $ throwM TestException     pure ()   TestException @=? exn -testTryWithoutContextPure :: Assertion-testTryWithoutContextPure = do-  Left exn <- tryWithoutContext . runErrorContextT $+testTryWithoutContextPure :: TestConf -> Assertion+testTryWithoutContextPure TestConf { .. } = do+  Left exn <- tryWithoutContext . runStackT $     seq (throw TestException) (pure ())   TestException @=? exn --- testTryAnyWithoutContext :: Assertion--- testTryAnyWithoutContext = do---   Left someExn <- tryAnyWithoutContext . runErrorContextT $ do---     void $ throwM TestException---     pure ()---   Just TestException @=? fromException someExn+testContextKv :: TestConf -> Assertion+testContextKv TestConf { .. } = do+  Left (ErrorWithContext ctx TestException) <- tryWithContext . runStackT $+    withErrorContext "ultimate-answer" answer $+    throwM TestException+  HashMap.fromList [("ultimate-answer", toJSON answer)] @=? extractKVs ctx++  where answer :: Int+        answer = 42++testContextKvOverwrite :: TestConf -> Assertion+testContextKvOverwrite TestConf { .. } = do+  Left (ErrorWithContext ctx TestException) <- tryWithContext . runStackT $+    withErrorContext "ultimate-answer" answer $+    withErrorContext "ultimate-answer" answer' $+    throwM TestException+  HashMap.fromList [("ultimate-answer", toJSON answer')] @=? errorContextKVs ctx++  where answer :: Int+        answer = 42++        answer' :: Int+        answer' = 0++testExample :: IO ()+testExample = do+  Left errWithCtx <- tryAnyWithContext . runErrorContextT $+    withErrorNamespace "middle-earth" $+    withErrorNamespace "mordor" $+    withErrorContext "ring-carrier" ("Frodo" :: Text) $+      throwM TestException+  putStrLn . displayException $ errWithCtx

@@ -8,3 +8,5 @@     testGroup "Test Suite"     [ Control.Error.Context.Test.tests     ]++