NamedResolver.hs

{-# 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 ctx _ xs = traverse (liftState . useDecodeValue ctx) xs >>= 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 ctx _ =
    [ NamedResolver
        { resolverName = useTypename ctx (outputType proxy),
          resolverFun = decodeValues (namedDrv ctx) proxy >=> pure . map (maybe NamedNullResolver (NamedScalarResolver . encodeScalar))
        }
    ]
    where
      proxy = Proxy @a
  kindedNamedRefs ctx _ = [scanLeaf fp proxy]
    where
      fp = useFingerprint ctx (outputType proxy)
      proxy = 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 ctx _ =
    [ NamedResolver
        { resolverName = useTypename ctx (outputType proxy),
          resolverFun = decodeValues (namedDrv ctx) proxy >=> deriveNamedResolverFun ctx
        }
    ]
    where
      proxy = Proxy @a

  kindedNamedRefs ctx _ = [scanNode True (useFingerprint ctx (outputType proxy)) proxy]
    where
      proxy = Proxy @a

instance (UseNamedResolver namedRes resFun gql val ~ ctx, namedRes m a) => KindedNamedResolver ctx CUSTOM m (NamedResolverT m a) where
  kindedNamedResolver ctx _ = useDeriveNamedResolvers ctx (Proxy @a)
  kindedNamedRefs ctx _ = useDeriveNamedRefs ctx (Proxy @a)

instance (UseNamedResolver namedRes resFun gql val ~ ctx, namedRes m a) => KindedNamedResolver ctx CUSTOM m (input -> a) where
  kindedNamedResolver ctx _ = useDeriveNamedResolvers ctx (Proxy @a)
  kindedNamedRefs ctx _ = useDeriveNamedRefs ctx (Proxy @a)

instance (UseNamedResolver namedRes resFun gql val ~ ctx, namedRes m a) => KindedNamedResolver ctx WRAPPER m (f a) where
  kindedNamedResolver ctx _ = useDeriveNamedResolvers ctx (Proxy @a)
  kindedNamedRefs ctx _ = useDeriveNamedRefs ctx (Proxy @a)