{-# 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.Enum (defineEnumUnit)
import Data.Morpheus.Server.Deriving.Schema.Internal
  ( lookupDescription,
    lookupDirectives,
    lookupFieldContent,
  )
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    FieldRep (..),
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CategoryValue (..),
    KindedType (..),
    outputType,
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (..),
    TypeData (..),
    __typeData,
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    insertType,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    FieldContent (..),
    FieldDefinition (..),
    FieldsDefinition,
    OBJECT,
    OUT,
    TRUE,
    TypeCategory,
    TypeContent (..),
    TypeDefinition,
    mkField,
    mkType,
    mkTypeRef,
    msg,
    unitFieldName,
    unitTypeName,
    unpackName,
    unsafeFromFields,
  )
import Relude hiding (empty)

defineObjectType ::
  KindedType kind a ->
  ConsRep (Maybe (FieldContent TRUE kind CONST)) ->
  SchemaT cat ()
defineObjectType :: forall (kind :: TypeCategory) a (cat :: TypeCategory).
KindedType kind a
-> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT cat ()
defineObjectType KindedType 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.
KindedType kind a
-> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
mkObjectTypeContent KindedType 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 ::
  (Applicative f, GQLType a) =>
  KindedType cat a ->
  [FieldRep (Maybe (FieldContent TRUE cat CONST))] ->
  f (TypeContent TRUE cat CONST)
buildObjectTypeContent :: forall (f :: * -> *) a (cat :: TypeCategory).
(Applicative f, GQLType a) =>
KindedType cat a
-> [FieldRep (Maybe (FieldContent TRUE cat CONST))]
-> f (TypeContent TRUE cat CONST)
buildObjectTypeContent KindedType cat a
scope [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.
KindedType kind a
-> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST
mkObjectTypeContent KindedType cat a
scope
    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 a (kind :: TypeCategory).
GQLType a =>
KindedType kind a
-> FieldDefinition kind CONST -> FieldDefinition kind CONST
setGQLTypeProps KindedType 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

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 ::
  (GQLType a) =>
  (f a -> SchemaT kind (FieldsDefinition OUT CONST)) ->
  f a ->
  SchemaT kind (TypeDefinition OBJECT CONST)
asObjectType :: forall a (f :: * -> *) (kind :: TypeCategory).
GQLType a =>
(f a -> SchemaT kind (FieldsDefinition OUT CONST))
-> f a -> SchemaT kind (TypeDefinition OBJECT CONST)
asObjectType 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
    (TypeData -> TypeName
gqlTypeName (forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData (forall {k} (f :: k -> *) (a :: k). f a -> KindedType 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 :: (GQLType a, CategoryValue c) => KindedType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)
withObject :: forall a (c :: TypeCategory) (any :: TypeCategory) (s :: Stage).
(GQLType a, CategoryValue c) =>
KindedType c a
-> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)
withObject KindedType 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 KindedType 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 KindedType c a
x TypeContent TRUE any s
_ = forall (c :: TypeCategory) a b.
(GQLType a, CategoryValue c) =>
KindedType c a -> SchemaT c b
failureOnlyObject KindedType c a
x

failureOnlyObject :: forall (c :: TypeCategory) a b. (GQLType a, CategoryValue c) => KindedType c a -> SchemaT c b
failureOnlyObject :: forall (c :: TypeCategory) a b.
(GQLType a, CategoryValue c) =>
KindedType c a -> SchemaT c b
failureOnlyObject KindedType 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 (TypeData -> TypeName
gqlTypeName forall a b. (a -> b) -> a -> b
$ forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData KindedType c a
proxy) forall a. Semigroup a => a -> a -> a
<> GQLError
" should have only one nonempty constructor"

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

setGQLTypeProps :: GQLType a => KindedType kind a -> FieldDefinition kind CONST -> FieldDefinition kind CONST
setGQLTypeProps :: forall a (kind :: TypeCategory).
GQLType a =>
KindedType kind a
-> FieldDefinition kind CONST -> FieldDefinition kind CONST
setGQLTypeProps KindedType 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
..} =
  FieldDefinition
    { FieldName
fieldName :: FieldName
fieldName :: FieldName
fieldName,
      fieldDescription :: Maybe Description
fieldDescription = forall a (f :: * -> *).
GQLType a =>
f a -> Description -> Maybe Description
lookupDescription KindedType kind a
proxy Description
key,
      fieldDirectives :: Directives CONST
fieldDirectives = forall a (f :: * -> *).
GQLType a =>
f a -> Description -> Directives CONST
lookupDirectives KindedType kind a
proxy Description
key,
      fieldContent :: Maybe (FieldContent TRUE kind CONST)
fieldContent = forall a (kind :: TypeCategory).
GQLType a =>
KindedType kind a
-> Description -> Maybe (FieldContent TRUE kind CONST)
lookupFieldContent KindedType kind a
proxy Description
key forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (FieldContent TRUE kind CONST)
fieldContent,
      TypeRef
fieldType :: TypeRef
fieldType :: TypeRef
..
    }
  where
    key :: Description
key = forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fieldName