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

module Data.Morpheus.Server.Deriving.Kinded.NamedResolver
  ( KindedNamedResolver (..),
  )
where

import Data.Morpheus.App.Internal.Resolving
  ( MonadResolver (..),
    NamedResolver (..),
    NamedResolverResult (..),
    ResolverValue,
  )
import Data.Morpheus.Generic
  ( GRep,
    Gmap,
    ScanRef,
    scanLeaf,
    scanNode,
  )
import Data.Morpheus.Server.Deriving.Kinded.NamedResolverFun
  ( deriveNamedResolverFun,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded (outputType)
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseDeriving (..),
    UseGQLType (..),
    UseGQLValue (..),
    UseNamedResolver (..),
  )
import Data.Morpheus.Server.Types.Kind
  ( CUSTOM,
    DerivingKind,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.Server.Types.NamedResolvers (Dependency, NamedResolverT (..), ResolveNamed (..))
import Data.Morpheus.Types.GQLScalar (EncodeScalar (..))
import Data.Morpheus.Types.Internal.AST
  ( ValidValue,
  )
import GHC.Generics (Rep)
import Relude

type DECODE_VALUES val m a = (ResolveNamed m a, val (Dependency a), MonadResolver m)

decodeValues :: (DECODE_VALUES val m a) => UseDeriving gql val -> Proxy a -> [ValidValue] -> m [Maybe a]
decodeValues :: forall (val :: * -> Constraint) (m :: * -> *) a
       (gql :: * -> Constraint).
DECODE_VALUES val m a =>
UseDeriving gql val -> Proxy a -> [ValidValue] -> m [Maybe a]
decodeValues UseDeriving gql val
ctx Proxy a
_ [ValidValue]
xs = (ValidValue -> m (Dependency a))
-> [ValidValue] -> m [Dependency a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (ResolverState (Dependency a) -> m (Dependency a)
forall a. ResolverState a -> m a
forall (m :: * -> *) a. MonadResolver m => ResolverState a -> m a
liftState (ResolverState (Dependency a) -> m (Dependency a))
-> (ValidValue -> ResolverState (Dependency a))
-> ValidValue
-> m (Dependency a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UseDeriving gql val -> ValidValue -> ResolverState (Dependency a)
forall a.
val a =>
UseDeriving gql val -> ValidValue -> ResolverState a
forall ctx (con :: * -> Constraint) a.
(UseGQLValue ctx con, con a) =>
ctx -> ValidValue -> ResolverState a
useDecodeValue UseDeriving gql val
ctx) [ValidValue]
xs m [Dependency a] -> ([Dependency a] -> m [Maybe a]) -> m [Maybe a]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Dependency a] -> m [Maybe a]
forall (m :: * -> *) a.
(ResolveNamed m a, MonadError GQLError m) =>
[Dependency a] -> m [Maybe a]
resolveBatched

class KindedNamedResolver ctx (k :: DerivingKind) (m :: Type -> Type) a where
  kindedNamedResolver :: (UseNamedResolver namedRes resFun gql val ~ ctx) => ctx -> p (f k a) -> [NamedResolver m]
  kindedNamedRefs :: (UseNamedResolver namedRes resFun gql val ~ ctx) => ctx -> p (f k a) -> [ScanRef Proxy (namedRes m)]

instance
  ( UseNamedResolver namedRes resFun gql val ~ ctx,
    DECODE_VALUES val m a,
    gql a,
    namedRes m a,
    EncodeScalar a
  ) =>
  KindedNamedResolver ctx SCALAR m a
  where
  kindedNamedResolver :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> * -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx -> p (f SCALAR a) -> [NamedResolver m]
kindedNamedResolver ctx
ctx p (f SCALAR a)
_ =
    [ NamedResolver
        { resolverName :: TypeName
resolverName = ctx -> CatType OUT a -> TypeName
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> TypeName
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeName
useTypename ctx
ctx (Proxy a -> CatType OUT a
forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType Proxy a
proxy),
          resolverFun :: NamedResolverFun m
resolverFun = UseDeriving gql val -> Proxy a -> [ValidValue] -> m [Maybe a]
forall (val :: * -> Constraint) (m :: * -> *) a
       (gql :: * -> Constraint).
DECODE_VALUES val m a =>
UseDeriving gql val -> Proxy a -> [ValidValue] -> m [Maybe a]
decodeValues (UseNamedResolver namedRes resFun gql val -> UseDeriving gql val
forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val -> UseDeriving gql val
namedDrv ctx
UseNamedResolver namedRes resFun gql val
ctx) Proxy a
proxy ([ValidValue] -> m [Maybe a])
-> ([Maybe a] -> m [NamedResolverResult m]) -> NamedResolverFun m
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [NamedResolverResult m] -> m [NamedResolverResult m]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([NamedResolverResult m] -> m [NamedResolverResult m])
-> ([Maybe a] -> [NamedResolverResult m])
-> [Maybe a]
-> m [NamedResolverResult m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> NamedResolverResult m)
-> [Maybe a] -> [NamedResolverResult m]
forall a b. (a -> b) -> [a] -> [b]
map (NamedResolverResult m
-> (a -> NamedResolverResult m) -> Maybe a -> NamedResolverResult m
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NamedResolverResult m
forall (m :: * -> *). NamedResolverResult m
NamedNullResolver (ScalarValue -> NamedResolverResult m
forall (m :: * -> *). ScalarValue -> NamedResolverResult m
NamedScalarResolver (ScalarValue -> NamedResolverResult m)
-> (a -> ScalarValue) -> a -> NamedResolverResult m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ScalarValue
forall a. EncodeScalar a => a -> ScalarValue
encodeScalar))
        }
    ]
    where
      proxy :: Proxy a
proxy = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
  kindedNamedRefs :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> * -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx -> p (f SCALAR a) -> [ScanRef Proxy (namedRes m)]
kindedNamedRefs ctx
ctx p (f SCALAR a)
_ = [TypeFingerprint -> Proxy a -> ScanRef Proxy (namedRes m)
forall (c :: * -> Constraint) a fp (f :: * -> *).
(c a, Show fp) =>
fp -> f a -> ScanRef f c
scanLeaf TypeFingerprint
fp Proxy a
proxy]
    where
      fp :: TypeFingerprint
fp = ctx -> CatType OUT a -> TypeFingerprint
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> TypeFingerprint
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeFingerprint
useFingerprint ctx
ctx (Proxy a -> CatType OUT a
forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType Proxy a
proxy)
      proxy :: Proxy a
proxy = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a

instance
  ( UseNamedResolver namedRes resFun gql val ~ ctx,
    DECODE_VALUES val m a,
    gql a,
    namedRes m a,
    Generic a,
    gql [Maybe a],
    GRep gql (resFun m) (m (ResolverValue m)) (Rep a),
    Gmap (namedRes m) (Rep a)
  ) =>
  KindedNamedResolver ctx TYPE m (a :: Type)
  where
  kindedNamedResolver :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> * -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx -> p (f TYPE a) -> [NamedResolver m]
kindedNamedResolver ctx
ctx p (f TYPE a)
_ =
    [ NamedResolver
        { resolverName :: TypeName
resolverName = ctx -> CatType OUT a -> TypeName
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> TypeName
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeName
useTypename ctx
ctx (Proxy a -> CatType OUT a
forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType Proxy a
proxy),
          resolverFun :: NamedResolverFun m
resolverFun = UseDeriving gql val -> Proxy a -> [ValidValue] -> m [Maybe a]
forall (val :: * -> Constraint) (m :: * -> *) a
       (gql :: * -> Constraint).
DECODE_VALUES val m a =>
UseDeriving gql val -> Proxy a -> [ValidValue] -> m [Maybe a]
decodeValues (UseNamedResolver namedRes resFun gql val -> UseDeriving gql val
forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val -> UseDeriving gql val
namedDrv ctx
UseNamedResolver namedRes resFun gql val
ctx) Proxy a
proxy ([ValidValue] -> m [Maybe a])
-> ([Maybe a] -> m [NamedResolverResult m]) -> NamedResolverFun m
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> UseNamedResolver namedRes resFun gql val
-> [Maybe a] -> m [NamedResolverResult m]
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 ctx
UseNamedResolver namedRes resFun gql val
ctx
        }
    ]
    where
      proxy :: Proxy a
proxy = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a

  kindedNamedRefs :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> * -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx -> p (f TYPE a) -> [ScanRef Proxy (namedRes m)]
kindedNamedRefs ctx
ctx p (f TYPE a)
_ = [Bool -> TypeFingerprint -> Proxy a -> ScanRef Proxy (namedRes m)
forall (c :: * -> Constraint) a fp (f :: * -> *).
(Gmap c (Rep a), c a, Show fp) =>
Bool -> fp -> f a -> ScanRef f c
scanNode Bool
True (ctx -> CatType OUT a -> TypeFingerprint
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> TypeFingerprint
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeFingerprint
useFingerprint ctx
ctx (Proxy a -> CatType OUT a
forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType Proxy a
proxy)) Proxy a
proxy]
    where
      proxy :: Proxy a
proxy = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a

instance (UseNamedResolver namedRes resFun gql val ~ ctx, namedRes m a) => KindedNamedResolver ctx CUSTOM m (NamedResolverT m a) where
  kindedNamedResolver :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> * -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx -> p (f CUSTOM (NamedResolverT m a)) -> [NamedResolver m]
kindedNamedResolver ctx
ctx p (f CUSTOM (NamedResolverT m a))
_ = UseNamedResolver namedRes resFun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   namedRes m a =>
   f a -> [NamedResolver m]
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]
useDeriveNamedResolvers ctx
UseNamedResolver namedRes resFun gql val
ctx (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  kindedNamedRefs :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> * -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx
-> p (f CUSTOM (NamedResolverT m a))
-> [ScanRef Proxy (namedRes m)]
kindedNamedRefs ctx
ctx p (f CUSTOM (NamedResolverT m a))
_ = UseNamedResolver namedRes resFun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   namedRes m a =>
   f a -> [ScanRef Proxy (namedRes m)]
forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   named m a =>
   f a -> [ScanRef Proxy (named m)]
useDeriveNamedRefs ctx
UseNamedResolver namedRes resFun gql val
ctx (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

instance (UseNamedResolver namedRes resFun gql val ~ ctx, namedRes m a) => KindedNamedResolver ctx CUSTOM m (input -> a) where
  kindedNamedResolver :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> * -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx -> p (f CUSTOM (input -> a)) -> [NamedResolver m]
kindedNamedResolver ctx
ctx p (f CUSTOM (input -> a))
_ = UseNamedResolver namedRes resFun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   namedRes m a =>
   f a -> [NamedResolver m]
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]
useDeriveNamedResolvers ctx
UseNamedResolver namedRes resFun gql val
ctx (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  kindedNamedRefs :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> * -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx -> p (f CUSTOM (input -> a)) -> [ScanRef Proxy (namedRes m)]
kindedNamedRefs ctx
ctx p (f CUSTOM (input -> a))
_ = UseNamedResolver namedRes resFun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   namedRes m a =>
   f a -> [ScanRef Proxy (namedRes m)]
forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   named m a =>
   f a -> [ScanRef Proxy (named m)]
useDeriveNamedRefs ctx
UseNamedResolver namedRes resFun gql val
ctx (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

instance (UseNamedResolver namedRes resFun gql val ~ ctx, namedRes m a) => KindedNamedResolver ctx WRAPPER m (f a) where
  kindedNamedResolver :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> k -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx -> p (f WRAPPER (f a)) -> [NamedResolver m]
kindedNamedResolver ctx
ctx p (f WRAPPER (f a))
_ = UseNamedResolver namedRes resFun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   namedRes m a =>
   f a -> [NamedResolver m]
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]
useDeriveNamedResolvers ctx
UseNamedResolver namedRes resFun gql val
ctx (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  kindedNamedRefs :: forall {k} (namedRes :: (* -> *) -> * -> Constraint)
       (resFun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint) (p :: k -> *)
       (f :: DerivingKind -> k -> k).
(UseNamedResolver namedRes resFun gql val ~ ctx) =>
ctx -> p (f WRAPPER (f a)) -> [ScanRef Proxy (namedRes m)]
kindedNamedRefs ctx
ctx p (f WRAPPER (f a))
_ = UseNamedResolver namedRes resFun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   namedRes m a =>
   f a -> [ScanRef Proxy (namedRes m)]
forall (named :: (* -> *) -> * -> Constraint)
       (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint)
       (val :: * -> Constraint).
UseNamedResolver named fun gql val
-> forall (f :: * -> *) a (m :: * -> *).
   named m a =>
   f a -> [ScanRef Proxy (named m)]
useDeriveNamedRefs ctx
UseNamedResolver namedRes resFun gql val
ctx (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)