-- |
-- Module      : Control.Exception.ChainedException
-- Description : Exception that keeps the stack of error locations
-- Copyright   : (c) Aleksey Makarov, 2021
-- License     : BSD 3-Clause License
-- Maintainer  : aleksey.makarov@gmail.com
-- Stability   : experimental
-- Portability : portable
-- 
-- Exception that keeps the stack of error locations.

-- Look also at these:
-- https://hackage.haskell.org/package/loch-th
-- https://github.com/MaartenFaddegon/Hoed

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}

module Control.Exception.ChainedException
    ( ChainedExceptionNext(..)
    , ChainedException(..)
    , chainedError
    , chainedError'
    , addContext
    , addContext'
    , maybeAddContext
    , maybeAddContext'
    , eitherAddContext'
    ) where

-- https://stackoverflow.com/questions/13379356/finding-the-line-number-of-a-function-in-haskell

import Control.Exception hiding (try, catch)
import Control.Monad.Catch
import Language.Haskell.TH

-- | Structure to organize the stack of exceptions with locations
data ChainedExceptionNext = Null                         -- ^ exception was initiated by @`chainedError`@
                          | Next SomeException           -- ^ some context was added to @t`SomeException`@ by @`addContext`@
                          | NextChained ChainedException -- ^ some context was added to a @t`ChainedException`@ by @`addContext`@

-- | Exception that keeps track of error locations
data ChainedException = ChainedException
    { ChainedException -> String
err   :: String               -- ^ description of the error
    , ChainedException -> Loc
loc   :: Loc                  -- ^ location
    , ChainedException -> ChainedExceptionNext
stack :: ChainedExceptionNext -- ^ stack of locations
    }

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@ results in a function of type
-- \'@chainedError :: MonadThrow m => String -> m a@\'.
-- It throws t`ChainedException` with its argument as error description.
chainedError :: Q Exp
chainedError :: Q Exp
chainedError = Q Exp -> Q Exp
withLoc [| chainedErrorX |]

-- | @\$chainedError'@ is the same as @$`chainedError` ""@
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@ results in a function of type
-- \'@addContext :: MonadCatch m => String -> m a -> m a@\'.
-- It runs the second argument and adds t`ChainedException` with its first argument
-- to the exceptions thrown from that monad.
addContext :: Q Exp
addContext :: Q Exp
addContext = Q Exp -> Q Exp
withLoc [| addContextX |]

-- | @\$addContext'@ is the same as @$addContext ""@
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@ results in a function of type
-- \'@maybeAddContext :: MonadThrow m => String -> Maybe a -> m a@\'.
-- If its second argument is `Nothing`, it throws t`ChainedException` with its first argument,
-- else it returns the value of `Just`.
maybeAddContext :: Q Exp
maybeAddContext :: Q Exp
maybeAddContext = Q Exp -> Q Exp
withLoc [| maybeAddContextX |]

-- | @\$maybeAddContext'@ is the same as @$maybeAddContext ""@
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'@ results in a function of type
-- \'@eitherAddContext' :: MonadThrow m => Either String a -> m a@\'.
-- If its argument is @`Left` e@, it throws t`ChainedException` with @e@ as error description,
-- else it returns the value of `Right`.
eitherAddContext' :: Q Exp
eitherAddContext' :: Q Exp
eitherAddContext' = Q Exp -> Q Exp
withLoc [| eitherAddContextX |]