{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Decode
  ( decodeArguments,
    Decode,
    decode,
  )
where

import Control.Monad.Except (MonadError (throwError))
import qualified Data.Map as M
import Data.Morpheus.App.Internal.Resolving
  ( ResolverState,
  )
import Data.Morpheus.Server.Deriving.Schema.Directive (visitEnumName, visitFieldName)
import Data.Morpheus.Server.Deriving.Utils
  ( selNameProxy,
    symbolName,
  )
import Data.Morpheus.Server.Deriving.Utils.Decode
  ( Context (..),
    DecoderT,
    DescribeCons,
    DescribeFields (countFields),
    decodeFieldWith,
    getFieldName,
    getUnionInfos,
    handleEither,
    setVariantRef,
    withInputObject,
    withInputUnion,
    withScalar,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( KindedProxy (..),
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType
      ( KIND
      ),
    deriveTypename,
  )
import Data.Morpheus.Server.Types.Kind
  ( CUSTOM,
    DerivingKind,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.Server.Types.Types (Arg (Arg))
import Data.Morpheus.Types.GQLScalar
  ( DecodeScalar (..),
  )
import Data.Morpheus.Types.GQLWrapper
  ( DecodeWrapper (..),
    DecodeWrapperConstraint,
  )
import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    Arguments,
    IN,
    LEAF,
    Object,
    ObjectEntry (..),
    TypeName,
    VALID,
    ValidObject,
    ValidValue,
    Value (..),
    internal,
    msg,
  )
import GHC.Generics
import GHC.TypeLits (KnownSymbol)
import Relude

-- GENERIC
decodeArguments :: forall a. Decode a => Arguments VALID -> ResolverState a
decodeArguments :: forall a. Decode a => Arguments VALID -> ResolverState a
decodeArguments = forall a. Decode a => ValidValue -> ResolverState a
decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stage :: Stage). Object stage -> Value stage
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {s :: Stage}. Argument s -> ObjectEntry s
toEntry
  where
    toEntry :: Argument s -> ObjectEntry s
toEntry Argument {Value s
FieldName
Position
argumentPosition :: forall (valid :: Stage). Argument valid -> Position
argumentName :: forall (valid :: Stage). Argument valid -> FieldName
argumentValue :: forall (valid :: Stage). Argument valid -> Value valid
argumentValue :: Value s
argumentName :: FieldName
argumentPosition :: Position
..} = forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
argumentName Value s
argumentValue

type Decode a = (DecodeKind (KIND a) a)

decode :: forall a. Decode a => ValidValue -> ResolverState a
decode :: forall a. Decode a => ValidValue -> ResolverState a
decode = forall (kind :: DerivingKind) a.
DecodeKind kind a =>
Proxy kind -> ValidValue -> ResolverState a
decodeKind (forall {k} (t :: k). Proxy t
Proxy @(KIND a))

-- | Decode GraphQL type with Specific Kind
class DecodeKind (kind :: DerivingKind) a where
  decodeKind :: Proxy kind -> ValidValue -> ResolverState a

-- SCALAR
instance (DecodeScalar a, GQLType a) => DecodeKind SCALAR a where
  decodeKind :: Proxy SCALAR -> ValidValue -> ResolverState a
decodeKind Proxy SCALAR
_ = forall (m :: * -> *) a.
(Applicative m, MonadError GQLError m) =>
TypeName -> (ScalarValue -> Either Token a) -> ValidValue -> m a
withScalar (forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeName
deriveTypename (forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy LEAF a)) forall a. DecodeScalar a => ScalarValue -> Either Token a
decodeScalar

-- INPUT_OBJECT and  INPUT_UNION
instance
  ( Generic a,
    GQLType a,
    DecodeRep (Rep a)
  ) =>
  DecodeKind TYPE a
  where
  decodeKind :: Proxy TYPE -> ValidValue -> ResolverState a
decodeKind Proxy TYPE
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Context
context) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep
    where
      context :: Context
context =
        Context
          { isVariantRef :: Bool
isVariantRef = Bool
False,
            typeName :: TypeName
typeName = forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeName
deriveTypename (forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy IN a),
            enumVisitor :: TypeName -> TypeName
enumVisitor = forall a (f :: * -> *). GQLType a => f a -> TypeName -> TypeName
visitEnumName Proxy a
proxy,
            fieldVisitor :: FieldName -> FieldName
fieldVisitor = forall a (f :: * -> *). GQLType a => f a -> FieldName -> FieldName
visitFieldName Proxy a
proxy
          }
        where
          proxy :: Proxy a
proxy = forall {k} (t :: k). Proxy t
Proxy @a

instance (Decode a, DecodeWrapperConstraint f a, DecodeWrapper f) => DecodeKind WRAPPER (f a) where
  decodeKind :: Proxy WRAPPER -> ValidValue -> ResolverState (f a)
