{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

module Data.Morpheus.Server.Deriving.Internal.Schema.Object
  ( buildObjectTypeContent,
    defineObjectType,
  )
where

import Data.Morpheus.Internal.Utils
  ( empty,
    singleton,
  )
import Data.Morpheus.Server.Deriving.Internal.Schema.Directive
  ( UseDeriving,
    deriveFieldDirectives,
    visitFieldContent,
    visitFieldDescription,
    visitFieldName,
  )
import Data.Morpheus.Server.Deriving.Internal.Schema.Enum
  ( defineEnumUnit,
  )
import Data.Morpheus.Server.Deriving.Utils.GRep
  ( ConsRep (..),
    FieldRep (..),
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    insertType,
  )
import Data.Morpheus.Types.Internal.AST (ArgumentsDefinition, CONST, FieldContent (..), FieldDefinition (..), FieldsDefinition, TRUE, TypeContent (..), mkField, mkType, mkTypeRef, unitFieldName, unitTypeName, unsafeFromFields)
import Relude hiding (empty)

defineObjectType ::
  CatType kind a ->
  ConsRep (Maybe (ArgumentsDefinition CONST)) ->
  SchemaT cat ()
defineObjectType :: forall (kind :: TypeCategory) a (cat :: TypeCategory).
CatType kind a
-> ConsRep (Maybe (ArgumentsDefinition CONST)) -> SchemaT cat ()
defineObjectType CatType kind a
proxy ConsRep {TypeName
consName :: forall v. ConsRep v -> TypeName
consName :: TypeName
consName, [FieldRep (Maybe (ArgumentsDefinition CONST))]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (Maybe (ArgumentsDefinition CONST))]
consFields} = forall (cat :: TypeCategory) (cat' :: TypeCategory).
TypeDefinition cat CONST -> SchemaT cat' ()
insertType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
consName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: TypeCategory) a.
CatType kind a
-> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
mkObjectTypeContent CatType kind a
proxy forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SchemaT cat (FieldsDefinition kind CONST)
fields
  where
    fields :: SchemaT cat (FieldsDefinition kind CONST)
fields
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldRep (Maybe (ArgumentsDefinition CONST))]
consFields = forall (cat :: TypeCategory). SchemaT cat ()
defineEnumUnit forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton FieldName
unitFieldName forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s
mkFieldUnit
      | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (cat :: TypeCategory) (s :: Stage).
[FieldDefinition cat s] -> FieldsDefinition cat s
unsafeFromFields forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (c :: TypeCategory) a.
CatType c a
-> FieldRep (Maybe (ArgumentsDefinition CONST))
-> FieldDefinition c CONST
repToFieldDefinition CatType kind a
proxy) [FieldRep (Maybe (ArgumentsDefinition CONST))]
consFields

mkFieldUnit :: FieldDefinition cat s
mkFieldUnit :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s
mkFieldUnit = forall (cat :: TypeCategory) (s :: Stage).
Maybe (FieldContent TRUE cat s)
-> FieldName -> TypeRef -> FieldDefinition cat s
mkField forall a. Maybe a
Nothing FieldName
unitFieldName (TypeName -> TypeRef
mkTypeRef TypeName
unitTypeName)

buildObjectTypeContent ::
  gql a =>
  UseDeriving gql args ->
  CatType cat a ->
  [FieldRep (Maybe (ArgumentsDefinition CONST))] ->
  SchemaT k (TypeContent TRUE cat CONST)
buildObjectTypeContent :: forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (cat :: TypeCategory) (k :: TypeCategory).
gql a =>
UseDeriving gql args
-> CatType cat a
-> [FieldRep (Maybe (ArgumentsDefinition CONST))]
-> SchemaT k (TypeContent TRUE cat CONST)
buildObjectTypeContent UseDeriving gql args
options CatType cat a
scope [FieldRep (Maybe (ArgumentsDefinition CONST))]
consFields = do
  [FieldDefinition cat CONST]
xs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (kind :: TypeCategory) (k :: TypeCategory).
gql a =>
UseDeriving gql args
-> CatType kind a
-> FieldDefinition kind CONST
-> SchemaT k (FieldDefinition kind CONST)
setGQLTypeProps UseDeriving gql args
options CatType cat a
scope forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (c :: TypeCategory) a.
CatType c a
-> FieldRep (Maybe (ArgumentsDefinition CONST))
-> FieldDefinition c CONST
repToFieldDefinition CatType cat a
scope) [FieldRep (Maybe (ArgumentsDefinition CONST))]
consFields
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (kind :: TypeCategory) a.
CatType kind a
-> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
mkObjectTypeContent CatType cat a
scope forall a b. (a -> b) -> a -> b
$ forall (cat :: TypeCategory) (s :: Stage).
[FieldDefinition cat s] -> FieldsDefinition cat s
unsafeFromFields [FieldDefinition cat CONST]
xs

repToFieldDefinition ::
  CatType c a ->
  FieldRep (Maybe (ArgumentsDefinition CONST)) ->
  FieldDefinition c CONST
