{-# 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 (..),
  )
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 {forall err a. Result err a -> a
result :: a, forall err a. Result err a -> [err]
warnings :: [err]}
  | Failure {forall err a. Result err a -> NonEmpty err
errors :: NonEmpty err}
  deriving (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
<$ :: forall a b. a -> Result err b -> Result err a
$c<$ :: forall err a b. a -> Result err b -> Result err a
fmap :: forall a b. (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 :: forall a. a -> Result er a
pure a
x = forall err a. a -> [err] -> Result err a
Success a
x []
  Success a -> b
f [er]
w1 <*> :: forall a b. Result er (a -> b) -> Result er a -> Result er b
<*> Success a
x [er]
w2 = forall err a. a -> [err] -> Result err a
Success (a -> b
f a
x) ([er]
w1 forall a. Semigroup a => a -> a -> a
<> [er]
w2)
  Failure NonEmpty er
e1 <*> Failure NonEmpty er
e2 = forall err a. NonEmpty err -> Result err a
Failure (NonEmpty er
e1 forall a. Semigroup a => a -> a -> a
<> NonEmpty er
e2)
  Failure (er
e :| [er]
es) <*> Success a
_ [er]
w = forall err a. NonEmpty err -> Result err a
Failure (er
e forall a. a -> [a] -> NonEmpty a
:| [er]
es forall a. Semigroup a => a -> a -> a
<> [er]
w)
  Success a -> b
_ [er]
w <*> Failure (er
e :| [er]
es) = forall err a. NonEmpty err -> Result err a
Failure (er
e forall a. a -> [a] -> NonEmpty a
:| [er]
es forall a. Semigroup a => a -> a -> a
<> [er]
w)

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

instance Bifunctor Result where
  bimap :: forall a b c d. (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 {warnings :: [b]
warnings = a -> b
f 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
..} = forall err a. NonEmpty err -> Result err a
Failure (a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty a
errors)

instance MonadError er (Result er) where
  throwError :: forall a. er -> Result er a
throwError = forall err a. NonEmpty err -> Result err a
Failure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  catchError :: forall a. 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 :: forall a. String -> Result err a
fail = forall err a. NonEmpty err -> Result err a
Failure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

resultOr :: (NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr :: forall err a' a.
(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 :: forall a. Result GQLError a -> Result GQLError a
sortErrors (Failure NonEmpty GQLError
errors) = forall err a. NonEmpty err -> Result err a
Failure (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
  { forall event (m :: * -> *) a.
ResultT event m a -> m (Result GQLError ([event], a))
runResultT :: m (Result GQLError ([event], a))
  }
  deriving (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
<$ :: forall a b. 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 :: forall a b. (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 :: forall a. a -> ResultT event m a
pure = forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([],)
  ResultT m (Result GQLError ([event], a -> b))
app1 <*> :: forall a b.
ResultT event m (a -> b) -> ResultT event m a -> ResultT event m b
<*> ResultT m (Result GQLError ([event], a))
app2 = forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (forall (f :: * -> *) event a b.
Monad f =>
f ([event], a -> b) -> f (([event], a) -> ([event], b))
fx 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 :: forall (f :: * -> *) event a b.
Monad f =>
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
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \([event]
e, a
a) -> ([event]
e forall a. Semigroup a => a -> a -> a
<> [event]
e', a -> b
f a
a)

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

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

instance Monad m => MonadError GQLError (ResultT event m) where
  throwError :: forall a. GQLError -> ResultT event m a
throwError = forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a.
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 = forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT (m (Result GQLError ([event], a))
mx 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]
_)) = 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 = 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 = forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ([event]
x, ())

cleanEvents ::
  Functor m =>
  ResultT e m a ->
  ResultT e' m a
cleanEvents :: forall (m :: * -> *) e a e'.
Functor m =>
ResultT e m a -> ResultT e' m a
cleanEvents ResultT e m a
resT = forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. a -> b -> a
const [])) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *) e e' value.
Monad m =>
(e -> e') -> ResultT e m value -> ResultT e' m value
mapEvent e -> e'
func (ResultT m (Result GQLError ([e], value))
ma) = forall event (m :: * -> *) a.
m (Result GQLError ([event], a)) -> ResultT event m a
ResultT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. (a -> b) -> [a] -> [b]
map e -> e'
func)) 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 :: forall err b. Result err b -> Either (NonEmpty err) b
toEither = forall err a' a.
(NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr forall a b. a -> Either a b
Left forall a b. b -> Either a b
Right