{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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 ((<:>))
import Data.Morpheus.Server.Deriving.Internal.Schema.Internal
  ( CatType,
    deriveTypeAsArguments,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
  )
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseDeriving (..),
    UseGQLType (..),
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    withInput,
  )
import Data.Morpheus.Types.Internal.AST
  ( ArgumentsDefinition,
    CONST,
    OUT,
  )
import Relude

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

class DeriveFieldArguments gql a where
  deriveFieldArguments :: UseDeriving gql val -> f a -> SchemaT OUT (Maybe (ArgumentsDefinition CONST))

instance DeriveFieldArguments gql () where
  deriveFieldArguments :: forall (val :: * -> Constraint) (f :: * -> *).
UseDeriving gql val
-> f () -> SchemaT OUT (Maybe (ArgumentsDefinition CONST))
deriveFieldArguments UseDeriving gql val
_ f ()
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

instance (gql b, gql a) => DeriveFieldArguments gql (a -> b) where
  deriveFieldArguments :: forall (val :: * -> Constraint) (f :: * -> *).
UseDeriving gql val
-> f (a -> b) -> SchemaT OUT (Maybe (ArgumentsDefinition CONST))
deriveFieldArguments UseDeriving {UseValue val
UseGQLType gql
forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val
dirGQL :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseGQLType gql
dirArgs :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
__directives :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val
-> forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val
dirGQL :: UseGQLType gql
dirArgs :: UseValue val
__directives :: forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val
..} f (a -> b)
_ = do
    ArgumentsDefinition CONST
a <- forall a. SchemaT IN a -> SchemaT OUT a
withInput forall a b. (a -> b) -> a -> b
$ forall (gql :: * -> Constraint) a (f :: * -> *).
gql a =>
UseGQLType gql -> f a -> SchemaT IN (ArgumentsDefinition CONST)
deriveTypeAsArguments UseGQLType gql
dirGQL (forall {k} (t :: k). Proxy t
Proxy @a)
    Maybe (ArgumentsDefinition CONST)
b <- forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a.
   gql a =>
   CatType c a -> SchemaT c (Maybe (ArgumentsDefinition CONST))
useDeriveFieldArguments UseGQLType gql
dirGQL (forall {k} (a :: k). CatType OUT a
OutputType :: CatType OUT b)
    case Maybe (ArgumentsDefinition CONST)
b of
      Just ArgumentsDefinition CONST
x -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArgumentsDefinition CONST
a forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> ArgumentsDefinition CONST
x)
      Maybe (ArgumentsDefinition CONST)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ArgumentsDefinition CONST
a