repToFieldDefinition :: forall (c :: TypeCategory) a.
CatType c a
-> FieldRep (Maybe (ArgumentsDefinition CONST))
-> FieldDefinition c CONST
repToFieldDefinition
  CatType c a
x
  FieldRep
    { fieldSelector :: forall a. FieldRep a -> FieldName
fieldSelector = FieldName
fieldName,
      fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldTypeRef = TypeRef
fieldType,
      Maybe (ArgumentsDefinition CONST)
fieldValue :: forall a. FieldRep a -> a
fieldValue :: Maybe (ArgumentsDefinition CONST)
fieldValue
    } =
    FieldDefinition
      { fieldDescription :: Maybe Description
fieldDescription = forall a. Monoid a => a
mempty,
        fieldDirectives :: Directives CONST
fieldDirectives = forall coll. Empty coll => coll
empty,
        fieldContent :: Maybe (FieldContent TRUE c CONST)
fieldContent = forall (c :: TypeCategory) a.
CatType c a
-> Maybe (ArgumentsDefinition CONST)
-> Maybe (FieldContent TRUE c CONST)
toFieldContent CatType c a
x Maybe (ArgumentsDefinition CONST)
fieldValue,
        TypeRef
FieldName
fieldName :: FieldName
fieldType :: TypeRef
fieldType :: TypeRef
fieldName :: FieldName
..
      }

toFieldContent :: CatType c a -> Maybe (ArgumentsDefinition CONST) -> Maybe (FieldContent TRUE c CONST)
toFieldContent :: forall (c :: TypeCategory) a.
CatType c a
-> Maybe (ArgumentsDefinition CONST)
-> Maybe (FieldContent TRUE c CONST)
toFieldContent CatType c a
OutputType (Just ArgumentsDefinition CONST
x) = forall a. a -> Maybe a
Just (forall (s :: Stage) (cat :: TypeCategory).
ArgumentsDefinition s -> FieldContent ('OUT <=? cat) cat s
FieldArgs ArgumentsDefinition CONST
x)
toFieldContent CatType c a
_ Maybe (ArgumentsDefinition CONST)
_ = forall a. Maybe a
Nothing

mkObjectTypeContent :: CatType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
mkObjectTypeContent :: forall (kind :: TypeCategory) a.
CatType kind a
-> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
mkObjectTypeContent CatType kind a
InputType = forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition 'IN s -> TypeContent (INPUT_OBJECT <=? a) a s
DataInputObject
mkObjectTypeContent CatType kind a
OutputType = forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition 'OUT s -> TypeContent (OBJECT <=? a) a s
DataObject []

setGQLTypeProps :: gql a => UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> SchemaT k (FieldDefinition kind CONST)
setGQLTypeProps :: forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (kind :: TypeCategory) (k :: TypeCategory).
gql a =>
UseDeriving gql args
-> CatType kind a
-> FieldDefinition kind CONST
-> SchemaT k (FieldDefinition kind CONST)
setGQLTypeProps UseDeriving gql args
options CatType kind a
proxy FieldDefinition {Maybe Description
Maybe (FieldContent TRUE kind CONST)
TypeRef
FieldName
Directives CONST
fieldDirectives :: Directives CONST
fieldContent :: Maybe (FieldContent TRUE kind CONST)
fieldType :: TypeRef
fieldName :: FieldName
fieldDescription :: Maybe Description
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Directives s
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Description
..} = do
  Directives CONST
dirs <- forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *) (kind :: TypeCategory).
gql a =>
UseDeriving gql args
-> f a -> FieldName -> SchemaT kind (Directives CONST)
deriveFieldDirectives UseDeriving gql args
options CatType kind a
proxy FieldName
fieldName
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    FieldDefinition
      { fieldName :: FieldName
fieldName = forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *).
gql a =>
UseDeriving gql args -> f a -> FieldName -> FieldName
visitFieldName UseDeriving gql args
options CatType kind a
proxy FieldName
fieldName,
        fieldDescription :: Maybe Description
fieldDescription = forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *).
gql a =>
UseDeriving gql args
-> f a -> FieldName -> Maybe Description -> Maybe Description
visitFieldDescription UseDeriving gql args
options CatType kind a
proxy FieldName
fieldName forall a. Maybe a
Nothing,
        fieldContent :: Maybe (FieldContent TRUE kind CONST)
fieldContent = forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (kind :: TypeCategory).
gql a =>
UseDeriving gql args
-> CatType kind a
-> FieldName
-> Maybe (FieldContent TRUE kind CONST)
-> Maybe (FieldContent TRUE kind CONST)
visitFieldContent UseDeriving gql args
options CatType kind a
proxy FieldName
fieldName Maybe (FieldContent TRUE kind CONST)
fieldContent,
        fieldDirectives :: Directives CONST
fieldDirectives = Directives CONST
dirs,
        TypeRef
fieldType :: TypeRef
fieldType :: TypeRef
..
      }