{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}

module Data.Morpheus.Server.Deriving.Internal.Schema.Enum
  ( buildEnumTypeContent,
    defineEnumUnit,
  )
where

import Data.Morpheus.Server.Deriving.Internal.Schema.Directive
  ( UseDeriving,
    deriveEnumDirectives,
    visitEnumName,
    visitEnumValueDescription,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    insertType,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    DataEnumValue (..),
    LEAF,
    TRUE,
    TypeContent (..),
    TypeDefinition,
    TypeName,
    mkEnumContent,
    mkType,
    unitTypeName,
  )

buildEnumTypeContent :: gql a => UseDeriving gql args -> CatType kind a -> [TypeName] -> SchemaT k (TypeContent TRUE kind CONST)
buildEnumTypeContent :: forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (kind :: TypeCategory) (k :: TypeCategory).
gql a =>
UseDeriving gql args
-> CatType kind a
-> [TypeName]
-> SchemaT k (TypeContent TRUE kind CONST)
buildEnumTypeContent UseDeriving gql args
options p :: CatType kind a
p@CatType kind a
InputType [TypeName]
enumCons = forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (LEAF <=? a) a s
DataEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *) (k :: TypeCategory).
gql a =>
UseDeriving gql args
-> f a -> TypeName -> SchemaT k (DataEnumValue CONST)
mkEnumValue UseDeriving gql args
options CatType kind a
p) [TypeName]
enumCons
buildEnumTypeContent UseDeriving gql args
options p :: CatType kind a
p@CatType kind a
OutputType [TypeName]
enumCons = forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (LEAF <=? a) a s
DataEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *) (k :: TypeCategory).
gql a =>
UseDeriving gql args
-> f a -> TypeName -> SchemaT k (DataEnumValue CONST)
mkEnumValue UseDeriving gql args
options CatType kind a
p) [TypeName]
enumCons

mkEnumValue :: gql a => UseDeriving gql args -> f a -> TypeName -> SchemaT k (DataEnumValue CONST)
mkEnumValue :: forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *) (k :: TypeCategory).
gql a =>
UseDeriving gql args
-> f a -> TypeName -> SchemaT k (DataEnumValue CONST)
mkEnumValue UseDeriving gql args
options f a
proxy TypeName
enumName = do
  Directives CONST
enumDirectives <- forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *) (k :: TypeCategory).
gql a =>
UseDeriving gql args
-> f a -> TypeName -> SchemaT k (Directives CONST)
deriveEnumDirectives UseDeriving gql args
options f a
proxy TypeName
enumName
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    DataEnumValue
      { enumName :: TypeName
enumName = forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *).
gql a =>
UseDeriving gql args -> f a -> TypeName -> TypeName
visitEnumName UseDeriving gql args
options f a
proxy TypeName
enumName,
        enumDescription :: Maybe Description
enumDescription = forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *).
gql a =>
UseDeriving gql args
-> f a -> TypeName -> Maybe Description -> Maybe Description
visitEnumValueDescription UseDeriving gql args
options f a
proxy TypeName
enumName forall a. Maybe a
Nothing,
        Directives CONST
enumDirectives :: Directives CONST
enumDirectives :: Directives CONST
..
      }

defineEnumUnit :: SchemaT cat ()
defineEnumUnit :: forall (cat :: TypeCategory). SchemaT cat ()
defineEnumUnit =
  forall (cat :: TypeCategory) (cat' :: TypeCategory).
TypeDefinition cat CONST -> SchemaT cat' ()
insertType
    ( forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
unitTypeName (forall (a :: TypeCategory) (s :: Stage).
(LEAF <=! a) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent [TypeName
unitTypeName]) ::
        TypeDefinition LEAF CONST
    )