{-# 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 ->
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))]}