{-# 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 UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Kinded.NamedResolverFun
  ( deriveNamedResolverFun,
    KindedNamedFunValue (..),
  )
where

import Control.Monad.Except (MonadError (..))
import Data.Aeson (ToJSON (..))
import Data.Morpheus.App.Internal.Resolving
  ( MonadResolver (..),
    NamedResolverRef (..),
    NamedResolverResult (..),
    ObjectTypeResolver (..),
    ResolverValue (..),
    getArguments,
    mkList,
    mkNull,
  )
import Data.Morpheus.Server.Deriving.Internal.Decode.Utils (useDecodeArguments)
import Data.Morpheus.Server.Deriving.Internal.Schema.Directive (UseDeriving, toFieldRes)
import Data.Morpheus.Server.Deriving.Utils.GRep
  ( ConsRep (..),
    FieldRep (..),
    GRep,
    RepContext (..),
    TypeRep (..),
    deriveValue,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
    outputType,
  )
import Data.Morpheus.Server.Deriving.Utils.Proxy
  ( ContextValue (..),
  )
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseDeriving (..),
    UseGQLType (..),
    UseNamedResolver (..),
  )
import Data.Morpheus.Server.Types.Kind
  ( CUSTOM,
    DerivingKind,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.Server.Types.NamedResolvers
  ( NamedRef,
    NamedResolverT (..),
  )
import Data.Morpheus.Types.GQLScalar
  ( EncodeScalar (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( GQLError,
    OUT,
    TypeName,
    ValidValue,
    Value (List),
    internal,
    replaceValue,
  )
import qualified GHC.Exts as HM
import GHC.Generics
  ( Generic (..),
  )
import Relude hiding (empty)

deriveNamedResolverFun ::
  ( Generic a,
    gql [Maybe a],
    gql a,
    MonadError GQLError m,
    GRep gql (res m) (m (ResolverValue m)) (Rep a)
  ) =>
  UseNamedResolver namedRes res gql val ->
  [Maybe a] ->
  m [NamedResolverResult m]
deriveNamedResolverFun :: forall a (gql :: * -> Constraint) (m :: * -> *)
       (res :: (* -> *) -> * -> Constraint)
       (namedRes :: (* -> *) -> * -> Constraint) (val :: * -> Constraint).
(Generic a, gql [Maybe a], gql a, MonadError GQLError m,
 GRep gql (res m) (m (ResolverValue m)) (Rep a)) =>
UseNamedResolver namedRes res gql val
-> [Maybe a] -> m [NamedResolverResult m]
deriveNamedResolverFun UseNamedResolver namedRes res gql val
ctx [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 (gql :: * -> Constraint) a (m :: * -> *)
       (val :: * -> Constraint) (f :: * -> *).
(gql a, MonadError GQLError m) =>
UseDeriving gql val
-> f a
-> TypeRep (m (ResolverValue m))
-> m (NamedResolverResult m)
convertNamedNode (forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val -> UseDeriving gql val
namedDrv UseNamedResolver namedRes res gql val
ctx) (forall a. a -> Identity a
Identity [Maybe a]
x) (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 (forall (namedRes :: (* -> *) -> * -> Constraint)
       (res :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (m :: * -> *).
UseNamedResolver namedRes res gql val
-> RepContext gql (res m) Identity (m (ResolverValue m))
getOptions UseNamedResolver namedRes res gql val
ctx) a
v)
    encodeNode Maybe a
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). NamedResolverResult m
NamedNullResolver

class KindedNamedFunValue res gql val (k :: DerivingKind) (m :: Type -> Type) (a :: Type) where
  kindedNamedFunValue :: UseNamedResolver namedRes res gql val -> ContextValue k a -> m (ResolverValue m)

instance (EncodeScalar a, Monad m) => KindedNamedFunValue res gql val SCALAR m a where
  kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint).
UseNamedResolver namedRes res gql val
-> ContextValue SCALAR a -> m (ResolverValue m)
kindedNamedFunValue UseNamedResolver namedRes res gql val
_ = 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 (MonadError GQLError m) => KindedNamedFunValue res gql val TYPE m a where
  kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint).
UseNamedResolver namedRes res gql val
-> ContextValue TYPE a -> m (ResolverValue m)
kindedNamedFunValue UseNamedResolver namedRes res gql val
_ (ContextValue a
_) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"types are resolved by Refs")

instance (Applicative m, res m a) => KindedNamedFunValue res gql val WRAPPER m [a] where
  kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint).
UseNamedResolver namedRes res gql val
-> ContextValue WRAPPER [a] -> m (ResolverValue m)
kindedNamedFunValue UseNamedResolver namedRes res gql val
ctx = 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 (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val
-> forall a (m :: * -> *). fun m a => a -> m (ResolverValue m)
useNamedFieldResolver UseNamedResolver namedRes res gql val
ctx) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

instance (gql a, res m a, Applicative m) => KindedNamedFunValue res gql val WRAPPER m (Maybe a) where
  kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint).
