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

module Data.Morpheus.Server.Deriving.Kinded.Value
  ( KindedValue (..),
  )
where

import Control.Monad.Except
  ( MonadError (throwError),
  )
import qualified Data.Map as M
import Data.Morpheus.App.Internal.Resolving
  ( ResolverState,
  )
import Data.Morpheus.Internal.Ext
  ( GQLResult,
  )
import Data.Morpheus.Server.Deriving.Internal.Decode.Rep
  ( DecodeRep (..),
  )
import Data.Morpheus.Server.Deriving.Internal.Decode.Utils
  ( Context (..),
    decodeFieldWith,
    handleEither,
    repValue,
    withInputObject,
    withScalar,
  )
import Data.Morpheus.Server.Deriving.Internal.Schema.Directive
  ( visitEnumName,
    visitFieldName,
  )
import Data.Morpheus.Server.Deriving.Utils.GRep
  ( GRep,
    RepContext (..),
    deriveValue,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
    inputType,
  )
import Data.Morpheus.Server.Deriving.Utils.Proxy
  ( ContextValue,
    symbolName,
    unContextValue,
  )
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseDeriving (..),
    UseGQLType (..),
    UseValue (..),
  )
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 (..),
    EncodeScalar (..),
  )
import Data.Morpheus.Types.GQLWrapper
  ( DecodeWrapper (..),
    DecodeWrapperConstraint,
    EncodeWrapperValue (encodeWrapperValue),
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    IN,
    ObjectEntry (..),
    VALID,
    ValidValue,
    Value (..),
  )
import GHC.Generics
import GHC.TypeLits (KnownSymbol)
import Relude

class KindedValue gql args (kind :: DerivingKind) (a :: Type) where
  encodeKindedValue :: UseDeriving gql args -> ContextValue kind a -> GQLResult (Value CONST)
  decodeKindedValue :: UseDeriving gql args -> Proxy kind -> ValidValue -> ResolverState a

instance (EncodeScalar a, DecodeScalar a, gql a) => KindedValue gql args SCALAR a where
  encodeKindedValue :: UseDeriving gql args
-> ContextValue SCALAR a -> GQLResult (Value CONST)
encodeKindedValue UseDeriving gql args
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stage :: Stage). ScalarValue -> Value stage
Scalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncodeScalar a => a -> ScalarValue
encodeScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue
  decodeKindedValue :: UseDeriving gql args
-> Proxy SCALAR -> ValidValue -> ResolverState a
decodeKindedValue UseDeriving gql args
dir Proxy SCALAR
_ = forall (m :: * -> *) a.
(Applicative m, MonadError GQLError m) =>
TypeName -> (ScalarValue -> Either Token a) -> ValidValue -> m a
withScalar (forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeName
useTypename (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseGQLType gql
dirGQL UseDeriving gql args
dir) (forall {k} (a :: k). CatType IN a
InputType :: CatType IN a)) forall a. DecodeScalar a => ScalarValue -> Either Token a
decodeScalar

instance (DecodeWrapperConstraint f a, DecodeWrapper f, EncodeWrapperValue f, args a) => KindedValue gql args WRAPPER (f a) where
  encodeKindedValue :: UseDeriving gql args
-> ContextValue WRAPPER (f a) -> GQLResult (Value CONST)
encodeKindedValue UseDeriving gql args
dir = forall (f :: * -> *) (m :: * -> *) a.
(EncodeWrapperValue f, Monad m) =>
(a -> m (Value CONST)) -> f a -> m (Value CONST)
encodeWrapperValue (forall (val :: * -> Constraint).
UseValue val -> forall a. val a => a -> GQLResult (Value CONST)
useEncodeValue (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
dirArgs UseDeriving gql args
dir)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue
  decodeKindedValue :: UseDeriving gql args
-> Proxy WRAPPER -> ValidValue -> ResolverState (f a)
decodeKindedValue UseDeriving gql args
dir 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 (val :: * -> Constraint).
UseValue val -> forall a. val a => ValidValue -> ResolverState a
useDecodeValue (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
dirArgs UseDeriving gql args
dir)) 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 (gql a, Generic a, DecodeRep gql args (Rep a), GRep gql args (GQLResult (Value CONST)) (Rep a)) => KindedValue gql args TYPE a where
  encodeKindedValue :: UseDeriving gql args
-> ContextValue TYPE a -> GQLResult (Value CONST)
encodeKindedValue UseDeriving {UseValue args
UseGQLType gql
forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql args
__directives :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val
-> forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val
dirGQL :: UseGQLType gql
dirArgs :: UseValue args
__directives :: forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql args
dirArgs :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
dirGQL :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseGQLType gql
..} =
    TypeRep (GQLResult (Value CONST)) -> GQLResult (Value CONST)
repValue
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (gql :: * -> Constraint) (constraint :: * -> Constraint)
       value.
(Generic a, GRep gql constraint value (Rep a), gql a) =>
RepContext gql constraint Identity value -> a -> TypeRep value
deriveValue
        ( RepContext
            { optApply :: forall a. args a => Identity a -> GQLResult (Value CONST)
optApply = forall (val :: * -> Constraint).
UseValue val -> forall a. val a => a -> GQLResult (Value CONST)
useEncodeValue UseValue args
dirArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity,
              optTypeData :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData = forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeData
useTypeData UseGQLType gql
dirGQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). f a -> CatType IN a
inputType
            } ::
            RepContext gql args Identity (GQLResult (Value CONST))
        )
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue
  decodeKindedValue :: UseDeriving gql args -> Proxy TYPE -> ValidValue -> ResolverState a
