{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Utils.Decode
  ( withInputObject,
    withEnum,
    withInputUnion,
    decodeFieldWith,
    withScalar,
    handleEither,
    getFieldName,
    DecoderT,
    withKind,
    Info (..),
    Context (..),
    Tag (..),
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.App.Internal.Resolving (ResolverState)
import Data.Morpheus.Internal.Utils
  ( selectOr,
  )
import Data.Morpheus.Server.Types.Internal
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 :: forall (m :: * -> *) a.
MonadError GQLError m =>
(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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
"InputObject" ValidValue
isType)

-- | Useful for more restrictive instances of lists (non empty, size indexed etc)
withEnum :: MonadError GQLError m => (TypeName -> m a) -> Value VALID -> m a
withEnum :: forall (m :: * -> *) a.
MonadError GQLError m =>
(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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (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 :: forall (m :: * -> *) a.
(MonadError GQLError m, Monad m) =>
(TypeName -> ValidObject -> ValidObject -> m a)
-> ValidObject -> m a
withInputUnion TypeName -> ValidObject -> ValidObject -> m a
decoder ValidObject
unions =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a}. GQLError -> m a
onFail (TypeName, ValidValue) -> m a
onSuccess (forall (stage :: Stage).
Object stage -> Either GQLError (TypeName, Value stage)
getInputUnionValue ValidObject
unions)
  where
    onSuccess :: (TypeName, ValidValue) -> m a
onSuccess (TypeName
name, ValidValue
value) = 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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> GQLError
internal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Msg a => a -> GQLError
msg

withScalar ::
  (Applicative m, MonadError GQLError m) =>
  TypeName ->
  (ScalarValue -> Either Token a) ->
  Value VALID ->
  m a
withScalar :: forall (m :: * -> *) a.
(Applicative m, MonadError GQLError m) =>
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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ScalarValue -> Either Token a
decodeScalar of
  Right a
scalar -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
scalar
  Left Token
message ->
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      ( forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch
          (GQLError
"SCALAR(" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
typename forall a. Semigroup a => a -> a -> a
<> GQLError
")" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg Token
message)
          ValidValue
value
      )

decodeFieldWith :: (Value VALID -> m a) -> FieldName -> ValidObject -> m a
decodeFieldWith :: forall (m :: * -> *) a.
(ValidValue -> m a) -> FieldName -> ValidObject -> m a
decodeFieldWith ValidValue -> m a
decoder = forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (ValidValue -> m a
decoder forall (stage :: Stage). Value stage
Null) (ValidValue -> m a
decoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). ObjectEntry s -> Value s
entryValue)

handleEither :: MonadError GQLError m => Either GQLError a -> m a
handleEither :: forall (m :: * -> *) a.
MonadError GQLError m =>
Either GQLError a -> m a
handleEither = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- if value is already validated but value has different type
typeMismatch :: GQLError -> Value s -> GQLError
typeMismatch :: forall (s :: Stage). GQLError -> Value s -> GQLError
typeMismatch GQLError
text Value s
jsType =
  GQLError -> GQLError
internal forall a b. (a -> b) -> a -> b
$
    GQLError
"Type mismatch! expected:"
      forall a. Semigroup a => a -> a -> a
<> GQLError
text
      forall a. Semigroup a => a -> a -> a
<> GQLError
", got: "
      forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg Value s
jsType

getFieldName :: FieldName -> Int -> FieldName
getFieldName :: FieldName -> Int -> FieldName
getFieldName FieldName
"" Int
index = FieldName
"_" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Int
index
getFieldName FieldName
label Int
_ = FieldName
label

data Tag = D_CONS | D_UNION deriving (Tag -> Tag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, Eq Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
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 :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmax :: Tag -> Tag -> Tag
>= :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c< :: Tag -> Tag -> Bool
compare :: Tag -> Tag -> Ordering
$ccompare :: Tag -> Tag -> Ordering
Ord)

data Info = Info
  { Info -> Tag
kind :: Tag,
    Info -> [TypeName]
tagName :: [TypeName]
  }

instance Semigroup Info where
  Info Tag
D_UNION [TypeName]
t1 <> :: Info -> Info -> Info
<> Info Tag
_ [TypeName]
t2 = Tag -> [TypeName] -> Info
Info Tag
D_UNION ([TypeName]
t1 forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)
  Info Tag
_ [TypeName]
t1 <> Info Tag
D_UNION [TypeName]
t2 = Tag -> [TypeName] -> Info
Info Tag
D_UNION ([TypeName]
t1 forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)
  Info Tag
D_CONS [TypeName]
t1 <> Info Tag
D_CONS [TypeName]
t2 = Tag -> [TypeName] -> Info
Info Tag
D_CONS ([TypeName]
t1 forall a. Semigroup a => a -> a -> a
<> [TypeName]
t2)

data Context = Context
  { Context -> Tag
contKind :: Tag,
    Context -> TypeName
typeName :: TypeName,
    Context -> GQLTypeOptions
options :: GQLTypeOptions
  }

type DecoderT = ReaderT Context ResolverState

withKind :: Tag -> DecoderT a -> DecoderT a
withKind :: forall a. Tag -> DecoderT a -> DecoderT a
withKind Tag
contKind = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Context
ctx -> Context
ctx {Tag
contKind :: Tag
contKind :: Tag
contKind})