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

module Data.Morpheus.Server.Deriving.Kinded.Arguments
  ( DeriveFieldArguments (..),
    HasArguments,
  )
where

import Data.Morpheus.Internal.Ext (GQLResult, (<:>))
import Data.Morpheus.Internal.Utils (empty)
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
    inputType,
  )
import Data.Morpheus.Server.Deriving.Utils.Types (nodeToType, typeToArguments)
import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..))
import Data.Morpheus.Types.Internal.AST
  ( ArgumentsDefinition,
    CONST,
    OUT,
  )
import Relude hiding (empty)

type family HasArguments a where
  HasArguments (a -> b) = (a -> b)
  HasArguments a = ()

class DeriveFieldArguments ctx a where
  deriveFieldArguments :: ctx -> f a -> GQLResult (ArgumentsDefinition CONST)

instance DeriveFieldArguments ctx () where
  deriveFieldArguments :: forall (f :: * -> *).
ctx -> f () -> GQLResult (ArgumentsDefinition CONST)
deriveFieldArguments ctx
_ f ()
_ = ArgumentsDefinition CONST -> GQLResult (ArgumentsDefinition CONST)
forall a. a -> Result GQLError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArgumentsDefinition CONST
forall coll. Empty coll => coll
empty

instance (UseGQLType ctx gql, gql b, gql a) => DeriveFieldArguments ctx (a -> b) where
  deriveFieldArguments :: forall (f :: * -> *).
ctx -> f (a -> b) -> GQLResult (ArgumentsDefinition CONST)
deriveFieldArguments ctx
gql f (a -> b)
_ = do
    ArgumentsDefinition CONST
a <- ctx -> CatType IN a -> GQLResult (GQLTypeNode IN)
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> GQLResult (GQLTypeNode c)
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> GQLResult (GQLTypeNode c)
useDeriveNode ctx
gql (Proxy a -> CatType IN a
forall {k} (f :: k -> *) (a :: k). f a -> CatType IN a
inputType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) GQLResult (GQLTypeNode IN)
-> (GQLTypeNode IN -> Result GQLError (TypeDefinition IN CONST))
-> Result GQLError (TypeDefinition IN CONST)
forall a b.
Result GQLError a -> (a -> Result GQLError b) -> Result GQLError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GQLTypeNode IN -> Result GQLError (TypeDefinition IN CONST)
forall (m :: * -> *) (c :: TypeCategory).
DerivingMonad m =>
GQLTypeNode c -> m (TypeDefinition c CONST)
nodeToType Result GQLError (TypeDefinition IN CONST)
-> (TypeDefinition IN CONST
    -> GQLResult (ArgumentsDefinition CONST))
-> GQLResult (ArgumentsDefinition CONST)
forall a b.
Result GQLError a -> (a -> Result GQLError b) -> Result GQLError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeDefinition IN CONST -> GQLResult (ArgumentsDefinition CONST)
forall (m :: * -> *).
DerivingMonad m =>
TypeDefinition IN CONST -> m (ArgumentsDefinition CONST)
typeToArguments
    ArgumentsDefinition CONST
b <- ctx -> CatType OUT b -> GQLResult (ArgumentsDefinition CONST)
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> GQLResult (ArgumentsDefinition CONST)
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> GQLResult (ArgumentsDefinition CONST)
useDeriveFieldArgs ctx
gql (CatType OUT b
forall {k} (a :: k). CatType OUT a
OutputType :: CatType OUT b)
    ArgumentsDefinition CONST
a ArgumentsDefinition CONST
-> ArgumentsDefinition CONST
-> GQLResult (ArgumentsDefinition CONST)
forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> ArgumentsDefinition CONST
b