{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
module Control.Exception.ChainedException
( ChainedExceptionNext(..)
, ChainedException(..)
, chainedError
, chainedError'
, addContext
, addContext'
, maybeAddContext
, maybeAddContext'
, eitherAddContext'
) where
import Control.Exception hiding (try, catch)
import Control.Monad.Catch
import Language.Haskell.TH
data ChainedExceptionNext = Null
| Next SomeException
| NextChained ChainedException
data ChainedException = ChainedException
{ ChainedException -> String
err :: String
, ChainedException -> Loc
loc :: Loc
, ChainedException -> ChainedExceptionNext
stack :: ChainedExceptionNext
}
formatLoc :: Loc -> String
formatLoc :: Loc -> String
formatLoc Loc
loc =
let
file :: String
file = Loc -> String
loc_filename Loc
loc
(Int
line, Int
_) = Loc -> CharPos
loc_start Loc
loc
in [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
file, String
":", Int -> String
forall a. Show a => a -> String
show Int
line]
instance Show ChainedException where
show :: ChainedException -> String
show ChainedException{String
Loc
ChainedExceptionNext
err :: ChainedException -> String
loc :: ChainedException -> Loc
stack :: ChainedException -> ChainedExceptionNext
err :: String
loc :: Loc
stack :: ChainedExceptionNext
..} = String
showThis String -> ShowS
forall a. [a] -> [a] -> [a]
++ case ChainedExceptionNext
stack of
ChainedExceptionNext
Null -> String
""
NextChained ChainedException
ce -> String
" // " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ChainedException -> String
forall a. Show a => a -> String
show ChainedException
ce
Next SomeException
e -> String
" // " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
where
showThis :: String
showThis = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
err, if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
err then String
"" else String
" ", String
"(", Loc -> String
formatLoc Loc
loc, String
")" ]
instance Exception ChainedException
withLoc :: Q Exp -> Q Exp
withLoc :: Q Exp -> Q Exp
withLoc Q Exp
f = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
f (Q Loc
location Q Loc -> (Loc -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Loc -> Q Exp
liftLoc)
liftLoc :: Loc -> Q Exp
liftLoc :: Loc -> Q Exp
liftLoc Loc {String
CharPos
loc_filename :: Loc -> String
loc_start :: Loc -> CharPos
loc_filename :: String
loc_package :: String
loc_module :: String
loc_start :: CharPos
loc_end :: CharPos
loc_end :: Loc -> CharPos
loc_module :: Loc -> String
loc_package :: Loc -> String
..} = [| Loc loc_filename loc_package loc_module loc_start loc_end |]
chainedErrorX :: MonadThrow m => Loc -> String -> m a
chainedErrorX :: forall (m :: * -> *) a. MonadThrow m => Loc -> String -> m a
chainedErrorX Loc
loc String
s = ChainedException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ChainedException -> m a) -> ChainedException -> m a
forall a b. (a -> b) -> a -> b
$ String -> Loc -> ChainedExceptionNext -> ChainedException
ChainedException String
s Loc
loc ChainedExceptionNext
Null
chainedError :: Q Exp
chainedError :: Q Exp
chainedError = Q Exp -> Q Exp
withLoc [| chainedErrorX |]
chainedError' :: Q Exp
chainedError' :: Q Exp
chainedError' = Q Exp -> Q Exp
withLoc [| (`chainedErrorX` []) |]
addContextX :: MonadCatch m => Loc -> String -> m a -> m a
addContextX :: forall (m :: * -> *) a. MonadCatch m => Loc -> String -> m a -> m a
addContextX Loc
loc String
s m a
m = m a
m m a -> (SomeException -> m a) -> m a
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> m a
forall (m :: * -> *) a. MonadThrow m => SomeException -> m a
f
where
f :: MonadThrow m => SomeException -> m a
f :: forall (m :: * -> *) a. MonadThrow m => SomeException -> m a
f SomeException
e = ChainedException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ChainedException -> m a) -> ChainedException -> m a
forall a b. (a -> b) -> a -> b
$ String -> Loc -> ChainedExceptionNext -> ChainedException
ChainedException String
s Loc
loc (ChainedExceptionNext -> ChainedException)
-> ChainedExceptionNext -> ChainedException
forall a b. (a -> b) -> a -> b
$ case SomeException -> Maybe ChainedException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just ChainedException
ce -> ChainedException -> ChainedExceptionNext
NextChained ChainedException
ce
Maybe ChainedException
Nothing -> SomeException -> ChainedExceptionNext
Next SomeException
e
addContext :: Q Exp
addContext :: Q Exp
addContext = Q Exp -> Q Exp
withLoc [| addContextX |]
addContext' :: Q Exp
addContext' :: Q Exp
addContext' = Q Exp -> Q Exp
withLoc [| (`addContextX` []) |]
maybeAddContextX :: MonadThrow m => Loc -> String -> Maybe a -> m a
maybeAddContextX :: forall (m :: * -> *) a.
MonadThrow m =>
Loc -> String -> Maybe a -> m a
maybeAddContextX Loc
loc String
s = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ChainedException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ChainedException -> m a) -> ChainedException -> m a
forall a b. (a -> b) -> a -> b
$ String -> Loc -> ChainedExceptionNext -> ChainedException
ChainedException String
s Loc
loc ChainedExceptionNext
Null) a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
maybeAddContext :: Q Exp
maybeAddContext :: Q Exp
maybeAddContext = Q Exp -> Q Exp
withLoc [| maybeAddContextX |]
maybeAddContext' :: Q Exp
maybeAddContext' :: Q Exp
maybeAddContext' = Q Exp -> Q Exp
withLoc [| (`maybeAddContextX` []) |]
eitherAddContextX :: MonadThrow m => Loc -> Either String a -> m a
eitherAddContextX :: forall (m :: * -> *) a.
MonadThrow m =>
Loc -> Either String a -> m a
eitherAddContextX Loc
loc = (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ String
s -> ChainedException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ChainedException -> m a) -> ChainedException -> m a
forall a b. (a -> b) -> a -> b
$ String -> Loc -> ChainedExceptionNext -> ChainedException
ChainedException String
s Loc
loc ChainedExceptionNext
Null) a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
eitherAddContext' :: Q Exp
eitherAddContext' :: Q Exp
eitherAddContext' = Q Exp -> Q Exp
withLoc [| eitherAddContextX |]