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

module Data.Morpheus.Server.Deriving.Named.EncodeValue
  ( EncodeFieldKind,
    Encode,
    getTypeName,
    encodeResolverValue,
    FieldConstraint,
  )
where

import Control.Monad.Except (MonadError (..))
import Data.Aeson (ToJSON (..))
import Data.Morpheus.App.Internal.Resolving
  ( LiftOperation,
    NamedResolverRef (..),
    NamedResolverResult (..),
    ObjectTypeResolver (..),
    Resolver,
    ResolverValue (..),
    getArguments,
    liftResolverState,
    mkList,
    mkNull,
  )
import Data.Morpheus.Server.Deriving.Decode
  ( Decode,
    decodeArguments,
  )
import Data.Morpheus.Server.Deriving.Encode
  ( ContextValue (..),
  )
import Data.Morpheus.Server.Deriving.Schema.Directive (toFieldRes)
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    DataType (..),
    FieldRep (..),
  )
import Data.Morpheus.Server.Deriving.Utils.DeriveGType
  ( DeriveValueOptions (..),
    DeriveWith,
    deriveValue,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
import Data.Morpheus.Server.NamedResolvers
  ( NamedRef,
    NamedResolverT (..),
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (__type),
    KIND,
    deriveTypename,
    withDir,
    __typeData,
  )
import Data.Morpheus.Server.Types.Internal
  ( TypeData (gqlTypeName),
  )
import Data.Morpheus.Server.Types.Kind
  ( CUSTOM,
    DerivingKind,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.Types.GQLScalar
  ( EncodeScalar (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( GQLError,
    OUT,
    TypeCategory (OUT),
    TypeName,
    ValidValue,
    Value (List),
    internal,
    replaceValue,
  )
import qualified GHC.Exts as HM
import GHC.Generics
  ( Generic (..),
  )
import Relude hiding (empty)

encodeResolverValue :: (MonadError GQLError m, FieldConstraint m a) => [Maybe a] -> m [NamedResolverResult m]
encodeResolverValue :: forall (m :: * -> *) a.
(MonadError GQLError m, FieldConstraint m a) =>
[Maybe a] -> m [NamedResolverResult m]
encodeResolverValue [Maybe a]
x = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Maybe a -> m (NamedResolverResult m)
encodeNode [Maybe a]
x
  where
    encodeNode :: Maybe a -> m (NamedResolverResult m)
encodeNode (Just a
v) = forall a (m :: * -> *) (f :: * -> *).
(GQLType a, MonadError GQLError m) =>
f a -> DataType (m (ResolverValue m)) -> m (NamedResolverResult m)
convertNamedNode (forall a. a -> Identity a
Identity [Maybe a]
x) (forall (m :: * -> *) a.
FieldConstraint m a =>
a -> DataType (m (ResolverValue m))
getFieldValues a
v)
    encodeNode Maybe a
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). NamedResolverResult m
NamedNullResolver

type FieldConstraint m a =
  ( GQLType a,
    Generic a,
    DeriveWith GQLType (Encode m) (m (ResolverValue m)) (Rep a)
  )

class Encode (m :: Type -> Type) res where
  encodeField :: res -> m (ResolverValue m)

instance (EncodeFieldKind (KIND a) m a) => Encode m a where
  encodeField :: a -> m (ResolverValue m)
encodeField a
resolver = forall (k :: DerivingKind) (m :: * -> *) a.
EncodeFieldKind k m a =>
ContextValue k a -> m (ResolverValue m)
encodeFieldKind (forall (kind :: DerivingKind) a. a -> ContextValue kind a
ContextValue a
resolver :: ContextValue (KIND a) a)

class EncodeFieldKind (k :: DerivingKind) (m :: Type -> Type) (a :: Type) where
  encodeFieldKind :: ContextValue k a -> m (ResolverValue m)

instance (EncodeScalar a, Monad m) => EncodeFieldKind SCALAR m a where
  encodeFieldKind :: ContextValue SCALAR a -> m (ResolverValue m)
encodeFieldKind = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar 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

instance (FieldConstraint m a, MonadError GQLError m) => EncodeFieldKind TYPE m a where
  encodeFieldKind :: ContextValue TYPE a -> m (ResolverValue m)
encodeFieldKind (ContextValue a
_) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"types are resolved by Refs")

instance (GQLType a, Applicative m, EncodeFieldKind (KIND a) m a) => EncodeFieldKind WRAPPER m [a] where
  encodeFieldKind :: ContextValue WRAPPER [a] -> m (ResolverValue m)
encodeFieldKind = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
ResList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

instance (GQLType a, EncodeFieldKind (KIND a) m a, Applicative m) => EncodeFieldKind WRAPPER m (Maybe a) where
  encodeFieldKind :: ContextValue WRAPPER (Maybe a) -> m (ResolverValue m)
encodeFieldKind (ContextValue (Just a
x)) = forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField a
x
  encodeFieldKind (ContextValue Maybe a
Nothing) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). ResolverValue m
mkNull

instance
  ( Monad m,
    GQLType a,
    EncodeFieldKind (KIND a) m a,
    ToJSON (NamedRef a)
  ) =>
  EncodeFieldKind CUSTOM m (NamedResolverT m a)
  where
  encodeFieldKind :: ContextValue CUSTOM (NamedResolverT m a) -> m (ResolverValue m)
encodeFieldKind = Monad m => NamedResolverT m a -> m (ResolverValue m)
encodeRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue
    where
      name :: TypeName
      name :: TypeName
name = forall a (f :: * -> *). GQLType a => f a -> TypeName
getTypeName (forall {k} (t :: k). Proxy t
Proxy @a)
      encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m)
      encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m)
