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

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

import Control.Monad.Except (throwError)
import Data.Morpheus.Internal.Utils
  ( empty,
    singleton,
  )
import Data.Morpheus.Server.Deriving.Schema.Directive
  ( UseDirective,
    deriveFieldDirectives,
    visitFieldContent,
    visitFieldDescription,
    visitFieldName,
  )
import Data.Morpheus.Server.Deriving.Schema.Enum (defineEnumUnit)
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    FieldRep (..),
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
    outputType,
  )
import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType, useTypename)
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    insertType,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    FieldContent (..),
    FieldDefinition (..),
    FieldsDefinition,
    OBJECT,
    OUT,
    TRUE,
    TypeContent (..),
    TypeDefinition,
    mkField,
    mkType,
    mkTypeRef,
    msg,
    unitFieldName,
    unitTypeName,
    unsafeFromFields,
  )
import Relude hiding (empty)

defineObjectType ::
  CatType kind a ->
  ConsRep (Maybe (FieldContent TRUE kind CONST)) ->
  SchemaT cat ()
defineObjectType :: forall (kind :: TypeCategory) a (cat :: TypeCategory).
CatType kind a
-> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT cat ()
defineObjectType CatType kind a
proxy ConsRep {TypeName
consName :: forall v. ConsRep v -> TypeName
consName :: TypeName
consName, [FieldRep (Maybe (FieldContent TRUE kind CONST))]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (Maybe (FieldContent TRUE kind 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 (FieldContent TRUE kind 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 (kind :: TypeCategory).
FieldRep (Maybe (FieldContent TRUE kind CONST))
-> FieldDefinition kind CONST
repToFieldDefinition [FieldRep (Maybe (FieldContent TRUE kind 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 =>
  UseDirective gql args ->
  CatType cat a ->
  [FieldRep (Maybe (FieldContent TRUE cat CONST))] ->
  SchemaT k (TypeContent TRUE cat CONST)
buildObjectTypeContent :: forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (cat :: TypeCategory) (k :: TypeCategory).
gql a =>
UseDirective gql args
-> CatType cat a
-> [FieldRep (Maybe (FieldContent TRUE cat CONST))]
-> SchemaT k (TypeContent TRUE cat CONST)
buildObjectTypeContent UseDirective gql args
options CatType cat a
scope [FieldRep (Maybe (FieldContent TRUE cat 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 =>
UseDirective gql args
-> CatType kind a
-> FieldDefinition kind CONST
-> SchemaT k (FieldDefinition kind CONST)
setGQLTypeProps UseDirective gql args
options CatType cat a
scope forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: TypeCategory).
FieldRep (Maybe (FieldContent TRUE kind CONST))
-> FieldDefinition kind CONST
repToFieldDefinition) [FieldRep (Maybe (FieldContent TRUE cat 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 ::
  FieldRep (Maybe (FieldContent TRUE kind CONST)) ->
  FieldDefinition kind CONST
repToFieldDefinition :: forall (kind :: TypeCategory).
FieldRep (Maybe (FieldContent TRUE kind CONST))
-> FieldDefinition kind CONST
repToFieldDefinition
  FieldRep
    { fieldSelector :: forall a. FieldRep a -> FieldName
fieldSelector = FieldName
fieldName,
      fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldTypeRef = TypeRef
fieldType,
      Maybe (FieldContent TRUE kind CONST)
fieldValue :: forall a. FieldRep a -> a
fieldValue :: Maybe (FieldContent TRUE kind 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 kind CONST)
fieldContent = Maybe (FieldContent TRUE kind CONST)
fieldValue,
        TypeRef
FieldName
fieldName :: FieldName
fieldType :: TypeRef
fieldType :: TypeRef
fieldName :: FieldName
..
      }

asObjectType ::
  (gql a) =>
  UseGQLType gql ->
  (f a -> SchemaT kind (FieldsDefinition OUT CONST)) ->
  f a ->
  SchemaT kind (TypeDefinition OBJECT CONST)
asObjectType :: forall (gql :: * -> Constraint) a (f :: * -> *)
       (kind :: TypeCategory).
gql a =>
UseGQLType gql
-> (f a -> SchemaT kind (FieldsDefinition OUT CONST))
-> f a
-> SchemaT kind (TypeDefinition OBJECT CONST)
asObjectType UseGQLType gql
gql f a -> SchemaT kind (FieldsDefinition OUT CONST)
f f a
proxy =
  forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType
    (forall (gqlType :: * -> Constraint) a (c :: TypeCategory).
gqlType a =>
UseGQLType gqlType -> CatType c a -> TypeName
useTypename UseGQLType gql
gql (forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType f a
proxy))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s
DataObject []
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> SchemaT kind (FieldsDefinition OUT CONST)
f f a
proxy

withObject :: (gql a) => UseGQLType gql -> CatType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)
withObject :: forall (gql :: * -> Constraint) a (c :: TypeCategory)
       (any :: TypeCategory) (s :: Stage).
gql a =>
UseGQLType gql
-> CatType c a
-> TypeContent TRUE any s
-> SchemaT c (FieldsDefinition c s)
withObject UseGQLType gql
_ CatType c a
InputType DataInputObject {FieldsDefinition 'IN s
inputObjectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition 'IN s
inputObjectFields :: FieldsDefinition 'IN s
inputObjectFields} = forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldsDefinition 'IN s
inputObjectFields
withObject UseGQLType gql
_ CatType c a
OutputType DataObject {FieldsDefinition OUT s
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields} = forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldsDefinition OUT s
objectFields
withObject UseGQLType gql
gql CatType c a
x TypeContent TRUE any s
_ = forall (gql :: * -> Constraint) a (c :: TypeCategory) b.
gql a =>
UseGQLType gql -> CatType c a -> SchemaT c b
failureOnlyObject UseGQLType gql
gql CatType c a
x

failureOnlyObject :: (gql a) => UseGQLType gql -> CatType c a -> SchemaT c b
failureOnlyObject :: forall (gql :: * -> Constraint) a (c :: TypeCategory) b.
gql a =>
UseGQLType gql -> CatType c a -> SchemaT c b
failureOnlyObject UseGQLType gql
gql CatType c a
proxy = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall a. Msg a => a -> GQLError
msg (forall (gqlType :: * -> Constraint) a (c :: TypeCategory).
gqlType a =>
UseGQLType gqlType -> CatType c a -> TypeName
useTypename UseGQLType gql
gql CatType c a
proxy) forall a. Semigroup a => a -> a -> a
<> GQLError
" should have only one nonempty constructor"

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 => UseDirective 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 =>
UseDirective gql args
-> CatType kind a
-> FieldDefinition kind CONST
-> SchemaT k (FieldDefinition kind CONST)
setGQLTypeProps UseDirective 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 =>
UseDirective gql args
-> f a -> FieldName -> SchemaT kind (Directives CONST)
deriveFieldDirectives UseDirective 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 =>
UseDirective gql args -> f a -> FieldName -> FieldName
visitFieldName UseDirective gql args
options CatType kind a
proxy FieldName
fieldName,
        fieldDescription :: Maybe Description
fieldDescription = forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *).
gql a =>
UseDirective gql args
-> f a -> FieldName -> Maybe Description -> Maybe Description
visitFieldDescription UseDirective 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 =>
UseDirective gql args
-> CatType kind a
-> FieldName
-> Maybe (FieldContent TRUE kind CONST)
-> Maybe (FieldContent TRUE kind CONST)
visitFieldContent UseDirective 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
..
      }