{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}

-- inspired by https://github.com/janestreet/base/blob/master/src/or_error.mli

-- | Provides composable and hierarchical errors, with pretty
-- printing. The errors are accumulated in a tree like structure,
-- 'ErrorAcc'. 'ErrorAcc' is disigned to be read by humans, via
-- 'pretty', not dispatched on by code. Using 'toE' to convert an
-- 'ErrorOr' to IO throws (in case it holds an error) a 'PrettyErrAcc'
-- that uses 'pretty' in the show instance.
module Data.ErrorOr
  ( ErrorOr(..),
    err,
    tag,
    pattern Error,
    pattern OK,
    isOK,
    isError,
    fromOK,
    ErrorConv(..),
    ErrorAcc(..),
    pretty,
    PrettyErrAcc (..),
    tagIO,
  )
where

import qualified Control.Exception as Exc
import Data.Foldable (toList)
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import GHC.IO.Exception (IOException)
#if __GLASGOW_HASKELL__ < 880
import Prelude hiding (fail)
import Data.Semigroup
import Control.Monad.Fail (MonadFail(..))
#endif

-- | Use 'Applicative'\'s 'sequenceA' and 'sequenceA_' to compose 'ErrorOr's as opposed to 'Monad' derived functions like 'sequence'.
newtype ErrorOr a = ErrorOr {ErrorOr a -> Either ErrorAcc a
errorOrToEither :: Either ErrorAcc a}
  deriving (Int -> ErrorOr a -> ShowS
[ErrorOr a] -> ShowS
ErrorOr a -> String
(Int -> ErrorOr a -> ShowS)
-> (ErrorOr a -> String)
-> ([ErrorOr a] -> ShowS)
-> Show (ErrorOr a)
forall a. Show a => Int -> ErrorOr a -> ShowS
forall a. Show a => [ErrorOr a] -> ShowS
forall a. Show a => ErrorOr a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorOr a] -> ShowS
$cshowList :: forall a. Show a => [ErrorOr a] -> ShowS
show :: ErrorOr a -> String
$cshow :: forall a. Show a => ErrorOr a -> String
showsPrec :: Int -> ErrorOr a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ErrorOr a -> ShowS
Show, ReadPrec [ErrorOr a]
ReadPrec (ErrorOr a)
Int -> ReadS (ErrorOr a)
ReadS [ErrorOr a]
(Int -> ReadS (ErrorOr a))
-> ReadS [ErrorOr a]
-> ReadPrec (ErrorOr a)
-> ReadPrec [ErrorOr a]
-> Read (ErrorOr a)
forall a. Read a => ReadPrec [ErrorOr a]
forall a. Read a => ReadPrec (ErrorOr a)
forall a. Read a => Int -> ReadS (ErrorOr a)
forall a. Read a => ReadS [ErrorOr a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ErrorOr a]
$creadListPrec :: forall a. Read a => ReadPrec [ErrorOr a]
readPrec :: ReadPrec (ErrorOr a)
$creadPrec :: forall a. Read a => ReadPrec (ErrorOr a)
readList :: ReadS [ErrorOr a]
$creadList :: forall a. Read a => ReadS [ErrorOr a]
readsPrec :: Int -> ReadS (ErrorOr a)
$creadsPrec :: forall a. Read a => Int -> ReadS (ErrorOr a)
Read, ErrorOr a -> ErrorOr a -> Bool
(ErrorOr a -> ErrorOr a -> Bool)
-> (ErrorOr a -> ErrorOr a -> Bool) -> Eq (ErrorOr a)
forall a. Eq a => ErrorOr a -> ErrorOr a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorOr a -> ErrorOr a -> Bool
$c/= :: forall a. Eq a => ErrorOr a -> ErrorOr a -> Bool
== :: ErrorOr a -> ErrorOr a -> Bool
$c== :: forall a. Eq a => ErrorOr a -> ErrorOr a -> Bool
Eq, Eq (ErrorOr a)
Eq (ErrorOr a)
-> (ErrorOr a -> ErrorOr a -> Ordering)
-> (ErrorOr a -> ErrorOr a -> Bool)
-> (ErrorOr a -> ErrorOr a -> Bool)
-> (ErrorOr a -> ErrorOr a -> Bool)
-> (ErrorOr a -> ErrorOr a -> Bool)
-> (ErrorOr a -> ErrorOr a -> ErrorOr a)
-> (ErrorOr a -> ErrorOr a -> ErrorOr a)
-> Ord (ErrorOr a)
ErrorOr a -> ErrorOr a -> Bool
ErrorOr a -> ErrorOr a -> Ordering
ErrorOr a -> ErrorOr a -> ErrorOr a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (ErrorOr a)
forall a. Ord a => ErrorOr a -> ErrorOr a -> Bool
forall a. Ord a => ErrorOr a -> ErrorOr a -> Ordering
forall a. Ord a => ErrorOr a -> ErrorOr a -> ErrorOr a
min :: ErrorOr a -> ErrorOr a -> ErrorOr a
$cmin :: forall a. Ord a => ErrorOr a -> ErrorOr a -> ErrorOr a
max :: ErrorOr a -> ErrorOr a -> ErrorOr a
$cmax :: forall a. Ord a => ErrorOr a -> ErrorOr a -> ErrorOr a
>= :: ErrorOr a -> ErrorOr a -> Bool
$c>= :: forall a. Ord a => ErrorOr a -> ErrorOr a -> Bool
> :: ErrorOr a -> ErrorOr a -> Bool
$c> :: forall a. Ord a => ErrorOr a -> ErrorOr a -> Bool
<= :: ErrorOr a -> ErrorOr a -> Bool
$c<= :: forall a. Ord a => ErrorOr a -> ErrorOr a -> Bool
< :: ErrorOr a -> ErrorOr a -> Bool
$c< :: forall a. Ord a => ErrorOr a -> ErrorOr a -> Bool
compare :: ErrorOr a -> ErrorOr a -> Ordering
$ccompare :: forall a. Ord a => ErrorOr a -> ErrorOr a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (ErrorOr a)
Ord, a -> ErrorOr b -> ErrorOr a
(a -> b) -> ErrorOr a -> ErrorOr b
(forall a b. (a -> b) -> ErrorOr a -> ErrorOr b)
-> (forall a b. a -> ErrorOr b -> ErrorOr a) -> Functor ErrorOr
forall a b. a -> ErrorOr b -> ErrorOr a
forall a b. (a -> b) -> ErrorOr a -> ErrorOr b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ErrorOr b -> ErrorOr a
$c<$ :: forall a b. a -> ErrorOr b -> ErrorOr a
fmap :: (a -> b) -> ErrorOr a -> ErrorOr b
$cfmap :: forall a b. (a -> b) -> ErrorOr a -> ErrorOr b
Functor, a -> ErrorOr a -> Bool
ErrorOr m -> m
ErrorOr a -> [a]
ErrorOr a -> Bool
ErrorOr a -> Int
ErrorOr a -> a
ErrorOr a -> a
ErrorOr a -> a
ErrorOr a -> a
(a -> m) -> ErrorOr a -> m
(a -> m) -> ErrorOr a -> m
(a -> b -> b) -> b -> ErrorOr a -> b
(a -> b -> b) -> b -> ErrorOr a -> b
(b -> a -> b) -> b -> ErrorOr a -> b
(b -> a -> b) -> b -> ErrorOr a -> b
(a -> a -> a) -> ErrorOr a -> a
(a -> a -> a) -> ErrorOr a -> a
(forall m. Monoid m => ErrorOr m -> m)
-> (forall m a. Monoid m => (a -> m) -> ErrorOr a -> m)
-> (forall m a. Monoid m => (a -> m) -> ErrorOr a -> m)
-> (forall a b. (a -> b -> b) -> b -> ErrorOr a -> b)
-> (forall a b. (a -> b -> b) -> b -> ErrorOr a -> b)
-> (forall b a. (b -> a -> b) -> b -> ErrorOr a -> b)
-> (forall b a. (b -> a -> b) -> b -> ErrorOr a -> b)
-> (forall a. (a -> a -> a) -> ErrorOr a -> a)
-> (forall a. (a -> a -> a) -> ErrorOr a -> a)
-> (forall a. ErrorOr a -> [a])
-> (forall a. ErrorOr a -> Bool)
-> (forall a. ErrorOr a -> Int)
-> (forall a. Eq a => a -> ErrorOr a -> Bool)
-> (forall a. Ord a => ErrorOr a -> a)
-> (forall a. Ord a => ErrorOr a -> a)
-> (forall a. Num a => ErrorOr a -> a)
-> (forall a. Num a => ErrorOr a -> a)
-> Foldable ErrorOr
forall a. Eq a => a -> ErrorOr a -> Bool
forall a. Num a => ErrorOr a -> a
forall a. Ord a => ErrorOr a -> a
forall m. Monoid m => ErrorOr m -> m
forall a. ErrorOr a -> Bool
forall a. ErrorOr a -> Int
forall a. ErrorOr a -> [a]
forall a. (a -> a -> a) -> ErrorOr a -> a
forall m a. Monoid m => (a -> m) -> ErrorOr a -> m
forall b a. (b -> a -> b) -> b -> ErrorOr a -> b
forall a b. (a -> b -> b) -> b -> ErrorOr a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: ErrorOr a -> a
$cproduct :: forall a. Num a => ErrorOr a -> a
sum :: ErrorOr a -> a
$csum :: forall a. Num a => ErrorOr a -> a
minimum :: ErrorOr a -> a
$cminimum :: forall a. Ord a => ErrorOr a -> a
maximum :: ErrorOr a -> a
$cmaximum :: forall a. Ord a => ErrorOr a -> a
elem :: a -> ErrorOr a -> Bool
$celem :: forall a. Eq a => a -> ErrorOr a -> Bool
length :: ErrorOr a -> Int
$clength :: forall a. ErrorOr a -> Int
null :: ErrorOr a -> Bool
$cnull :: forall a. ErrorOr a -> Bool
toList :: ErrorOr a -> [a]
$ctoList :: forall a. ErrorOr a -> [a]
foldl1 :: (a -> a -> a) -> ErrorOr a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ErrorOr a -> a
foldr1 :: (a -> a -> a) -> ErrorOr a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> ErrorOr a -> a
foldl' :: (b -> a -> b) -> b -> ErrorOr a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ErrorOr a -> b
foldl :: (b -> a -> b) -> b -> ErrorOr a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ErrorOr a -> b
foldr' :: (a -> b -> b) -> b -> ErrorOr a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ErrorOr a -> b
foldr :: (a -> b -> b) -> b -> ErrorOr a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> ErrorOr a -> b
foldMap' :: (a -> m) -> ErrorOr a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ErrorOr a -> m
foldMap :: (a -> m) -> ErrorOr a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ErrorOr a -> m
fold :: ErrorOr m -> m
$cfold :: forall m. Monoid m => ErrorOr m -> m
Foldable, Functor ErrorOr
Foldable ErrorOr
Functor ErrorOr
-> Foldable ErrorOr
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> ErrorOr a -> f (ErrorOr b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ErrorOr (f a) -> f (ErrorOr a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ErrorOr a -> m (ErrorOr b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ErrorOr (m a) -> m (ErrorOr a))
-> Traversable ErrorOr
(a -> f b) -> ErrorOr a -> f (ErrorOr b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => ErrorOr (m a) -> m (ErrorOr a)
forall (f :: * -> *) a.
Applicative f =>
ErrorOr (f a) -> f (ErrorOr a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ErrorOr a -> m (ErrorOr b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ErrorOr a -> f (ErrorOr b)
sequence :: ErrorOr (m a) -> m (ErrorOr a)
$csequence :: forall (m :: * -> *) a. Monad m => ErrorOr (m a) -> m (ErrorOr a)
mapM :: (a -> m b) -> ErrorOr a -> m (ErrorOr b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ErrorOr a -> m (ErrorOr b)
sequenceA :: ErrorOr (f a) -> f (ErrorOr a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ErrorOr (f a) -> f (ErrorOr a)
traverse :: (a -> f b) -> ErrorOr a -> f (ErrorOr b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ErrorOr a -> f (ErrorOr b)
$cp2Traversable :: Foldable ErrorOr
$cp1Traversable :: Functor ErrorOr
Traversable)

pattern OK :: a -> ErrorOr a
pattern $mOK :: forall r a. ErrorOr a -> (a -> r) -> (Void# -> r) -> r
OK x <- ErrorOr (Right x)

pattern Error :: ErrorAcc -> ErrorOr a
pattern $mError :: forall r a. ErrorOr a -> (ErrorAcc -> r) -> (Void# -> r) -> r
Error err <- ErrorOr (Left err)

{-# COMPLETE OK, Error #-}

data ErrorAcc
  = Message T.Text
  | List (Seq.Seq ErrorAcc)
  | Tag T.Text ErrorAcc
  deriving (Int -> ErrorAcc -> ShowS
[ErrorAcc] -> ShowS
ErrorAcc -> String
(Int -> ErrorAcc -> ShowS)
-> (ErrorAcc -> String) -> ([ErrorAcc] -> ShowS) -> Show ErrorAcc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorAcc] -> ShowS
$cshowList :: [ErrorAcc] -> ShowS
show :: ErrorAcc -> String
$cshow :: ErrorAcc -> String
showsPrec :: Int -> ErrorAcc -> ShowS
$cshowsPrec :: Int -> ErrorAcc -> ShowS
Show, ReadPrec [ErrorAcc]
ReadPrec ErrorAcc
Int -> ReadS ErrorAcc
ReadS [ErrorAcc]
(Int -> ReadS ErrorAcc)
-> ReadS [ErrorAcc]
-> ReadPrec ErrorAcc
-> ReadPrec [ErrorAcc]
-> Read ErrorAcc
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ErrorAcc]
$creadListPrec :: ReadPrec [ErrorAcc]
readPrec :: ReadPrec ErrorAcc
$creadPrec :: ReadPrec ErrorAcc
readList :: ReadS [ErrorAcc]
$creadList :: ReadS [ErrorAcc]
readsPrec :: Int -> ReadS ErrorAcc
$creadsPrec :: Int -> ReadS ErrorAcc
Read, ErrorAcc -> ErrorAcc -> Bool
(ErrorAcc -> ErrorAcc -> Bool)
-> (ErrorAcc -> ErrorAcc -> Bool) -> Eq ErrorAcc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorAcc -> ErrorAcc -> Bool
$c/= :: ErrorAcc -> ErrorAcc -> Bool
== :: ErrorAcc -> ErrorAcc -> Bool
$c== :: ErrorAcc -> ErrorAcc -> Bool
Eq, Eq ErrorAcc
Eq ErrorAcc
-> (ErrorAcc -> ErrorAcc -> Ordering)
-> (ErrorAcc -> ErrorAcc -> Bool)
-> (ErrorAcc -> ErrorAcc -> Bool)
-> (ErrorAcc -> ErrorAcc -> Bool)
-> (ErrorAcc -> ErrorAcc -> Bool)
-> (ErrorAcc -> ErrorAcc -> ErrorAcc)
-> (ErrorAcc -> ErrorAcc -> ErrorAcc)
-> Ord ErrorAcc
ErrorAcc -> ErrorAcc -> Bool
ErrorAcc -> ErrorAcc -> Ordering
ErrorAcc -> ErrorAcc -> ErrorAcc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ErrorAcc -> ErrorAcc -> ErrorAcc
$cmin :: ErrorAcc -> ErrorAcc -> ErrorAcc
max :: ErrorAcc -> ErrorAcc -> ErrorAcc
$cmax :: ErrorAcc -> ErrorAcc -> ErrorAcc
>= :: ErrorAcc -> ErrorAcc -> Bool
$c>= :: ErrorAcc -> ErrorAcc -> Bool
> :: ErrorAcc -> ErrorAcc -> Bool
$c> :: ErrorAcc -> ErrorAcc -> Bool
<= :: ErrorAcc -> ErrorAcc -> Bool
$c<= :: ErrorAcc -> ErrorAcc -> Bool
< :: ErrorAcc -> ErrorAcc -> Bool
$c< :: ErrorAcc -> ErrorAcc -> Bool
compare :: ErrorAcc -> ErrorAcc -> Ordering
$ccompare :: ErrorAcc -> ErrorAcc -> Ordering
$cp1Ord :: Eq ErrorAcc
Ord)

-- | Produce an error.
err :: T.Text -> ErrorOr a
err :: Text -> ErrorOr a
err = Either ErrorAcc a -> ErrorOr a
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (Either ErrorAcc a -> ErrorOr a)
-> (Text -> Either ErrorAcc a) -> Text -> ErrorOr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorAcc -> Either ErrorAcc a
forall a b. a -> Either a b
Left (ErrorAcc -> Either ErrorAcc a)
-> (Text -> ErrorAcc) -> Text -> Either ErrorAcc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ErrorAcc
Message

-- | Annotate the error with context information.
tag :: T.Text -> ErrorOr a -> ErrorOr a
tag :: Text -> ErrorOr a -> ErrorOr a
tag Text
str ErrorOr a
res
  | ErrorOr a -> Bool
forall a. ErrorOr a -> Bool
isOK ErrorOr a
res = ErrorOr a
res
  | Bool
otherwise = (ErrorAcc -> ErrorAcc) -> ErrorOr a -> ErrorOr a
forall a. (ErrorAcc -> ErrorAcc) -> ErrorOr a -> ErrorOr a
mapError (Text -> ErrorAcc -> ErrorAcc
Tag Text
str) ErrorOr a
res

-- | A wrapper over 'ErrorAcc' to provide human readable exceptions.
-- (Exception class' displayException does not seem to be used by GHC)
-- https://stackoverflow.com/questions/55490766/why-doesn-t-ghc-use-my-displayexception-method
newtype PrettyErrAcc = PrettyErrAcc {PrettyErrAcc -> ErrorAcc
unPrettyErrAcc :: ErrorAcc}

instance Show PrettyErrAcc where
  show :: PrettyErrAcc -> String
show = Text -> String
T.unpack  (Text -> String)
-> (PrettyErrAcc -> Text) -> PrettyErrAcc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ErrorAcc -> Text
pretty Int
0 (ErrorAcc -> Text)
-> (PrettyErrAcc -> ErrorAcc) -> PrettyErrAcc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyErrAcc -> ErrorAcc
unPrettyErrAcc

instance Exc.Exception PrettyErrAcc where

-- | Tag an exception with an annotation.
--
-- It acts on two types of exceptions: `IOException` and
-- `PrettyErrAcc`. For `PrettyErrAcc` it is streightforward tagging.
-- For `IOException`, otoh, it converts the error message into Text
-- via String and turns it into `PrettyErrAcc` tagged with provided
-- adnotation.
--
-- This is rather a convenience function. Sometimes it is convenient
-- to @fail "msg"@ in IO, and tag it higher up with some context. The
-- need for 'tagIO' often comes with 'Data.ErrorOr.Utils.lookup' (from
-- error-or-utils package) when used from IO, which is overloaded for
-- MonadFail.
--
-- Since ver 0.1.1.0
tagIO :: T.Text -> IO a -> IO a
tagIO :: Text -> IO a -> IO a
tagIO Text
str IO a
action =
  (IO a
action
     IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exc.catch` \(IOException
e :: IOException) ->
         PrettyErrAcc -> IO a
forall e a. Exception e => e -> IO a
Exc.throwIO (PrettyErrAcc -> IO a) -> PrettyErrAcc -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorAcc -> PrettyErrAcc
PrettyErrAcc (ErrorAcc -> PrettyErrAcc) -> ErrorAcc -> PrettyErrAcc
forall a b. (a -> b) -> a -> b
$ Text -> ErrorAcc -> ErrorAcc
Tag Text
str (Text -> ErrorAcc
Message (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
e)))

     IO a -> (PrettyErrAcc -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exc.catch` \(PrettyErrAcc
e :: PrettyErrAcc) ->
         PrettyErrAcc -> IO a
forall e a. Exception e => e -> IO a
Exc.throwIO (PrettyErrAcc -> IO a) -> PrettyErrAcc -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorAcc -> PrettyErrAcc
PrettyErrAcc (ErrorAcc -> PrettyErrAcc) -> ErrorAcc -> PrettyErrAcc
forall a b. (a -> b) -> a -> b
$ Text -> ErrorAcc -> ErrorAcc
Tag Text
str (PrettyErrAcc -> ErrorAcc
unPrettyErrAcc PrettyErrAcc
e)


-- | Pretty print the error.
pretty :: Int
  -- ^ Initial indent, usually 0
  -> ErrorAcc -> T.Text
pretty :: Int -> ErrorAcc -> Text
pretty Int
indent (Message Text
txt) = Int -> Text -> Text
T.replicate Int
indent Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt
pretty Int
indent (List Seq ErrorAcc
errs) = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text)
-> (Seq ErrorAcc -> [Text]) -> Seq ErrorAcc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ErrorAcc -> Text) -> [ErrorAcc] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ErrorAcc -> Text
pretty Int
indent) ([ErrorAcc] -> [Text])
-> (Seq ErrorAcc -> [ErrorAcc]) -> Seq ErrorAcc -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq ErrorAcc -> [ErrorAcc]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq ErrorAcc -> Text) -> Seq ErrorAcc -> Text
forall a b. (a -> b) -> a -> b
$ Seq ErrorAcc
errs
pretty Int
indent (Tag Text
str ErrorAcc
err) = Text -> [Text] -> Text
T.intercalate Text
"\n" [Int -> ErrorAcc -> Text
pretty Int
indent (Text -> ErrorAcc
Message Text
str), Int -> ErrorAcc -> Text
pretty (Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) ErrorAcc
err]

instance Semigroup ErrorAcc where
  List Seq ErrorAcc
l1 <> :: ErrorAcc -> ErrorAcc -> ErrorAcc
<> List Seq ErrorAcc
l2 = Seq ErrorAcc -> ErrorAcc
List (Seq ErrorAcc
l1 Seq ErrorAcc -> Seq ErrorAcc -> Seq ErrorAcc
forall a. Semigroup a => a -> a -> a
<> Seq ErrorAcc
l2)
  List Seq ErrorAcc
l1 <> ErrorAcc
other = Seq ErrorAcc -> ErrorAcc
List (Seq ErrorAcc
l1 Seq ErrorAcc -> ErrorAcc -> Seq ErrorAcc
forall a. Seq a -> a -> Seq a
Seq.|> ErrorAcc
other)
  ErrorAcc
other <> List Seq ErrorAcc
l2 = Seq ErrorAcc -> ErrorAcc
List (ErrorAcc
other ErrorAcc -> Seq ErrorAcc -> Seq ErrorAcc
forall a. a -> Seq a -> Seq a
Seq.<| Seq ErrorAcc
l2)
  ErrorAcc
notList1 <> ErrorAcc
notList2 = Seq ErrorAcc -> ErrorAcc
List ([ErrorAcc] -> Seq ErrorAcc
forall a. [a] -> Seq a
Seq.fromList [ErrorAcc
notList1, ErrorAcc
notList2])

instance Applicative ErrorOr where
  pure :: a -> ErrorOr a
pure a
x = Either ErrorAcc a -> ErrorOr a
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (a -> Either ErrorAcc a
forall a b. b -> Either a b
Right a
x)
  ErrorOr (Right a -> b
f) <*> :: ErrorOr (a -> b) -> ErrorOr a -> ErrorOr b
<*> ErrorOr (Right a
a) = b -> ErrorOr b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
a)
  ErrorOr (Left ErrorAcc
e1) <*> ErrorOr (Left ErrorAcc
e2) = Either ErrorAcc b -> ErrorOr b
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (Either ErrorAcc b -> ErrorOr b)
-> (ErrorAcc -> Either ErrorAcc b) -> ErrorAcc -> ErrorOr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorAcc -> Either ErrorAcc b
forall a b. a -> Either a b
Left (ErrorAcc -> ErrorOr b) -> ErrorAcc -> ErrorOr b
forall a b. (a -> b) -> a -> b
$ ErrorAcc
e1 ErrorAcc -> ErrorAcc -> ErrorAcc
forall a. Semigroup a => a -> a -> a
<> ErrorAcc
e2
  ErrorOr (Left ErrorAcc
e1) <*> ErrorOr (Right a
_) = Either ErrorAcc b -> ErrorOr b
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (Either ErrorAcc b -> ErrorOr b)
-> (ErrorAcc -> Either ErrorAcc b) -> ErrorAcc -> ErrorOr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorAcc -> Either ErrorAcc b
forall a b. a -> Either a b
Left (ErrorAcc -> ErrorOr b) -> ErrorAcc -> ErrorOr b
forall a b. (a -> b) -> a -> b
$ ErrorAcc
e1
  ErrorOr (Right a -> b
_) <*> ErrorOr (Left ErrorAcc
e2) = Either ErrorAcc b -> ErrorOr b
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (Either ErrorAcc b -> ErrorOr b)
-> (ErrorAcc -> Either ErrorAcc b) -> ErrorAcc -> ErrorOr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorAcc -> Either ErrorAcc b
forall a b. a -> Either a b
Left (ErrorAcc -> ErrorOr b) -> ErrorAcc -> ErrorOr b
forall a b. (a -> b) -> a -> b
$ ErrorAcc
e2

instance Semigroup a => Semigroup (ErrorOr a) where
  Error ErrorAcc
e1 <> :: ErrorOr a -> ErrorOr a -> ErrorOr a
<> Error ErrorAcc
e2 = Either ErrorAcc a -> ErrorOr a
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (ErrorAcc -> Either ErrorAcc a
forall a b. a -> Either a b
Left (ErrorAcc -> Either ErrorAcc a) -> ErrorAcc -> Either ErrorAcc a
forall a b. (a -> b) -> a -> b
$ ErrorAcc
e1 ErrorAcc -> ErrorAcc -> ErrorAcc
forall a. Semigroup a => a -> a -> a
<> ErrorAcc
e2)
  OK a
v1 <> OK a
v2 = Either ErrorAcc a -> ErrorOr a
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (a -> Either ErrorAcc a
forall a b. b -> Either a b
Right (a -> Either ErrorAcc a) -> a -> Either ErrorAcc a
forall a b. (a -> b) -> a -> b
$ a
v1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
v2)
  l :: ErrorOr a
l@(ErrorOr (Left ErrorAcc
_)) <> ErrorOr a
_ = ErrorOr a
l
  ErrorOr a
_ <> ErrorOr a
r = ErrorOr a
r

instance (
#if __GLASGOW_HASKELL__ < 880
    Semigroup (ErrorOr a),
#endif
    Monoid a) => Monoid (ErrorOr a) where
  mappend :: ErrorOr a -> ErrorOr a -> ErrorOr a
mappend = ErrorOr a -> ErrorOr a -> ErrorOr a
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: ErrorOr a
mempty = a -> ErrorOr a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

-- | OrError's instances for 'Monad' and 'Applicative' don't align,
-- but the 'Monad' and 'MonadFail' instances are too useful (as in
-- convenient) to pass on.
-- In particular, composing two failing actions using the
-- 'Applicative' instance creates a /composite/ error, where as
-- composing the same two actions using the 'Monad' instance '(>>)'
-- produces only the error from the first action in the sequence. This
-- is a consequence of the fact that for Monads executing the second
-- of two actions ('(>>)' is defined in terms of '(>>=)') requires the result from the first to be passed to
-- the second: the very result that is not available if the first
-- action fails!
instance Monad ErrorOr where
  return :: a -> ErrorOr a
return = a -> ErrorOr a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ErrorOr Either ErrorAcc a
either >>= :: ErrorOr a -> (a -> ErrorOr b) -> ErrorOr b
>>= a -> ErrorOr b
f = Either ErrorAcc b -> ErrorOr b
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (Either ErrorAcc a
either Either ErrorAcc a -> (a -> Either ErrorAcc b) -> Either ErrorAcc b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ErrorOr b -> Either ErrorAcc b)
-> (a -> ErrorOr b) -> a -> Either ErrorAcc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ErrorOr b -> Either ErrorAcc b
forall a. ErrorOr a -> Either ErrorAcc a
errorOrToEither a -> ErrorOr b
f)

instance MonadFail ErrorOr where
  fail :: String -> ErrorOr a
fail = Either ErrorAcc a -> ErrorOr a
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (Either ErrorAcc a -> ErrorOr a)
-> (String -> Either ErrorAcc a) -> String -> ErrorOr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorAcc -> Either ErrorAcc a
forall a b. a -> Either a b
Left (ErrorAcc -> Either ErrorAcc a)
-> (String -> ErrorAcc) -> String -> Either ErrorAcc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ErrorAcc
Message (Text -> ErrorAcc) -> (String -> Text) -> String -> ErrorAcc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

isOK :: ErrorOr a -> Bool
isOK :: ErrorOr a -> Bool
isOK (OK a
_) = Bool
True
isOK ErrorOr a
_ = Bool
False

isError :: ErrorOr a -> Bool
isError :: ErrorOr a -> Bool
isError = Bool -> Bool
not (Bool -> Bool) -> (ErrorOr a -> Bool) -> ErrorOr a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorOr a -> Bool
forall a. ErrorOr a -> Bool
isOK

mapError :: (ErrorAcc -> ErrorAcc) -> ErrorOr a -> ErrorOr a
mapError :: (ErrorAcc -> ErrorAcc) -> ErrorOr a -> ErrorOr a
mapError ErrorAcc -> ErrorAcc
f (ErrorOr (Left ErrorAcc
e)) = Either ErrorAcc a -> ErrorOr a
forall a. Either ErrorAcc a -> ErrorOr a
ErrorOr (ErrorAcc -> Either ErrorAcc a
forall a b. a -> Either a b
Left (ErrorAcc -> ErrorAcc
f ErrorAcc
e))
mapError ErrorAcc -> ErrorAcc
_ ErrorOr a
ok = ErrorOr a
ok

-- | A partial function, like 'fromRight'.
fromOK :: ErrorOr a -> a
fromOK :: ErrorOr a -> a
fromOK (OK a
a) = a
a
fromOK (Error ErrorAcc
err) = String -> a
forall a. HasCallStack => String -> a
error (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Int -> ErrorAcc -> Text
pretty Int
0 ErrorAcc
err)

-- | Convert between functors that hold error info.
class ErrorConv t s where
  toE :: t a -> s a

-- | Convert from ErrorOr to IO. 'toE' throws a 'PrettyErrAcc' if the input holds an error.
instance ErrorConv ErrorOr IO where
  toE :: ErrorOr a -> IO a
toE (OK a
val) = a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val
  toE (Error ErrorAcc
e) = PrettyErrAcc -> IO a
forall e a. Exception e => e -> IO a
Exc.throwIO (ErrorAcc -> PrettyErrAcc
PrettyErrAcc ErrorAcc
e)

-- | Convert from 'Maybe a' to 'ErrorOr a'. It converts 'Nothing' simply to an error
-- with msg "Nothing".
instance ErrorConv Maybe ErrorOr where
  toE :: Maybe a -> ErrorOr a
toE Maybe a
Nothing = String -> ErrorOr a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Nothing"
  toE (Just a
a) = a -> ErrorOr a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a