{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Morpheus.Server.Deriving.Schema.TypeContent
  ( buildTypeContent,
    insertTypeContent,
    deriveTypeContentWith,
    deriveFieldsWith,
  )
where

import Data.Morpheus.Server.Deriving.Schema.Directive (UseDirective (..), deriveTypeDirectives, visitTypeDescription)
import Data.Morpheus.Server.Deriving.Schema.Enum
  ( buildEnumTypeContent,
  )
import Data.Morpheus.Server.Deriving.Schema.Internal
  ( CatType,
    TyContent,
  )
import Data.Morpheus.Server.Deriving.Schema.Object
  ( buildObjectTypeContent,
    withObject,
  )
import Data.Morpheus.Server.Deriving.Schema.Union (buildUnionTypeContent)
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    DeriveTypeOptions,
    DeriveWith,
    deriveTypeWith,
    isEmptyConstraint,
    unpackMonad,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded (typeCat)
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseGQLType (..),
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    updateSchema,
  )
import Data.Morpheus.Types.Internal.AST
import GHC.Generics (Rep)

buildTypeContent ::
  (gql a) =>
  UseDirective gql args ->
  CatType kind a ->
  [ConsRep (TyContent kind)] ->
  SchemaT kind (TypeContent TRUE kind CONST)
buildTypeContent :: forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (kind :: TypeCategory).
gql a =>
UseDirective gql args
-> CatType kind a
-> [ConsRep (TyContent kind)]
-> SchemaT kind (TypeContent TRUE kind CONST)
buildTypeContent UseDirective gql args
options CatType kind a
scope [ConsRep (TyContent kind)]
cons | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. ConsRep a -> Bool
isEmptyConstraint [ConsRep (TyContent kind)]
cons = forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (kind :: TypeCategory) (k :: TypeCategory).
gql a =>
UseDirective gql args
-> CatType kind a
-> [TypeName]
-> SchemaT k (TypeContent TRUE kind CONST)
buildEnumTypeContent UseDirective gql args
options CatType kind a
scope (forall v. ConsRep v -> TypeName
consName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConsRep (TyContent kind)]
cons)
buildTypeContent UseDirective gql args
options CatType kind a
scope [ConsRep {[FieldRep (TyContent kind)]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (TyContent kind)]
consFields}] = 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 kind a
scope [FieldRep (TyContent kind)]
consFields
buildTypeContent UseDirective gql args
options CatType kind a
scope [ConsRep (TyContent kind)]
cons = forall (gql :: * -> Constraint) a (kind :: TypeCategory)
       (k :: TypeCategory).
gql a =>
UseGQLType gql
-> CatType kind a
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT k (TypeContent TRUE kind CONST)
buildUnionTypeContent (forall (gql :: * -> Constraint) (args :: * -> Constraint).
UseDirective gql args -> UseGQLType gql
dirGQL UseDirective gql args
options) CatType kind a
scope [ConsRep (TyContent kind)]
cons

insertTypeContent ::
  forall k gql args a.
  (gql a) =>
  UseDirective gql args ->
  (CatType k a -> SchemaT k (TypeContent TRUE k CONST)) ->
  CatType k a ->
  SchemaT k ()
insertTypeContent :: forall (k :: TypeCategory) (gql :: * -> Constraint)
       (args :: * -> Constraint) a.
gql a =>
UseDirective gql args
-> (CatType k a -> SchemaT k (TypeContent TRUE k CONST))
-> CatType k a
-> SchemaT k ()
insertTypeContent options :: UseDirective gql args
options@UseDirective {dirGQL :: forall (gql :: * -> Constraint) (args :: * -> Constraint).
UseDirective gql args -> UseGQLType gql
dirGQL = UseGQLType {forall (f :: * -> *) a. gql a => f a -> TypeCategory -> TypeData
forall (f :: * -> *) a. gql a => TypeCategory -> f a -> TypeName
forall (f :: * -> *) a.
gql a =>
TypeCategory -> f a -> TypeFingerprint
__useTypeData :: forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (f :: * -> *) a. gql a => f a -> TypeCategory -> TypeData
__useTypename :: forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (f :: * -> *) a. gql a => TypeCategory -> f a -> TypeName
__useFingerprint :: forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (f :: * -> *) a.
   gql a =>
   TypeCategory -> f a -> TypeFingerprint
__useTypeData :: forall (f :: * -> *) a. gql a => f a -> TypeCategory -> TypeData
__useTypename :: forall (f :: * -> *) a. gql a => TypeCategory -> f a -> TypeName
__useFingerprint :: forall (f :: * -> *) a.
gql a =>
TypeCategory -> f a -> TypeFingerprint
..}} CatType k a -> SchemaT k (TypeContent TRUE k CONST)
f CatType k a
proxy =
  forall a (cat' :: TypeCategory) (cat :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (TypeDefinition cat CONST))
-> a
-> SchemaT cat' ()
updateSchema
    (forall (f :: * -> *) a.
gql a =>
TypeCategory -> f a -> TypeFingerprint
__useFingerprint TypeCategory
category CatType k a
proxy)
    CatType k a -> SchemaT k (TypeDefinition k CONST)
deriveD
    CatType k a
proxy
  where
    category :: TypeCategory
category = forall {k} (c :: TypeCategory) (a :: k).
CatType c a -> TypeCategory
typeCat CatType k a
proxy
    deriveD :: CatType k a -> SchemaT k (TypeDefinition k CONST)
deriveD CatType k a
x = do
      TypeContent TRUE k CONST
content <- CatType k a -> SchemaT k (TypeContent TRUE k CONST)
f CatType k a
x
      Directives CONST
dirs <- forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *) (kind :: TypeCategory).
gql a =>
UseDirective gql args -> f a -> SchemaT kind (Directives CONST)
deriveTypeDirectives UseDirective gql args
options CatType k a
proxy
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
          (forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *).
