{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Deriving.Utils.Decode
( withInputObject,
withEnum,
withInputUnion,
decodeFieldWith,
withScalar,
handleEither,
)
where
import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.Internal.Utils
( selectOr,
)
import Data.Morpheus.Types.GQLScalar
( toScalar,
)
import Data.Morpheus.Types.Internal.AST
( FieldName,
GQLError,
Msg (msg),
ObjectEntry (..),
ScalarValue,
Token,
TypeName,
VALID,
ValidObject,
ValidValue,
Value (..),
getInputUnionValue,
internal,
)
import Relude
withInputObject ::
MonadError GQLError m =>
(ValidObject -> m a) ->
ValidValue ->
m a
withInputObject :: (ValidObject -> m a) -> ValidValue -> m a
withInputObject ValidObject -> m a
f (Object ValidObject
object) = ValidObject -> m a
f ValidObject
object
withInputObject ValidObject -> m a
_ ValidValue
isType = GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> ValidValue -> GQLError
forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
"InputObject" ValidValue
isType)
withEnum :: MonadError GQLError m => (TypeName -> m a) -> Value VALID -> m a
withEnum :: (TypeName -> m a) -> ValidValue -> m a
withEnum TypeName -> m a
decode (Enum TypeName
value) = TypeName -> m a
decode TypeName
value
withEnum TypeName -> m a
_ ValidValue
isType = GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> ValidValue -> GQLError
forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
"Enum" ValidValue
isType)
withInputUnion ::
(MonadError GQLError m, Monad m) =>
(TypeName -> ValidObject -> ValidObject -> m a) ->
ValidObject ->
m a
withInputUnion :: (TypeName -> ValidObject -> ValidObject -> m a)
-> ValidObject -> m a
withInputUnion TypeName -> ValidObject -> ValidObject -> m a
decoder ValidObject
unions =
(GQLError -> m a)
-> ((TypeName, ValidValue) -> m a)
-> Either GQLError (TypeName, ValidValue)
-> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GQLError -> m a
forall a. GQLError -> m a
onFail (TypeName, ValidValue) -> m a
onSuccess (ValidObject -> Either GQLError (TypeName, ValidValue)
forall (stage :: Stage).
Object stage -> Either GQLError (TypeName, Value stage)
getInputUnionValue ValidObject
unions)
where
onSuccess :: (TypeName, ValidValue) -> m a
onSuccess (TypeName
name, ValidValue
value) = (ValidObject -> m a) -> ValidValue -> m a
forall (m :: * -> *) a.
MonadError GQLError m =>
(ValidObject -> m a) -> ValidValue -> m a
withInputObject (TypeName -> ValidObject -> ValidObject -> m a
decoder TypeName
name ValidObject
unions) ValidValue
value
onFail :: GQLError -> m a
onFail = GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m a) -> (GQLError -> GQLError) -> GQLError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> GQLError
internal (GQLError -> GQLError)
-> (GQLError -> GQLError) -> GQLError -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> GQLError
forall a. Msg a => a -> GQLError
msg
withScalar ::
(Applicative m, MonadError GQLError m) =>
TypeName ->
(ScalarValue -> Either Token a) ->
Value VALID ->
m a
withScalar :: TypeName -> (ScalarValue -> Either Token a) -> ValidValue -> m a
withScalar TypeName
typename ScalarValue -> Either Token a
decodeScalar ValidValue
value = case ValidValue -> Either Token ScalarValue
toScalar ValidValue
value Either Token ScalarValue
-> (ScalarValue -> Either Token a) -> Either Token a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ScalarValue -> Either Token a
decodeScalar of
Right a
scalar -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
scalar
Left Token
message ->
GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
( GQLError -> ValidValue -> GQLError
forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch
(GQLError
"SCALAR(" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
typename GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
")" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Token -> GQLError
forall a. Msg a => a -> GQLError
msg Token
message)
ValidValue
value
)
decodeFieldWith :: (Value VALID -> m a) -> FieldName -> ValidObject -> m a
decodeFieldWith :: (ValidValue -> m a) -> FieldName -> ValidObject -> m a
decodeFieldWith ValidValue -> m a
decoder = m a
-> (ObjectEntry VALID -> m a) -> FieldName -> ValidObject -> m a
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (ValidValue -> m a
decoder ValidValue
forall (stage :: Stage). Value stage
Null) (ValidValue -> m a
decoder (ValidValue -> m a)
-> (ObjectEntry VALID -> ValidValue) -> ObjectEntry VALID -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectEntry VALID -> ValidValue
forall (s :: Stage). ObjectEntry s -> Value s
entryValue)
handleEither :: MonadError GQLError m => Either GQLError a -> m a
handleEither :: Either GQLError a -> m a
handleEither = (GQLError -> m a) -> (a -> m a) -> Either GQLError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
typeMismatch :: GQLError -> Value s -> GQLError
typeMismatch :: GQLError -> Value s -> GQLError
typeMismatch GQLError
text Value s
jsType =
GQLError -> GQLError
internal (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$
GQLError
"Type mismatch! expected:" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
text GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
", got: "
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Value s -> GQLError
forall a. Msg a => a -> GQLError
msg Value s
jsType