{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}

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

import Data.Morpheus.Server.Deriving.Schema.Internal
  ( lookupDescription,
    lookupDirectives,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( KindedType (..),
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType,
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    insertType,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    DataEnumValue (..),
    LEAF,
    TRUE,
    TypeContent (..),
    TypeDefinition,
    TypeName,
    mkEnumContent,
    mkType,
    unitTypeName,
    unpackName,
  )

buildEnumTypeContent :: GQLType a => KindedType kind a -> [TypeName] -> SchemaT c (TypeContent TRUE kind CONST)
buildEnumTypeContent :: KindedType kind a
-> [TypeName] -> SchemaT c (TypeContent TRUE kind CONST)
buildEnumTypeContent p :: KindedType kind a
p@KindedType kind a
InputType [TypeName]
enumCons = TypeContent TRUE kind CONST
-> SchemaT c (TypeContent TRUE kind CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContent TRUE kind CONST
 -> SchemaT c (TypeContent TRUE kind CONST))
-> TypeContent TRUE kind CONST
-> SchemaT c (TypeContent TRUE kind CONST)
forall a b. (a -> b) -> a -> b
$ DataEnum CONST -> TypeContent (LEAF <=? 'IN) 'IN CONST
forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (LEAF <=? a) a s
DataEnum (DataEnum CONST -> TypeContent (LEAF <=? 'IN) 'IN CONST)
-> DataEnum CONST -> TypeContent (LEAF <=? 'IN) 'IN CONST
forall a b. (a -> b) -> a -> b
$ (TypeName -> DataEnumValue CONST) -> [TypeName] -> DataEnum CONST
forall a b. (a -> b) -> [a] -> [b]
map (KindedType kind a -> TypeName -> DataEnumValue CONST
forall a (f :: * -> *).
GQLType a =>
f a -> TypeName -> DataEnumValue CONST
mkEnumValue KindedType kind a
p) [TypeName]
enumCons
buildEnumTypeContent p :: KindedType kind a
p@KindedType kind a
OutputType [TypeName]
enumCons = TypeContent TRUE kind CONST
-> SchemaT c (TypeContent TRUE kind CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContent TRUE kind CONST
 -> SchemaT c (TypeContent TRUE kind CONST))
-> TypeContent TRUE kind CONST
-> SchemaT c (TypeContent TRUE kind CONST)
forall a b. (a -> b) -> a -> b
$ DataEnum CONST -> TypeContent (LEAF <=? 'OUT) 'OUT CONST
forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (LEAF <=? a) a s
DataEnum (DataEnum CONST -> TypeContent (LEAF <=? 'OUT) 'OUT CONST)
-> DataEnum CONST -> TypeContent (LEAF <=? 'OUT) 'OUT CONST
forall a b. (a -> b) -> a -> b
$ (TypeName -> DataEnumValue CONST) -> [TypeName] -> DataEnum CONST
forall a b. (a -> b) -> [a] -> [b]
map (KindedType kind a -> TypeName -> DataEnumValue CONST
forall a (f :: * -> *).
GQLType a =>
f a -> TypeName -> DataEnumValue CONST
mkEnumValue KindedType kind a
p) [TypeName]
enumCons

mkEnumValue :: GQLType a => f a -> TypeName -> DataEnumValue CONST
mkEnumValue :: f a -> TypeName -> DataEnumValue CONST
mkEnumValue f a
proxy TypeName
enumName =
  DataEnumValue :: forall (s :: Stage).
Maybe Description -> TypeName -> Directives s -> DataEnumValue s
DataEnumValue
    { TypeName
enumName :: TypeName
enumName :: TypeName
enumName,
      enumDescription :: Maybe Description
enumDescription = f a -> Description -> Maybe Description
forall a (f :: * -> *).
GQLType a =>
f a -> Description -> Maybe Description
lookupDescription f a
proxy (TypeName -> Description
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
enumName),
      enumDirectives :: Directives CONST
enumDirectives = f a -> Description -> Directives CONST
forall a (f :: * -> *).
GQLType a =>
f a -> Description -> Directives CONST
lookupDirectives f a
proxy (TypeName -> Description
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
enumName)
    }

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