gql a =>
UseDirective gql args
-> f a -> Maybe Description -> Maybe Description
visitTypeDescription UseDirective gql args
options CatType k a
proxy forall a. Maybe a
Nothing)
          (forall (f :: * -> *) a. gql a => TypeCategory -> f a -> TypeName
__useTypename TypeCategory
category CatType k a
proxy)
          Directives CONST
dirs
          TypeContent TRUE k CONST
content

deriveTypeContentWith ::
  ( DeriveWith gql derive (SchemaT kind (TyContent kind)) (Rep a),
    gql a
  ) =>
  UseDirective gql args ->
  DeriveTypeOptions kind gql derive (SchemaT kind (TyContent kind)) ->
  CatType kind a ->
  SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContentWith :: forall (gql :: * -> Constraint) (derive :: * -> Constraint)
       (kind :: TypeCategory) a (args :: * -> Constraint).
(DeriveWith gql derive (SchemaT kind (TyContent kind)) (Rep a),
 gql a) =>
UseDirective gql args
-> DeriveTypeOptions
     kind gql derive (SchemaT kind (TyContent kind))
-> CatType kind a
-> SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContentWith UseDirective gql args
options DeriveTypeOptions kind gql derive (SchemaT kind (TyContent kind))
x CatType kind a
kindedProxy =
  forall (m :: * -> *) a. Monad m => [ConsRep (m a)] -> m [ConsRep a]
unpackMonad
    ( forall {k} (kind :: k) (gql :: * -> Constraint)
       (c :: * -> Constraint) v (kinded :: k -> * -> *) a.
DeriveWith gql c v (Rep a) =>
DeriveTypeOptions kind gql c v -> kinded kind a -> [ConsRep v]
deriveTypeWith DeriveTypeOptions kind gql derive (SchemaT kind (TyContent kind))
x CatType kind a
kindedProxy
    )
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (kind :: TypeCategory).
gql a =>
UseDirective gql args
-> CatType kind a
-> [ConsRep (TyContent kind)]
-> SchemaT kind (TypeContent TRUE kind CONST)
buildTypeContent UseDirective gql args
options CatType kind a
kindedProxy

deriveFieldsWith ::
  ( gql a,
    DeriveWith gql derive (SchemaT cat (TyContent cat)) (Rep a)
  ) =>
  UseDirective gql args ->
  DeriveTypeOptions cat gql derive (SchemaT cat (TyContent cat)) ->
  CatType cat a ->
  SchemaT cat (FieldsDefinition cat CONST)
deriveFieldsWith :: forall (gql :: * -> Constraint) a (derive :: * -> Constraint)
       (cat :: TypeCategory) (args :: * -> Constraint).
(gql a,
 DeriveWith gql derive (SchemaT cat (TyContent cat)) (Rep a)) =>
UseDirective gql args
-> DeriveTypeOptions cat gql derive (SchemaT cat (TyContent cat))
-> CatType cat a
-> SchemaT cat (FieldsDefinition cat CONST)
deriveFieldsWith UseDirective gql args
dirs DeriveTypeOptions cat gql derive (SchemaT cat (TyContent cat))
cont CatType cat a
kindedType = forall (gql :: * -> Constraint) (derive :: * -> Constraint)
       (kind :: TypeCategory) a (args :: * -> Constraint).
(DeriveWith gql derive (SchemaT kind (TyContent kind)) (Rep a),
 gql a) =>
UseDirective gql args
-> DeriveTypeOptions
     kind gql derive (SchemaT kind (TyContent kind))
-> CatType kind a
-> SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContentWith UseDirective gql args
dirs DeriveTypeOptions cat gql derive (SchemaT cat (TyContent cat))
cont CatType cat a
kindedType forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 (forall (gql :: * -> Constraint) (args :: * -> Constraint).
UseDirective gql args -> UseGQLType gql
dirGQL UseDirective gql args
dirs) CatType cat a
kindedType