decodeKindedValue UseDeriving gql args
dir 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 (gql :: * -> Constraint) (args :: * -> Constraint)
       (f :: * -> *) a.
DecodeRep gql args f =>
UseDeriving gql args -> ValidValue -> DecoderT (f a)
decodeRep UseDeriving gql args
dir
    where
      context :: Context
context =
        Context
          { isVariantRef :: Bool
isVariantRef = Bool
False,
            typeName :: TypeName
typeName = forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeName
useTypename (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseGQLType gql
dirGQL UseDeriving gql args
dir) (forall {k} (a :: k). CatType IN a
InputType :: CatType IN a),
            enumVisitor :: TypeName -> TypeName
enumVisitor = forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *).
gql a =>
UseDeriving gql args -> f a -> TypeName -> TypeName
visitEnumName UseDeriving gql args
dir Proxy a
proxy,
            fieldVisitor :: FieldName -> FieldName
fieldVisitor = forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *).
gql a =>
UseDeriving gql args -> f a -> FieldName -> FieldName
visitFieldName UseDeriving gql args
dir Proxy a
proxy
          }
        where
          proxy :: Proxy a
proxy = forall {k} (t :: k). Proxy t
Proxy @a

instance KindedValue gql args CUSTOM (Value CONST) where
  encodeKindedValue :: UseDeriving gql args
-> ContextValue CUSTOM (Value CONST) -> GQLResult (Value CONST)
encodeKindedValue UseDeriving gql args
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue
  decodeKindedValue :: UseDeriving gql args
-> Proxy CUSTOM -> ValidValue -> ResolverState (Value CONST)
decodeKindedValue UseDeriving gql args
_ Proxy CUSTOM
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidValue -> Value CONST
toConstValue

toConstValue :: ValidValue -> Value CONST
toConstValue :: ValidValue -> Value CONST
toConstValue ValidValue
Null = forall (stage :: Stage). Value stage
Null
toConstValue (Enum TypeName
x) = forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
x
toConstValue (Scalar ScalarValue
x) = forall (stage :: Stage). ScalarValue -> Value stage
Scalar ScalarValue
x
toConstValue (List [ValidValue]
xs) = forall (stage :: Stage). [Value stage] -> Value stage
List (forall a b. (a -> b) -> [a] -> [b]
map ValidValue -> Value CONST
toConstValue [ValidValue]
xs)
toConstValue (Object Object VALID
fields) = forall (stage :: Stage). Object stage -> Value stage
Object (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ObjectEntry VALID -> ObjectEntry CONST
toEntry Object VALID
fields)
  where
    toEntry :: ObjectEntry VALID -> ObjectEntry CONST
    toEntry :: ObjectEntry VALID -> ObjectEntry CONST
toEntry ObjectEntry {ValidValue
FieldName
entryName :: forall (s :: Stage). ObjectEntry s -> FieldName
entryValue :: forall (s :: Stage). ObjectEntry s -> Value s
entryValue :: ValidValue
entryName :: FieldName
..} = ObjectEntry {entryValue :: Value CONST
entryValue = ValidValue -> Value CONST
toConstValue ValidValue
entryValue, FieldName
entryName :: FieldName
entryName :: FieldName
..}

instance (KnownSymbol name, args a) => KindedValue gql args CUSTOM (Arg name a) where
  encodeKindedValue :: UseDeriving gql args
-> ContextValue CUSTOM (Arg name a) -> GQLResult (Value CONST)
encodeKindedValue UseDeriving gql args
_ ContextValue CUSTOM (Arg name a)
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"directives cant be tagged arguments"
  decodeKindedValue :: UseDeriving gql args
-> Proxy CUSTOM -> ValidValue -> ResolverState (Arg name a)
decodeKindedValue UseDeriving {UseValue args
dirArgs :: UseValue args
dirArgs :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
dirArgs} 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 =>
(Object VALID -> m a) -> ValidValue -> m a
withInputObject Object VALID -> ResolverStateT () Identity a
fieldDecoder ValidValue
value
    where
      fieldDecoder :: Object VALID -> ResolverStateT () Identity a
fieldDecoder = forall (m :: * -> *) a.
(ValidValue -> m a) -> FieldName -> Object VALID -> m a
decodeFieldWith (forall (val :: * -> Constraint).
UseValue val -> forall a. val a => ValidValue -> ResolverState a
useDecodeValue UseValue args
dirArgs) 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, val [(k, v)]) => KindedValue gql val CUSTOM (Map k v) where
  decodeKindedValue :: UseDeriving gql val
-> Proxy CUSTOM -> ValidValue -> ResolverState (Map k v)
decodeKindedValue UseDeriving gql val
dir 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 (val :: * -> Constraint).
UseValue val -> forall a. val a => ValidValue -> ResolverState a
useDecodeValue (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
dirArgs UseDeriving gql val
dir) ValidValue
v :: ResolverState [(k, v)])
  encodeKindedValue :: UseDeriving gql val
-> ContextValue CUSTOM (Map k v) -> GQLResult (Value CONST)
encodeKindedValue UseDeriving gql val
dir = forall (val :: * -> Constraint).
UseValue val -> forall a. val a => a -> GQLResult (Value CONST)
useEncodeValue (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
dirArgs UseDeriving gql val
dir) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue