NamedResolverFun.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# 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.Generic
  ( GRep,
    GRepFun (..),
    GRepValue (..),
    deriveValue,
  )
import Data.Morpheus.Server.Deriving.Internal.Directive
  ( UseDeriving,
    toFieldRes,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
    Kinded (..),
    outputType,
  )
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseGQLType (..),
    UseNamedResolver (..),
    useDecodeArguments,
  )
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 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 ctx x = traverse encodeNode x
  where
    encodeNode (Just v) = convertNamedNode (namedDrv ctx) (Identity x) (deriveValue (getOptions ctx) v)
    encodeNode Nothing = pure NamedNullResolver

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

instance (EncodeScalar a, Monad m) => KindedNamedFunValue ctx SCALAR m a where
  kindedNamedFunValue _ = pure . ResScalar . encodeScalar . unkind

instance (MonadError GQLError m) => KindedNamedFunValue ctx TYPE m a where
  kindedNamedFunValue _ _ = throwError (internal "types are resolved by Refs")

instance (UseNamedResolver namedRes res gql val ~ ctx, Applicative m, res m a) => KindedNamedFunValue ctx WRAPPER m [a] where
  kindedNamedFunValue ctx = fmap ResList . traverse (useNamedFieldResolver ctx) . unkind

instance (UseNamedResolver namedRes res gql val ~ ctx, gql a, res m a, Applicative m) => KindedNamedFunValue ctx WRAPPER m (Maybe a) where
  kindedNamedFunValue ctx (Kinded (Just x)) = useNamedFieldResolver ctx x
  kindedNamedFunValue _ (Kinded Nothing) = pure mkNull

instance (UseNamedResolver namedRes res gql val ~ ctx, Monad m, gql a, ToJSON (NamedRef a)) => KindedNamedFunValue ctx CUSTOM m (NamedResolverT m a) where
  kindedNamedFunValue ctx = encodeRef . unkind
    where
      name :: TypeName
      name = useTypename ctx (OutputType :: CatType OUT a)
      encodeRef :: (Monad m) => NamedResolverT m a -> m (ResolverValue m)
      encodeRef (NamedResolverT ref) = do
        value <- replaceValue . toJSON <$> ref
        case value of
          (List ls) -> pure $ mkList $ map (packRef name) ls
          _ -> pure $ packRef name value

packRef :: (Applicative m) => TypeName -> ValidValue -> ResolverValue m
packRef name v = ResRef $ pure $ NamedResolverRef name [v]

instance (UseNamedResolver namedRes res gql val ~ ctx, Monad m, val a, MonadResolver m, res m b) => KindedNamedFunValue ctx CUSTOM m (a -> b) where
  kindedNamedFunValue ctx (Kinded f) =
    getArguments
      >>= liftState
      . useDecodeArguments (namedDrv ctx)
      >>= useNamedFieldResolver ctx
      . f

getOptions :: UseNamedResolver namedRes res gql val -> GRepFun gql (res m) Identity (m (ResolverValue m))
getOptions ctx =
  GRepFun
    { grepFun = useNamedFieldResolver ctx . runIdentity,
      grepTypename = useTypename ctx . outputType,
      grepWrappers = useWrappers ctx . outputType
    }

convertNamedNode ::
  (MonadError GQLError m, gql a) =>
  UseDeriving gql val ->
  f a ->
  GRepValue (m (ResolverValue m)) ->
  m (NamedResolverResult m)
convertNamedNode _ _ GRepValueEnum {..} = pure $ NamedEnumResolver enumVariantName
convertNamedNode drv proxy GRepValueObject {..} = pure $ NamedObjectResolver $ ObjectTypeResolver $ fromList (toFieldRes drv proxy <$> objectFields)
convertNamedNode _ _ GRepValueUnionRef {..} = NamedUnionResolver <$> (unionRefValue >>= getRef)
convertNamedNode _ _ GRepValueUnion {} = throwError "only union references are supported!"

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