{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}

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

import Data.Morpheus.Server.Deriving.Schema.Directive (deriveTypeDirectives)
import Data.Morpheus.Server.Deriving.Schema.Enum
  ( buildEnumTypeContent,
  )
import Data.Morpheus.Server.Deriving.Schema.Internal
  ( KindedType (..),
    TyContent,
  )
import Data.Morpheus.Server.Deriving.Schema.Object
  ( buildObjectTypeContent,
  )
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
  ( CategoryValue (..),
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (..),
    deriveFingerprint,
    deriveTypename,
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    updateSchema,
  )
import Data.Morpheus.Types.Internal.AST
import GHC.Generics (Rep)

buildTypeContent ::
  (GQLType a, CategoryValue kind) =>
  KindedType kind a ->
  [ConsRep (TyContent kind)] ->
  SchemaT kind (TypeContent TRUE kind CONST)
buildTypeContent :: forall a (kind :: TypeCategory).
(GQLType a, CategoryValue kind) =>
KindedType kind a
-> [ConsRep (TyContent kind)]
-> SchemaT kind (TypeContent TRUE kind CONST)
buildTypeContent KindedType 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 a (kind :: TypeCategory) (c :: TypeCategory).
GQLType a =>
KindedType kind a
-> [TypeName] -> SchemaT c (TypeContent TRUE kind CONST)
buildEnumTypeContent KindedType 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 KindedType kind a
scope [ConsRep {[FieldRep (TyContent kind)]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (TyContent kind)]
consFields}] = forall a (cat :: TypeCategory) (c :: TypeCategory).
GQLType a =>
KindedType cat a
-> [FieldRep (Maybe (FieldContent TRUE cat CONST))]
-> SchemaT c (TypeContent TRUE cat CONST)
buildObjectTypeContent KindedType kind a
scope [FieldRep (TyContent kind)]
consFields
buildTypeContent KindedType kind a
scope [ConsRep (TyContent kind)]
cons = forall a (kind :: TypeCategory) (c :: TypeCategory).
(GQLType a, CategoryValue kind) =>
KindedType kind a
-> [ConsRep (Maybe (FieldContent TRUE kind CONST))]
-> SchemaT c (TypeContent TRUE kind CONST)
buildUnionTypeContent KindedType kind a
scope [ConsRep (TyContent kind)]
cons

insertTypeContent ::
  (GQLType a, CategoryValue kind) =>
  (f kind a -> SchemaT c (TypeContent TRUE kind CONST)) ->
  f kind a ->
  SchemaT c ()
insertTypeContent :: forall a (kind :: TypeCategory) (f :: TypeCategory -> * -> *)
       (c :: TypeCategory).
(GQLType a, CategoryValue kind) =>
(f kind a -> SchemaT c (TypeContent TRUE kind CONST))
-> f kind a -> SchemaT c ()
insertTypeContent f kind a -> SchemaT c (TypeContent TRUE kind CONST)
f f kind a
proxy =
  forall a (cat' :: TypeCategory) (cat :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (TypeDefinition cat CONST))
-> a
-> SchemaT cat' ()
updateSchema
    (forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeFingerprint
deriveFingerprint f kind a
proxy)
    f kind a -> SchemaT c (TypeDefinition kind CONST)
deriveD
    f kind a
proxy
  where
    deriveD :: f kind a -> SchemaT c (TypeDefinition kind CONST)
deriveD f kind a
x = do
      TypeContent TRUE kind CONST
content <- f kind a -> SchemaT c (TypeContent TRUE kind CONST)
f f kind a
x
      Directives CONST
dirs <- forall (c :: TypeCategory) (f :: * -> *) a.
GQLType a =>
f a -> SchemaT c (Directives CONST)
deriveTypeDirectives f kind 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 a (f :: * -> *). GQLType a => f a -> Maybe Description
description f kind a
proxy)
          (forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeName
deriveTypename f kind a
proxy)
          Directives CONST
dirs
          TypeContent TRUE kind CONST
content

deriveTypeContentWith ::
  ( CategoryValue kind,
    DeriveWith c (SchemaT kind (TyContent kind)) (Rep a),
    GQLType a
  ) =>
  DeriveTypeOptions kind c (SchemaT kind (TyContent kind)) ->
  KindedType kind a ->
  SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContentWith :: forall (kind :: TypeCategory) (c :: * -> Constraint) a.
(CategoryValue kind,
 DeriveWith c (SchemaT kind (TyContent kind)) (Rep a), GQLType a) =>
DeriveTypeOptions kind c (SchemaT kind (TyContent kind))
-> KindedType kind a -> SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContentWith DeriveTypeOptions kind c (SchemaT kind (TyContent kind))
x KindedType kind a
kindedProxy =
  forall (m :: * -> *) a. Monad m => [ConsRep (m a)] -> m [ConsRep a]
unpackMonad
    ( forall (kind :: TypeCategory) (c :: * -> Constraint) v
       (kinded :: TypeCategory -> * -> *) a.
(CategoryValue kind, DeriveWith c v (Rep a)) =>
DeriveTypeOptions kind c v -> kinded kind a -> [ConsRep v]
deriveTypeWith DeriveTypeOptions kind c (SchemaT kind (TyContent kind))
x KindedType kind a
kindedProxy
    )
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (kind :: TypeCategory).
(GQLType a, CategoryValue kind) =>
KindedType kind a
-> [ConsRep (TyContent kind)]
-> SchemaT kind (TypeContent TRUE kind CONST)
buildTypeContent KindedType kind a
kindedProxy