{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Ext.Result
  ( Result (..),
    ResultT (..),
    mapEvent,
    cleanEvents,
    PushEvents (..),
    resultOr,
    sortErrors,
    toEither,
    GQLResult,
  )
where

import Control.Monad.Except (MonadError (..))
import qualified Data.List.NonEmpty as NE
import Data.Morpheus.Types.Internal.AST.Error
  ( GQLError (..),
    GQLError,
  )
import Data.Text.Lazy.Builder ()
import Relude

type GQLResult = Result GQLError

-- EVENTS
class PushEvents e m where
  pushEvents :: [e] -> m ()

--
-- Result
--
--
data Result err a
  = Success {Result err a -> a
result :: a, Result err a -> [err]
warnings :: [err]}
  | Failure {Result err a -> NonEmpty err
errors :: NonEmpty err}
  deriving (a -> Result err b -> Result err a
(a -> b) -> Result err a -> Result err b
(forall a b. (a -> b) -> Result err a -> Result err b)
-> (forall a b. a -> Result err b -> Result err a)
-> Functor (Result err)
forall a b. a -> Result err b -> Result err a
forall a b. (a -> b) -> Result err a -> Result err b
forall err a b. a -> Result err b -> Result err a
forall err a b. (a -> b) -> Result err a -> Result err b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Result err b -> Result err a
$c<$ :: forall err a b. a -> Result err b -> Result err a
fmap :: (a -> b) -> Result err a -> Result err b
$cfmap :: forall err a b. (a -> b) -> Result err a -> Result err b
Functor)

instance Applicative (Result er) where
  pure :: a -> Result er a
pure a
x = a -> [er] -> Result er a
forall err a. a -> [err] -> Result err a
Success a
x []
  Success a -> b
f [er]
w1 <*> :: Result er (a -> b) -> Result er a -> Result er b
<*> Success a
x [er]
w2 = b -> [er] -> Result er b
forall err a. a -> [err] -> Result err a
Success (a -> b
f a
x) ([er]
w1 [er] -> [er] -> [er]
forall a. Semigroup a => a -> a -> a
<> [er]
w2)
  Failure NonEmpty er
e1 <*> Failure NonEmpty er
e2 = NonEmpty er -> Result er b
forall err a. NonEmpty err -> Result err a
Failure (NonEmpty er
e1 NonEmpty er -> NonEmpty er -> NonEmpty er
forall a. Semigroup a => a -> a -> a
<> NonEmpty er
e2)
  Failure (er
e :| [er]
es) <*> Success a
_ [er]
w = NonEmpty er -> Result er b
forall err a. NonEmpty err -> Result err a
Failure (er
e er -> [er] -> NonEmpty er
forall a. a -> [a] -> NonEmpty a
:| [er]
es [er] -> [er] -> [er]
forall a. Semigroup a => a -> a -> a
<> [er]
w)
  Success a -> b
_ [er]
w <*> Failure (er
e :| [er]
es) = NonEmpty er -> Result er b
forall err a. NonEmpty err -> Result err a
Failure (er
e er -> [er] -> NonEmpty er
forall a. a -> [a] -> NonEmpty a
:| [er]
es [er] -> [er] -> [er]
forall a. Semigroup a => a -> a -> a
<> [er]
w)

instance Monad (Result er) where
  return :: a -> Result er a
return = a -> Result er a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Success a
v [er]
w1 >>= :: Result er a -> (a -> Result er b) -> Result er b
>>= a -> Result er b
fm = case a -> Result er b
fm a
v of
    (Success b
x [er]
w2) -> b -> [er] -> Result er b
forall err a. a -> [err] -> Result err a
Success b
x ([er]
w1 [er] -> [er] -> [er]
forall a. Semigroup a => a -> a -> a
<> [er]
w2)
    (Failure (er
e :| [er]
es)) -> NonEmpty er -> Result er b
forall err a. NonEmpty err -> Result err a
Failure (er
e er -> [er] -> NonEmpty er
forall a. a -> [a] -> NonEmpty a
:| [er]
es [er] -> [er] -> [er]
forall a. Semigroup a => a -> a -> a
<> [er]
w1)
  Failure NonEmpty er
e >>= a -> Result er b
_ = NonEmpty er -> Result er b
forall err a. NonEmpty err -> Result err a
Failure NonEmpty er
e

instance Bifunctor Result where
  bimap :: (a -> b) -> (c -> d) -> Result a c -> Result b d
bimap a -> b
f c -> d
g Success {c
[a]
warnings :: [a]
result :: c
warnings :: forall err a. Result err a -> [err]
result :: forall err a. Result err a -> a
..} = Success :: forall err a. a -> [err] -> Result err a
Success {warnings :: [b]
warnings = a -> b
f (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
warnings, result :: d
result = c -> d
g c
result, ..}
  bimap a -> b
f c -> d
_ Failure {NonEmpty a
errors :: NonEmpty a
errors :: forall err a. Result err a -> NonEmpty err
..} = NonEmpty b -> Result b d
forall err a. NonEmpty err -> Result err a
Failure (a -> b
f (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty a
errors)

instance MonadError er (Result er) where
  throwError :: er -> Result er a
throwError = NonEmpty er -> Result er a
forall err a. NonEmpty err -> Result err a
Failure (NonEmpty er -> Result er a)
-> (er -> NonEmpty er) -> er -> Result er a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. er -> NonEmpty er
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  catchError :: Result er a -> (er -> Result er a) -> Result er a
catchError (Failure (er
x :| [er]
_)) er -> Result er a
f = er -> Result er a
f er
x
  catchError Result er a
x er -> Result er a
_ = Result er a
x

instance IsString err => MonadFail (Result err) where
  fail :: String -> Result err a
fail = NonEmpty err -> Result err a
forall err a. NonEmpty err -> Result err a
Failure (NonEmpty err -> Result err a)
-> (String -> NonEmpty err) -> String -> Result err a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> NonEmpty err
forall (f :: * -> *) a. Applicative f => a -> f a
pure (err -> NonEmpty err) -> (String -> err) -> String -> NonEmpty err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> err
forall a. IsString a => String -> a
fromString

resultOr :: (NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr :: (NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr NonEmpty err -> a'
_ a -> a'
f Success {a
result :: a
result :: forall err a. Result err a -> a
result} = a -> a'
f a
result
resultOr NonEmpty err -> a'
f a -> a'
_ Failure {NonEmpty err
errors :: NonEmpty err
errors :: forall err a. Result err a -> NonEmpty err
errors} = NonEmpty err -> a'
f NonEmpty err
errors

sortErrors :: Result GQLError a -> Result GQLError a
sortErrors :: Result GQLError a -> Result GQLError a
sortErrors (Failure NonEmpty GQLError
errors) = NonEmpty GQLError -> Result GQLError a
forall err a. NonEmpty err -> Result err a
Failure (NonEmpty GQLError -> NonEmpty GQLError
forall a. Ord a => NonEmpty a -> NonEmpty a
NE.sort NonEmpty GQLError
errors)
sortErrors Result GQLError a
x = Result GQLError a
x

-- ResultT
newtype ResultT event (m :: Type -> Type) a = ResultT
  { ResultT event m a -> m (Result GQLError ([event], a))
runResultT :: m (Result GQLError ([event], a))
  }
  deriving (a -> ResultT event m b -> ResultT event m a
(a -> b) -> ResultT event m a -> ResultT event m b
(forall a b. (a -> b) -> ResultT event m a -> ResultT event m b)
-> (forall a b. a -> ResultT event m b -> ResultT event m a)
-> Functor (ResultT event m)
forall a b. a -> ResultT event m b -> ResultT event m a
forall a b. (a -> b) -> ResultT event m a -> ResultT event m b
forall event (m :: * -> *) a b.
Functor m =>
a -> ResultT event m b -> ResultT event m a
forall event (m :: * -> *) a b.
Functor m =>
(a -> b) -> ResultT event m a -> ResultT event m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ResultT event m b -> ResultT event m a
$c<$ :: forall event (m :: * -> *) a b.
Functor m =>
a -> ResultT event m b -> ResultT event m a
fmap :: (a -> b) -> ResultT event m a -> ResultT event m b
$cfmap :: forall event (m :: * -> *) a b.
Functor m =>
(a -> b) -> ResultT event m a -> ResultT event m b
Functor)

instance Applicative m => Applicative (ResultT event m) where
  pure :: a -> ResultT event m a
pure = m (Result GQLError ([event], a)) -> ResultT event m a
forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([event], a)) -> ResultT event m a)
-> (a -> m (Result GQLError ([event], a)))
-> a
-> ResultT event m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result GQLError ([event], a) -> m (Result GQLError ([event], a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result GQLError ([event], a) -> m (Result GQLError ([event], a)))
-> (a -> Result GQLError ([event], a))
-> a
-> m (Result GQLError ([event], a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([event], a) -> Result GQLError ([event], a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([event], a) -> Result GQLError ([event], a))
-> (a -> ([event], a)) -> a -> Result GQLError ([event], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([],)
  ResultT m (Result GQLError ([event], a -> b))
app1 <*> :: ResultT event m (a -> b) -> ResultT event m a -> ResultT event m b
<*> ResultT m (Result GQLError ([event], a))
app2 = m (Result GQLError ([event], b)) -> ResultT event m b
forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([event], b)) -> ResultT event m b)
-> m (Result GQLError ([event], b)) -> ResultT event m b
forall a b. (a -> b) -> a -> b
$ (Result GQLError (([event], a) -> ([event], b))
 -> Result GQLError ([event], a) -> Result GQLError ([event], b))
-> m (Result GQLError (([event], a) -> ([event], b)))
-> m (Result GQLError ([event], a))
-> m (Result GQLError ([event], b))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Result GQLError (([event], a) -> ([event], b))
-> Result GQLError ([event], a) -> Result GQLError ([event], b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (Result GQLError ([event], a -> b)
-> Result GQLError (([event], a) -> ([event], b))
forall (f :: * -> *) event a b.
Monad f =>
f ([event], a -> b) -> f (([event], a) -> ([event], b))
fx (Result GQLError ([event], a -> b)
 -> Result GQLError (([event], a) -> ([event], b)))
-> m (Result GQLError ([event], a -> b))
-> m (Result GQLError (([event], a) -> ([event], b)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Result GQLError ([event], a -> b))
app1) m (Result GQLError ([event], a))
app2
    where
      fx :: Monad f => f ([event], a -> b) -> f (([event], a) -> ([event], b))
      fx :: f ([event], a -> b) -> f (([event], a) -> ([event], b))
fx f ([event], a -> b)
x = do
        ([event]
e', a -> b
f) <- f ([event], a -> b)
x
        (([event], a) -> ([event], b)) -> f (([event], a) -> ([event], b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((([event], a) -> ([event], b))
 -> f (([event], a) -> ([event], b)))
-> (([event], a) -> ([event], b))
-> f (([event], a) -> ([event], b))
forall a b. (a -> b) -> a -> b
$ \([event]
e, a
a) -> ([event]
e [event] -> [event] -> [event]
forall a. Semigroup a => a -> a -> a
<> [event]
e', a -> b
f a
a)

instance Monad m => Monad (ResultT event m) where
  return :: a -> ResultT event m a
return = a -> ResultT event m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (ResultT m (Result GQLError ([event], a))
m1) >>= :: ResultT event m a -> (a -> ResultT event m b) -> ResultT event m b
>>= a -> ResultT event m b
mFunc = m (Result GQLError ([event], b)) -> ResultT event m b
forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([event], b)) -> ResultT event m b)
-> m (Result GQLError ([event], b)) -> ResultT event m b
forall a b. (a -> b) -> a -> b
$ do
    Result GQLError ([event], a)
result <- m (Result GQLError ([event], a))
m1
    case Result GQLError ([event], a)
result of
      Failure NonEmpty GQLError
errors -> Result GQLError ([event], b) -> m (Result GQLError ([event], b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result GQLError ([event], b) -> m (Result GQLError ([event], b)))
-> Result GQLError ([event], b) -> m (Result GQLError ([event], b))
forall a b. (a -> b) -> a -> b
$ NonEmpty GQLError -> Result GQLError ([event], b)
forall err a. NonEmpty err -> Result err a
Failure NonEmpty GQLError
errors
      Success ([event]
events, a
value) [GQLError]
w1 -> do
        Result GQLError ([event], b)
result' <- ResultT event m b -> m (Result GQLError ([event], b))
forall event (m :: * -> *) a.
ResultT event m a -> m (Result GQLError ([event], a))
runResultT (a -> ResultT event m b
mFunc a
value)
        case Result GQLError ([event], b)
result' of
          Failure (GQLError
e :| [GQLError]
es) -> Result GQLError ([event], b) -> m (Result GQLError ([event], b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result GQLError ([event], b) -> m (Result GQLError ([event], b)))
-> Result GQLError ([event], b) -> m (Result GQLError ([event], b))
forall a b. (a -> b) -> a -> b
$ NonEmpty GQLError -> Result GQLError ([event], b)
forall err a. NonEmpty err -> Result err a
Failure (GQLError
e GQLError -> [GQLError] -> NonEmpty GQLError
forall a. a -> [a] -> NonEmpty a
:| [GQLError]
es [GQLError] -> [GQLError] -> [GQLError]
forall a. Semigroup a => a -> a -> a
<> [GQLError]
w1)
          Success ([event]
events', b
value') [GQLError]
w2 -> Result GQLError ([event], b) -> m (Result GQLError ([event], b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result GQLError ([event], b) -> m (Result GQLError ([event], b)))
-> Result GQLError ([event], b) -> m (Result GQLError ([event], b))
forall a b. (a -> b) -> a -> b
$ ([event], b) -> [GQLError] -> Result GQLError ([event], b)
forall err a. a -> [err] -> Result err a
Success ([event]
events [event] -> [event] -> [event]
forall a. Semigroup a => a -> a -> a
<> [event]
events', b
value') ([GQLError]
w1 [GQLError] -> [GQLError] -> [GQLError]
forall a. Semigroup a => a -> a -> a
<> [GQLError]
w2)

instance MonadTrans (ResultT event) where
  lift :: m a -> ResultT event m a
lift = m (Result GQLError ([event], a)) -> ResultT event m a
forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([event], a)) -> ResultT event m a)
-> (m a -> m (Result GQLError ([event], a)))
-> m a
-> ResultT event m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Result GQLError ([event], a))
-> m a -> m (Result GQLError ([event], a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([event], a) -> Result GQLError ([event], a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([event], a) -> Result GQLError ([event], a))
-> (a -> ([event], a)) -> a -> Result GQLError ([event], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([],))

instance Monad m => MonadError GQLError (ResultT event m) where
  throwError :: GQLError -> ResultT event m a
throwError = m (Result GQLError ([event], a)) -> ResultT event m a
forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([event], a)) -> ResultT event m a)
-> (GQLError -> m (Result GQLError ([event], a)))
-> GQLError
-> ResultT event m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result GQLError ([event], a) -> m (Result GQLError ([event], a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result GQLError ([event], a) -> m (Result GQLError ([event], a)))
-> (GQLError -> Result GQLError ([event], a))
-> GQLError
-> m (Result GQLError ([event], a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> Result GQLError ([event], a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: ResultT event m a
-> (GQLError -> ResultT event m a) -> ResultT event m a
catchError (ResultT m (Result GQLError ([event], a))
mx) GQLError -> ResultT event m a
f = m (Result GQLError ([event], a)) -> ResultT event m a
forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([event], a))
mx m (Result GQLError ([event], a))
-> (Result GQLError ([event], a)
    -> m (Result GQLError ([event], a)))
-> m (Result GQLError ([event], a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result GQLError ([event], a) -> m (Result GQLError ([event], a))
catchResultError)
    where
      catchResultError :: Result GQLError ([event], a) -> m (Result GQLError ([event], a))
catchResultError (Failure (GQLError
x :| [GQLError]
_)) = ResultT event m a -> m (Result GQLError ([event], a))
forall event (m :: * -> *) a.
ResultT event m a -> m (Result GQLError ([event], a))
runResultT (GQLError -> ResultT event m a
f GQLError
x)
      catchResultError Result GQLError ([event], a)
x = Result GQLError ([event], a) -> m (Result GQLError ([event], a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result GQLError ([event], a)
x

instance Applicative m => PushEvents event (ResultT event m) where
  pushEvents :: [event] -> ResultT event m ()
pushEvents [event]
x = m (Result GQLError ([event], ())) -> ResultT event m ()
forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([event], ())) -> ResultT event m ())
-> m (Result GQLError ([event], ())) -> ResultT event m ()
forall a b. (a -> b) -> a -> b
$ Result GQLError ([event], ()) -> m (Result GQLError ([event], ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result GQLError ([event], ())
 -> m (Result GQLError ([event], ())))
-> Result GQLError ([event], ())
-> m (Result GQLError ([event], ()))
forall a b. (a -> b) -> a -> b
$ ([event], ()) -> Result GQLError ([event], ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([event]
x, ())

cleanEvents ::
  Functor m =>
  ResultT e m a ->
  ResultT e' m a
cleanEvents :: ResultT e m a -> ResultT e' m a
cleanEvents ResultT e m a
resT = m (Result GQLError ([e'], a)) -> ResultT e' m a
forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([e'], a)) -> ResultT e' m a)
-> m (Result GQLError ([e'], a)) -> ResultT e' m a
forall a b. (a -> b) -> a -> b
$ (([e], a) -> ([e'], a))
-> Result GQLError ([e], a) -> Result GQLError ([e'], a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([e] -> [e']) -> ([e], a) -> ([e'], a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([e'] -> [e] -> [e']
forall a b. a -> b -> a
const [])) (Result GQLError ([e], a) -> Result GQLError ([e'], a))
-> m (Result GQLError ([e], a)) -> m (Result GQLError ([e'], a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResultT e m a -> m (Result GQLError ([e], a))
forall event (m :: * -> *) a.
ResultT event m a -> m (Result GQLError ([event], a))
runResultT ResultT e m a
resT

mapEvent ::
  Monad m =>
  (e -> e') ->
  ResultT e m value ->
  ResultT e' m value
mapEvent :: (e -> e') -> ResultT e m value -> ResultT e' m value
mapEvent e -> e'
func (ResultT m (Result GQLError ([e], value))
ma) = m (Result GQLError ([e'], value)) -> ResultT e' m value
forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([e'], value)) -> ResultT e' m value)
-> m (Result GQLError ([e'], value)) -> ResultT e' m value
forall a b. (a -> b) -> a -> b
$ (([e], value) -> ([e'], value))
-> Result GQLError ([e], value) -> Result GQLError ([e'], value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([e] -> [e']) -> ([e], value) -> ([e'], value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((e -> e') -> [e] -> [e']
forall a b. (a -> b) -> [a] -> [b]
map e -> e'
func)) (Result GQLError ([e], value) -> Result GQLError ([e'], value))
-> m (Result GQLError ([e], value))
-> m (Result GQLError ([e'], value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Result GQLError ([e], value))
ma

toEither :: Result err b -> Either (NonEmpty err) b
toEither :: Result err b -> Either (NonEmpty err) b
toEither = (NonEmpty err -> Either (NonEmpty err) b)
-> (b -> Either (NonEmpty err) b)
-> Result err b
-> Either (NonEmpty err) b
forall err a' a.
(NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr NonEmpty err -> Either (NonEmpty err) b
forall a b. a -> Either a b
Left b -> Either (NonEmpty err) b
forall a b. b -> Either a b
Right