encodeRef (NamedResolverT m (NamedRef a)
ref) = do
        Value VALID
value <- forall (a :: Stage). Value -> Value a
replaceValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (NamedRef a)
ref
        case Value VALID
value of
          (List [Value VALID]
ls) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *).
Applicative m =>
TypeName -> Value VALID -> ResolverValue m
packRef TypeName
name) [Value VALID]
ls
          Value VALID
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Applicative m =>
TypeName -> Value VALID -> ResolverValue m
packRef TypeName
name Value VALID
value

packRef :: Applicative m => TypeName -> ValidValue -> ResolverValue m
packRef :: forall (m :: * -> *).
Applicative m =>
TypeName -> Value VALID -> ResolverValue m
packRef TypeName
name Value VALID
v = forall (m :: * -> *). m NamedResolverRef -> ResolverValue m
ResRef forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TypeName -> [Value VALID] -> NamedResolverRef
NamedResolverRef TypeName
name [Value VALID
v]

instance
  ( Decode a,
    Monad m,
    Encode (Resolver o e m) b,
    LiftOperation o
  ) =>
  EncodeFieldKind CUSTOM (Resolver o e m) (a -> b)
  where
  encodeFieldKind :: ContextValue CUSTOM (a -> b)
-> Resolver o e m (ResolverValue (Resolver o e m))
encodeFieldKind (ContextValue a -> b
f) =
    forall (o :: OperationType) (m :: * -> *) e.
(LiftOperation o, Monad m) =>
Resolver o e m (Arguments VALID)
getArguments
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (o :: OperationType) (m :: * -> *) a e.
(LiftOperation o, Monad m) =>
ResolverState a -> Resolver o e m a
liftResolverState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Decode a => Arguments VALID -> ResolverState a
decodeArguments
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

getFieldValues :: forall m a. FieldConstraint m a => a -> DataType (m (ResolverValue m))
getFieldValues :: forall (m :: * -> *) a.
FieldConstraint m a =>
a -> DataType (m (ResolverValue m))
getFieldValues =
  forall {k} a (gql :: * -> Constraint)
       (constraint :: * -> Constraint) value (kind :: k).