decodeKind Proxy WRAPPER
_ ValidValue
value =
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall (f :: * -> *) (m :: * -> *) a.
(DecodeWrapper f, Monad m, DecodeWrapperConstraint f a) =>
(ValidValue -> m a) -> ValidValue -> ExceptT GQLError m (f a)
decodeWrapper forall a. Decode a => ValidValue -> ResolverState a
decode ValidValue
value)
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
MonadError GQLError m =>
Either GQLError a -> m a
handleEither

instance (Decode a, KnownSymbol name) => DecodeKind CUSTOM (Arg name a) where
  decodeKind :: Proxy CUSTOM -> ValidValue -> ResolverState (Arg name a)
decodeKind Proxy CUSTOM
_ ValidValue
value = forall (name :: Symbol) a. a -> Arg name a
Arg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
MonadError GQLError m =>
(ValidObject -> m a) -> ValidValue -> m a
withInputObject ValidObject -> ResolverStateT () Identity a
fieldDecoder ValidValue
value
    where
      fieldDecoder :: ValidObject -> ResolverStateT () Identity a
fieldDecoder = forall (m :: * -> *) a.
(ValidValue -> m a) -> FieldName -> ValidObject -> m a
decodeFieldWith forall a. Decode a => ValidValue -> ResolverState a
decode FieldName
fieldName
      fieldName :: FieldName
fieldName = forall (a :: Symbol) (f :: Symbol -> *).
KnownSymbol a =>
f a -> FieldName
symbolName (forall {k} (t :: k). Proxy t
Proxy @name)

--  Map
instance (Ord k, Decode (k, v)) => DecodeKind CUSTOM (Map k v) where
  decodeKind :: Proxy CUSTOM -> ValidValue -> ResolverState (Map k v)
decodeKind Proxy CUSTOM
_ ValidValue
v = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Decode a => ValidValue -> ResolverState a
decode ValidValue
v :: ResolverState [(k, v)])

decideEither ::
  (DecodeRep f, DecodeRep g) =>
  ([TypeName], [TypeName]) ->
  TypeName ->
  ValidValue ->
  DecoderT ((f :+: g) a)
decideEither :: forall (f :: * -> *) (g :: * -> *) a.
(DecodeRep f, DecodeRep g) =>
([TypeName], [TypeName])
-> TypeName -> ValidValue -> DecoderT ((:+:) f g a)
decideEither ([TypeName]
left, [TypeName]
right) TypeName
name ValidValue
value
  | TypeName
name forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
left = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep ValidValue
value
  | TypeName
name forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
right = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep ValidValue
value
  | Bool
otherwise =
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
        GQLError -> GQLError
internal forall a b. (a -> b) -> a -> b
$
          GQLError
"Constructor \""
            forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
name
            forall a. Semigroup a => a -> a -> a
<> GQLError
"\" could not find in Union"

decodeInputUnionObject ::
  (DecodeRep f, DecodeRep g) =>
  ([TypeName], [TypeName]) ->
  TypeName ->
  Object VALID ->
  ValidObject ->
  DecoderT ((f :+: g) a)
decodeInputUnionObject :: forall (f :: * -> *) (g :: * -> *) a.
(DecodeRep f, DecodeRep g) =>
([TypeName], [TypeName])
-> TypeName -> ValidObject -> ValidObject -> DecoderT ((:+:) f g a)
decodeInputUnionObject ([TypeName]
l, [TypeName]
r) TypeName
name ValidObject
unions ValidObject
object
  | [TypeName
name] forall a. Eq a => a -> a -> Bool
== [TypeName]
l = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep (forall (stage :: Stage). Object stage -> Value stage
Object ValidObject
object)
  | [TypeName
name] forall a. Eq a => a -> a -> Bool
== [TypeName]
r = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep (forall (stage :: Stage). Object stage -> Value stage
Object ValidObject
object)
  | Bool
otherwise = forall (f :: * -> *) (g :: * -> *) a.
(DecodeRep f, DecodeRep g) =>
([TypeName], [TypeName])
-> TypeName -> ValidValue -> DecoderT ((:+:) f g a)
decideEither ([TypeName]
l, [TypeName]
r) TypeName
name (forall (stage :: Stage). Object stage -> Value stage
Object ValidObject
unions)

class DecodeRep (f :: Type -> Type) where
  decodeRep :: ValidValue -> DecoderT (f a)

instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where
  decodeRep :: forall a. ValidValue -> DecoderT (M1 D d f a)
decodeRep ValidValue
value = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. DecodeRep f => ValidValue -> DecoderT (f a)
decodeRep ValidValue
value

instance (DescribeCons a, DescribeCons b, DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where
  decodeRep :: forall a. ValidValue -> DecoderT ((:+:) a b a)
decodeRep (Object ValidObject
obj) =
    do
      (Bool
kind, ([TypeName], [TypeName])
lr) <- forall (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *).
(DescribeCons a, DescribeCons b) =>
f (a :+: b) -> DecoderT (Bool, ([TypeName], [TypeName]))
getUnionInfos (forall {k} (t :: k). Proxy t
Proxy @(a :+: b))
      forall a. Bool -> DecoderT a -> DecoderT a
setVariantRef Bool
kind forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadError GQLError m, Monad m) =>
(TypeName -> ValidObject -> ValidObject -> m a)
-> ValidObject -> m a
withInputUnion (forall (f :: * -> *) (g :: * -> *) a.
(DecodeRep f, DecodeRep g) =>
([TypeName], [TypeName])
-> TypeName -> ValidObject -> ValidObject -> DecoderT ((:+:) f g a)
decodeInputUnionObject ([TypeName], [TypeName])
lr) ValidObject
obj
  decodeRep (Enum TypeName
name) = do
    (Bool
_, ([TypeName]
l, [TypeName]
r)) <- forall (f :: (* -> *) -> *) (a :: * -> *) (b :: * -> *).
(DescribeCons a, DescribeCons b) =>
f (a :+: b) -> DecoderT (Bool, ([TypeName], [TypeName]))
getUnionInfos (forall {k} (t :: k). Proxy t
Proxy @(a :+: b))
    TypeName -> TypeName
visitor <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> TypeName -> TypeName
enumVisitor
    forall (f :: * -> *) (g :: * -> *) a.
(DecodeRep f, DecodeRep g) =>
([TypeName], [TypeName])
-> TypeName -> ValidValue -> DecoderT ((:+:) f g a)
decideEither (forall a b. (a -> b) -> [a] -> [b]
map TypeName -> TypeName
visitor [TypeName]
l, forall a b. (a -> b) -> [a] -> [b]
map TypeName -> TypeName
visitor [TypeName]
r) TypeName
name (forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
name)
  decodeRep ValidValue
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"lists and scalars are not allowed in Union")

instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where
  decodeRep :: forall a. ValidValue -> DecoderT (M1 C c a a)
decodeRep = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
DecodeFields f =>
Int -> ValidValue -> DecoderT (f a)
decodeFields Int
0

class DecodeFields (f :: Type -> Type) where
  decodeFields :: Int -> ValidValue -> DecoderT (f a)

instance (DecodeFields f, DecodeFields g, DescribeFields g) => DecodeFields (f :*: g) where
  decodeFields :: forall a. Int -> ValidValue -> DecoderT ((:*:) f g a)
decodeFields Int
index ValidValue
gql =
    forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
DecodeFields f =>
Int -> ValidValue -> DecoderT (f a)
decodeFields Int
index ValidValue
gql
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a.
DecodeFields f =>
Int -> ValidValue -> DecoderT (f a)
decodeFields (Int
index forall a. Num a => a -> a -> a
+ forall (f :: * -> *). DescribeFields f => Proxy f -> Int
countFields (forall {k} (t :: k). Proxy t
Proxy @g)) ValidValue
gql

instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where
  decodeFields :: forall a. Int -> ValidValue -> DecoderT (M1 S s (K1 i a) a)
decodeFields Int
index ValidValue
value =
    forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      Context {Bool
isVariantRef :: Bool
isVariantRef :: Context -> Bool
isVariantRef, FieldName -> FieldName
fieldVisitor :: FieldName -> FieldName
fieldVisitor :: Context -> FieldName -> FieldName
fieldVisitor} <- forall r (m :: * -> *). MonadReader r m => m r
ask
      if Bool
isVariantRef
        then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Decode a => ValidValue -> ResolverState a
decode ValidValue
value)
        else
          let fieldName :: FieldName
fieldName = FieldName -> FieldName
fieldVisitor forall a b. (a -> b) -> a -> b
$ FieldName -> Int -> FieldName
getFieldName (forall (f :: Meta -> *) (s :: Meta). Selector s => f s -> FieldName
selNameProxy (forall {k} (t :: k). Proxy t
Proxy @s)) Int
index
              fieldDecoder :: ValidObject -> ReaderT Context (ResolverStateT () Identity) a
fieldDecoder = forall (m :: * -> *) a.
(ValidValue -> m a) -> FieldName -> ValidObject -> m a
decodeFieldWith (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Decode a => ValidValue -> ResolverState a
decode) FieldName
fieldName
           in forall (m :: * -> *) a.
MonadError GQLError m =>
(ValidObject -> m a) -> ValidValue -> m a
withInputObject ValidObject -> ReaderT Context (ResolverStateT () Identity) a
fieldDecoder ValidValue
value

instance DecodeFields U1 where
  decodeFields :: forall a. Int -> ValidValue -> DecoderT (U1 a)
decodeFields Int
_ ValidValue
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1