{-# 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 {result :: a, warnings :: [err]}
| Failure {errors :: NonEmpty err}
deriving (Functor)
instance Applicative (Result er) where
pure x = Success x []
Success f w1 <*> Success x w2 = Success (f x) (w1 <> w2)
Failure e1 <*> Failure e2 = Failure (e1 <> e2)
Failure (e :| es) <*> Success _ w = Failure (e :| es <> w)
Success _ w <*> Failure (e :| es) = Failure (e :| es <> w)
instance Monad (Result er) where
return = pure
Success v w1 >>= fm = case fm v of
(Success x w2) -> Success x (w1 <> w2)
(Failure (e :| es)) -> Failure (e :| es <> w1)
Failure e >>= _ = Failure e
instance Bifunctor Result where
bimap f g Success {..} = Success {warnings = f <$> warnings, result = g result, ..}
bimap f _ Failure {..} = Failure (f <$> errors)
instance MonadError er (Result er) where
throwError = Failure . pure
catchError (Failure (x :| _)) f = f x
catchError x _ = x
instance (IsString err) => MonadFail (Result err) where
fail = Failure . pure . fromString
resultOr :: (NonEmpty err -> a') -> (a -> a') -> Result err a -> a'
resultOr _ f Success {result} = f result
resultOr f _ Failure {errors} = f errors
sortErrors :: Result GQLError a -> Result GQLError a
sortErrors (Failure errors) = Failure (NE.sort errors)
sortErrors x = x
-- ResultT
newtype ResultT event (m :: Type -> Type) a = ResultT
{ runResultT :: m (Result GQLError ([event], a))
}
deriving (Functor)
instance (Applicative m) => Applicative (ResultT event m) where
pure = ResultT . pure . pure . ([],)
ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) (fx <$> app1) app2
where
fx :: (Monad f) => f ([event], a -> b) -> f (([event], a) -> ([event], b))
fx x = do
(e', f) <- x
pure $ \(e, a) -> (e <> e', f a)
instance (Monad m) => Monad (ResultT event m) where
return = pure
(ResultT m1) >>= mFunc = ResultT $ do
result <- m1
case result of
Failure errors -> pure $ Failure errors
Success (events, value) w1 -> do
result' <- runResultT (mFunc value)
case result' of
Failure (e :| es) -> pure $ Failure (e :| es <> w1)
Success (events', value') w2 -> pure $ Success (events <> events', value') (w1 <> w2)
instance MonadTrans (ResultT event) where
lift = ResultT . fmap (pure . ([],))
instance (Monad m) => MonadError GQLError (ResultT event m) where
throwError = ResultT . pure . throwError
catchError (ResultT mx) f = ResultT (mx >>= catchResultError)
where
catchResultError (Failure (x :| _)) = runResultT (f x)
catchResultError x = pure x
instance (Applicative m) => PushEvents event (ResultT event m) where
pushEvents x = ResultT $ pure $ pure (x, ())
cleanEvents ::
(Functor m) =>
ResultT e m a ->
ResultT e' m a
cleanEvents resT = ResultT $ fmap (first (const [])) <$> runResultT resT
mapEvent ::
(Monad m) =>
(e -> e') ->
ResultT e m value ->
ResultT e' m value
mapEvent func (ResultT ma) = ResultT $ fmap (first (map func)) <$> ma
toEither :: Result err b -> Either (NonEmpty err) b
toEither = resultOr Left Right