{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module RON.Error (
    Error (..),
    MonadE,
    correct,
    errorContext,
    liftEither,
    liftEitherString,
    liftMaybe,
    throwError,
    throwErrorString,
    throwErrorText,
    tryIO,
) where

import           RON.Prelude

import           Control.Exception (SomeException, try)
import           Data.String (IsString, fromString)
import qualified Data.Text as Text
import           GHC.Stack (callStack, getCallStack, prettySrcLoc)
import qualified Text.Show

data Error = Error{Error -> Text
description :: Text, Error -> [Error]
reasons :: [Error]}
  deriving (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq)

instance Show Error where
  show :: Error -> String
show =
    [String] -> String
unlines ([String] -> String) -> (Error -> [String]) -> Error -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> [String]
go
    where
      go :: Error -> [String]
go Error{Text
description :: Text
description :: Error -> Text
description, [Error]
reasons :: [Error]
reasons :: Error -> [Error]
reasons} =
        Text -> String
Text.unpack Text
description String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Error -> [String]) -> [Error] -> [String]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> (Error -> [String]) -> Error -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> [String]
go) [Error]
reasons

instance Exception Error

instance IsString Error where
    fromString :: String -> Error
fromString String
s = Text -> [Error] -> Error
Error (String -> Text
forall a. IsString a => String -> a
fromString String
s) []

type MonadE = MonadError Error

errorContext :: MonadE m => Text -> m a -> m a
errorContext :: Text -> m a -> m a
errorContext Text
ctx m a
action = m a
action m a -> (Error -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \Error
e -> Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> m a) -> Error -> m a
forall a b. (a -> b) -> a -> b
$ Text -> [Error] -> Error
Error Text
ctx [Error
e]

liftMaybe :: MonadE m => Text -> Maybe a -> m a
liftMaybe :: Text -> Maybe a -> m a
liftMaybe Text
msg = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> m a
forall (m :: * -> *) a. MonadE m => Text -> m a
throwErrorText Text
msg) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

liftEitherString :: (MonadError e m, IsString e) => Either String a -> m a
liftEitherString :: Either String a -> m a
liftEitherString = (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 -> m a
forall e (m :: * -> *) a.
(MonadError e m, IsString e) =>
String -> m a
throwErrorString a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

throwErrorText :: MonadE m => Text -> m a
throwErrorText :: Text -> m a
throwErrorText Text
msg = Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> m a) -> Error -> m a
forall a b. (a -> b) -> a -> b
$ Text -> [Error] -> Error
Error Text
msg []

throwErrorString :: (MonadError e m, IsString e) => String -> m a
throwErrorString :: String -> m a
throwErrorString = e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m a) -> (String -> e) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> e
forall a. IsString a => String -> a
fromString

correct :: MonadError e m => a -> m a -> m a
correct :: a -> m a -> m a
correct a
def m a
action =
    m a
action
    m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \e
_e ->
        -- TODO(2019-08-06, cblp) $logWarnSH e
        a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def

tryIO :: (MonadE m, MonadIO m, HasCallStack) => IO a -> m a
tryIO :: IO a -> m a
tryIO IO a
action = do
  Either SomeException a
e <- IO (Either SomeException a) -> m (Either SomeException a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException a) -> m (Either SomeException a))
-> IO (Either SomeException a) -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
action
  case Either SomeException a
e of
    Right a
a  -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left SomeException
exc -> do
      let
        description :: Text
description =
          case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
            [] -> Text
"tryIO"
            (String
f, SrcLoc
loc) : [(String, SrcLoc)]
_ -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", called at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
prettySrcLoc SrcLoc
loc
      Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        Error :: Text -> [Error] -> Error
Error{Text
description :: Text
description :: Text
description, reasons :: [Error]
reasons = [String -> Error
forall a. IsString a => String -> a
fromString (SomeException -> String
forall a s. (Show a, IsString s) => a -> s
show (SomeException
exc :: SomeException))]}