(Generic a, DeriveWith gql constraint value (Rep a)) =>
DeriveValueOptions kind gql constraint value -> a -> DataType value
deriveValue
    ( DeriveValueOptions
        { __valueApply :: forall a. Encode m a => a -> m (ResolverValue m)
__valueApply = forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField,
          __valueTypeName :: TypeName
__valueTypeName = forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeName
deriveTypename (forall {k} (a :: k). CatType OUT a
OutputType :: CatType OUT a),
          __valueGetType :: forall (f :: * -> *) a. GQLType a => f a -> TypeData
__valueGetType = forall a (cat :: TypeCategory).
GQLType a =>
CatType cat a -> TypeData
__typeData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType
        } ::
        DeriveValueOptions OUT GQLType (Encode m) (m (ResolverValue m))
    )

convertNamedNode ::
  (GQLType a, MonadError GQLError m) =>
  f a ->
  DataType (m (ResolverValue m)) ->
  m (NamedResolverResult m)
convertNamedNode :: forall a (m :: * -> *) (f :: * -> *).
(GQLType a, MonadError GQLError m) =>
f a -> DataType (m (ResolverValue m)) -> m (NamedResolverResult m)
convertNamedNode
  f a
proxy
  DataType
    { Bool
tyIsUnion :: forall v. DataType v -> Bool
tyIsUnion :: Bool
tyIsUnion,
      tyCons :: forall v. DataType v -> ConsRep v
tyCons = ConsRep {[FieldRep (m (ResolverValue m))]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (m (ResolverValue m))]
consFields, TypeName
consName :: forall v. ConsRep v -> TypeName
consName :: TypeName
consName}
    }
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldRep (m (ResolverValue m))]
consFields = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). TypeName -> NamedResolverResult m
NamedEnumResolver TypeName
consName
    | Bool
tyIsUnion = forall (m :: * -> *).
MonadError GQLError m =>
[FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)
deriveUnion [FieldRep (m (ResolverValue m))]
consFields
    | Bool
otherwise =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *). ObjectTypeResolver m -> NamedResolverResult m
NamedObjectResolver
            ObjectTypeResolver
              { objectFields :: HashMap FieldName (m (ResolverValue m))
objectFields = forall l. IsList l => [Item l] -> l
HM.fromList (forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *) v.
gql a =>
UseDirective gql args -> f a -> FieldRep v -> (FieldName, v)
toFieldRes UseDirective GQLType DeriveDirective
withDir f a
proxy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldRep (m (ResolverValue m))]
consFields)
              }

deriveUnion :: (MonadError GQLError m) => [FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)
deriveUnion :: forall (m :: * -> *).
MonadError GQLError m =>
[FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)
deriveUnion [FieldRep {m (ResolverValue m)
TypeRef
FieldName
fieldValue :: forall a. FieldRep a -> a
fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldSelector :: forall a. FieldRep a -> FieldName
fieldValue :: m (ResolverValue m)
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
..}] =
  forall (m :: * -> *). NamedResolverRef -> NamedResolverResult m
NamedUnionResolver forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m (ResolverValue m)
fieldValue forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadError GQLError m =>
ResolverValue m -> m NamedResolverRef
getRef)
deriveUnion [FieldRep (m (ResolverValue m))]
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"only union references are supported!"

getRef :: MonadError GQLError m => ResolverValue m -> m NamedResolverRef
getRef :: forall (m :: * -> *).
MonadError GQLError m =>
ResolverValue m -> m NamedResolverRef
getRef (ResRef m NamedResolverRef
x) = m NamedResolverRef
x
getRef ResolverValue m
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"only resolver references are supported!"

getTypeName :: GQLType a => f a -> TypeName
getTypeName :: forall a (f :: * -> *). GQLType a => f a -> TypeName
getTypeName f a
proxy = TypeData -> TypeName
gqlTypeName forall a b. (a -> b) -> a -> b
$ forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type f a
proxy TypeCategory
OUT