UseNamedResolver namedRes res gql val
-> ContextValue WRAPPER (Maybe a) -> m (ResolverValue m)
kindedNamedFunValue UseNamedResolver namedRes res gql val
ctx (ContextValue (Just a
x)) = forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val
-> forall a (m :: * -> *). fun m a => a -> m (ResolverValue m)
useNamedFieldResolver UseNamedResolver namedRes res gql val
ctx a
x
  kindedNamedFunValue UseNamedResolver namedRes res gql val
_ (ContextValue Maybe a
Nothing) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). ResolverValue m
mkNull

instance (Monad m, gql a, ToJSON (NamedRef a)) => KindedNamedFunValue res gql val CUSTOM m (NamedResolverT m a) where
  kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint).
UseNamedResolver namedRes res gql val
-> ContextValue CUSTOM (NamedResolverT m a) -> m (ResolverValue m)
kindedNamedFunValue UseNamedResolver namedRes res gql val
ctx = 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 (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 (forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val -> UseDeriving gql val
namedDrv UseNamedResolver namedRes res gql val
ctx)) (forall {k} (a :: k). CatType OUT a
OutputType :: CatType OUT 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 (Monad m, val a, MonadResolver m, res m b) => KindedNamedFunValue res gql val CUSTOM m (a -> b) where
  kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint).
UseNamedResolver namedRes res gql val
-> ContextValue CUSTOM (a -> b) -> m (ResolverValue m)
kindedNamedFunValue UseNamedResolver namedRes res gql val
ctx (ContextValue a -> b
f) =
    forall (m :: * -> *). MonadResolver m => m (Arguments VALID)
getArguments
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadResolver m => ResolverState a -> m a
liftState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (val :: * -> Constraint) a (gql :: * -> Constraint).
val a =>
UseDeriving gql val -> Arguments VALID -> ResolverState a
useDecodeArguments (forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val -> UseDeriving gql val
namedDrv UseNamedResolver namedRes res gql val
ctx)
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val
-> forall a (m :: * -> *). fun m a => a -> m (ResolverValue m)
useNamedFieldResolver UseNamedResolver namedRes res gql val
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

getOptions :: UseNamedResolver namedRes res gql val -> RepContext gql (res m) Identity (m (ResolverValue m))
getOptions :: forall (namedRes :: (* -> *) -> * -> Constraint)
       (res :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (m :: * -> *).
UseNamedResolver namedRes res gql val
-> RepContext gql (res m) Identity (m (ResolverValue m))
getOptions UseNamedResolver {UseDeriving gql val
forall a (m :: * -> *). res m a => a -> m (ResolverValue m)
forall (f :: * -> *) a (m :: * -> *).
namedRes m a =>
f a -> [NamedResolver m]
forall (f :: * -> *) a (m :: * -> *).
namedRes m a =>
f a -> [ScanRef (namedRes m)]
useDeriveNamedRefs :: forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   named m a =>
   f a -> [ScanRef (named m)]
useDeriveNamedResolvers :: forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   named m a =>
   f a -> [NamedResolver m]
namedDrv :: UseDeriving gql val
useDeriveNamedRefs :: forall (f :: * -> *) a (m :: * -> *).
namedRes m a =>
f a -> [ScanRef (namedRes m)]
useDeriveNamedResolvers :: forall (f :: * -> *) a (m :: * -> *).
namedRes m a =>
f a -> [NamedResolver m]
useNamedFieldResolver :: forall a (m :: * -> *). res m a => a -> m (ResolverValue m)
useNamedFieldResolver :: forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val
-> forall a (m :: * -> *). fun m a => a -> m (ResolverValue m)
namedDrv :: forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val -> UseDeriving gql val
..} =
  RepContext
    { optApply :: forall a. res m a => Identity a -> m (ResolverValue m)
optApply = forall a (m :: * -> *). res m a => a -> m (ResolverValue m)
useNamedFieldResolver 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 (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseGQLType gql
dirGQL UseDeriving gql val
namedDrv) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType
    }

convertNamedNode ::
  (gql a, MonadError GQLError m) =>
  UseDeriving gql val ->
  f a ->
  TypeRep (m (ResolverValue m)) ->
  m (NamedResolverResult m)
convertNamedNode :: forall (gql :: * -> Constraint) a (m :: * -> *)
       (val :: * -> Constraint) (f :: * -> *).
(gql a, MonadError GQLError m) =>
UseDeriving gql val
-> f a
-> TypeRep (m (ResolverValue m))
-> m (NamedResolverResult m)
convertNamedNode
  UseDeriving gql val
drv
  f a
proxy
  TypeRep
    { Bool
tyIsUnion :: forall v. TypeRep v -> Bool
tyIsUnion :: Bool
tyIsUnion,
      tyCons :: forall v. TypeRep 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 =>
UseDeriving gql args -> f a -> FieldRep v -> (FieldName, v)
toFieldRes UseDeriving gql val
drv 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!"