{-# 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,
  )
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.Kind
  ( CUSTOM,
    DerivingKind,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.NamedResolvers
  ( NamedResolverT (..),
    ResolveNamed (..),
  )
import Data.Morpheus.Server.Deriving.Decode
  ( DecodeConstraint,
    decodeArguments,
  )
import Data.Morpheus.Server.Deriving.Encode
  ( ContextValue (..),
  )
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    DataType (..),
    FieldRep (..),
    TypeConstraint (..),
    TypeRep (..),
    toFieldRes,
    toValue,
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (__type),
    KIND,
    TypeData (gqlTypeName),
  )
import Data.Morpheus.Types.GQLScalar
  ( EncodeScalar (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( GQLError,
    OUT,
    TypeCategory (OUT),
    TypeName,
    internal,
    replaceValue,
  )
import qualified GHC.Exts as HM
import GHC.Generics
  ( Generic (..),
  )
import Relude

encodeResolverValue :: (MonadError GQLError m, FieldConstraint m a) => a -> m (NamedResolverResult m)
encodeResolverValue :: forall (m :: * -> *) a.
(MonadError GQLError m, FieldConstraint m a) =>
a -> m (NamedResolverResult m)
encodeResolverValue = forall (m :: * -> *).
MonadError GQLError m =>
DataType (m (ResolverValue m)) -> m (NamedResolverResult m)
convertNamedNode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
FieldConstraint m a =>
a -> DataType (m (ResolverValue m))
getFieldValues

type FieldConstraint m a =
  ( GQLType a,
    Generic a,
    TypeRep (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 (Dep 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 (Ref m (Dep a)
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). m NamedResolverRef -> ResolverValue m
ResRef (TypeName -> ValidValue -> NamedResolverRef
NamedResolverRef TypeName
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (Dep a)
x)
      encodeRef (Value m a
value) = m a
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField
      encodeRef (Refs m [Dep a1]
refs) = forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). m NamedResolverRef -> ResolverValue m
ResRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> ValidValue -> NamedResolverRef
NamedResolverRef TypeName
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 [Dep a1]
refs

instance
  ( DecodeConstraint a,
    Generic 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. DecodeConstraint 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 :: FieldConstraint m a => a -> DataType (m (ResolverValue m))
getFieldValues :: forall (m :: * -> *) a.
FieldConstraint m a =>
a -> DataType (m (ResolverValue m))
getFieldValues =
  forall (proxy :: TypeCategory -> *) (kind :: TypeCategory)
       (constraint :: * -> Constraint) value a.
(GQLType a, CategoryValue kind, Generic a,
 TypeRep constraint value (Rep a)) =>
TypeConstraint constraint value Identity
-> proxy kind -> a -> DataType value
toValue
    ( forall (c :: * -> Constraint) v (f :: * -> *).
(forall a. c a => f a -> v) -> TypeConstraint c v f
TypeConstraint (forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity) ::
        TypeConstraint (Encode m) (m (ResolverValue m)) Identity
    )
    (forall {k} (t :: k). Proxy t
Proxy @OUT)

convertNamedNode ::
  MonadError GQLError m =>
  DataType (m (ResolverValue m)) ->
  m (NamedResolverResult m)
convertNamedNode :: forall (m :: * -> *).
MonadError GQLError m =>
DataType (m (ResolverValue m)) -> m (NamedResolverResult m)
convertNamedNode
  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 {k} (m :: k -> *) (a :: k).
FieldRep (m a) -> (FieldName, m a)
toFieldRes 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