{-# 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
, catchAnyWithContext
, catchAnyWithoutContext
, ensureExceptionContext
, tryAnyWithContext
, tryAnyWithoutContext
, tryWithContext
, 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
class (Monad m, MonadThrow m) => MonadErrorContext m where
errorContextCollect :: m ErrorContext
withErrorContext :: Text -> m a -> m a
newtype ErrorContextT m a =
ErrorContextT { _runErrorContextT :: ReaderT ErrorContext m a
} deriving ( Functor
, Applicative
, Monad
, MonadTrans
, MonadState s
, MonadWriter w )
data ErrorWithContext e =
ErrorWithContext ErrorContext e
deriving (Show)
instance Functor ErrorWithContext where
fmap f (ErrorWithContext ctx e) = ErrorWithContext ctx (f e)
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
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)
instance MonadThrow m => MonadErrorContext (ErrorContextT m) where
errorContextCollect = ErrorContextT ask
withErrorContext layer (ErrorContextT m) =
ErrorContextT (local (errorContextPush layer) m)
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))
instance MonadCatch m => MonadCatch (ErrorContextT m) where
catch (ErrorContextT (ReaderT m)) c =
ErrorContextT . ReaderT $
\ r -> m r `catchWithoutContext` \ exn -> runReaderT (_runErrorContextT (c exn)) r
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 =
case fromException someExn of
Just (ErrorWithContext ctx someExnWithoutCtx :: ErrorWithContext SomeException) ->
case fromException someExnWithoutCtx of
Just exn -> Just (ErrorWithContext ctx exn)
Nothing -> Nothing
Nothing ->
case fromException someExn of
Just exn ->
Just (ErrorWithContext (ErrorContext []) exn)
Nothing ->
Nothing
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 =
case fromException someExn :: Maybe (ErrorWithContext SomeException) of
Just (ErrorWithContext _ctx someExnWithoutContext) ->
case fromException someExnWithoutContext :: Maybe e of
Just exn ->
Just exn
Nothing ->
Nothing
Nothing ->
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)
instance (MonadCatch m, MonadResource m) => MonadResource (ErrorContextT m) where
liftResourceT = lift . 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)))
data ErrorContext = ErrorContext [Text] deriving (Show, Eq)
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
errorWithContextDump
:: (Show e, MonadIO m)
=> ErrorWithContext e
-> m ()
errorWithContextDump (ErrorWithContext ctx err) = do
liftIO . putStrLn $ "Error: " <> show err
liftIO . putStrLn . errorContextAsString $ ctx
errorContextualize
:: MonadErrorContext m
=> e
-> m (ErrorWithContext e)
errorContextualize e = do
ctx <- errorContextCollect
pure $ ErrorWithContext ctx e
errorContextForget
:: ErrorWithContext e
-> e
errorContextForget (ErrorWithContext _ctx e) = e
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)
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
Just exnWithCtx ->
throwM exnWithCtx
Nothing -> do
ctx <- errorContextCollect
throwM $ ErrorWithContext ctx someExn