{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.AST.TypeSystem
  ( ScalarDefinition (..),
    DataEnum,
    DataUnion,
    TypeContent (..),
    TypeDefinition (..),
    Schema (..),
    DataEnumValue (..),
    TypeLib,
    TypeCategory,
    DataInputUnion,
    mkEnumContent,
    mkUnionContent,
    mkType,
    createScalarType,
    mkInputUnionFields,
    initTypeLib,
    kindOf,
    isEntNode,
    lookupWith,
    __inputname,
    UnionMember (..),
    mkUnionMember,
    RawTypeDefinition (..),
    RootOperationTypeDefinition (..),
    SchemaDefinition (..),
    buildSchema,
    Typed (Typed),
    untyped,
    typed,
    possibleTypes,
    possibleInterfaceTypes,
    safeDefineType,
    defineSchemaWith,
  )
where

-- MORPHEUS
import Control.Monad (foldM)
import Data.Morpheus.Error.NameCollision
  ( NameCollision (..),
  )
import Data.Morpheus.Ext.OrdMap
  ( OrdMap,
  )
import Data.Morpheus.Ext.SafeHashMap
  ( SafeHashMap,
    insert,
  )
import Data.Morpheus.Ext.SemigroupM
  ( (<:>),
    SemigroupM (..),
  )
import Data.Morpheus.Internal.Utils
  ( Collection (..),
    Elems (..),
    Failure (..),
    FromElems (..),
    KeyOf (..),
    Selectable (..),
  )
import Data.Morpheus.Rendering.RenderGQL
  ( RenderGQL (..),
    Rendering,
    intercalate,
    newline,
    renderEntry,
    renderMembers,
    renderObject,
  )
import Data.Morpheus.Types.Internal.AST.Base
  ( Description,
    FieldName,
    FieldName (..),
    Msg (..),
    OperationType (..),
    TRUE,
    Token,
    TypeKind (..),
    TypeName,
    TypeRef (..),
    TypeWrapper (..),
    ValidationError,
    ValidationErrors,
    isNotSystemTypeName,
    mkTypeRef,
    msg,
    msgValidation,
    toFieldName,
    toOperationType,
  )
import Data.Morpheus.Types.Internal.AST.Fields
  ( Directive,
    DirectiveDefinition (..),
    Directives,
    FieldDefinition (..),
    FieldsDefinition,
    unsafeFromFields,
  )
import Data.Morpheus.Types.Internal.AST.Stage
  ( CONST,
    Stage,
    VALID,
  )
import Data.Morpheus.Types.Internal.AST.TypeCategory
  ( ANY,
    ELEM,
    FromCategory (..),
    IMPLEMENTABLE,
    IN,
    LEAF,
    OBJECT,
    OUT,
    ToCategory (..),
    TypeCategory,
    fromAny,
    toAny,
  )
import Data.Morpheus.Types.Internal.AST.Value
  ( Value (..),
  )
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift (..))
import Relude hiding
  ( empty,
    intercalate,
    show,
  )
import Prelude (Show (..))

type DataEnum s = [DataEnumValue s]

-- used for preserving type information from untyped values
-- e.g
-- unionType :: UnionMember IN VALID -> Typed IN VALID TypeName
-- unionType = typed memberName
typed :: (a c s -> b) -> a c s -> Typed c s b
typed :: (a c s -> b) -> a c s -> Typed c s b
typed a c s -> b
f = b -> Typed c s b
forall (cat :: TypeCategory) (s :: Stage) a. a -> Typed cat s a
Typed (b -> Typed c s b) -> (a c s -> b) -> a c s -> Typed c s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a c s -> b
f

untyped :: (a -> b) -> Typed c s a -> b
untyped :: (a -> b) -> Typed c s a -> b
untyped a -> b
f = a -> b
f (a -> b) -> (Typed c s a -> a) -> Typed c s a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed c s a -> a
forall (cat :: TypeCategory) (s :: Stage) a. Typed cat s a -> a
_untyped

-- | used for preserving type information from untyped values
-- see function typed
newtype Typed (cat :: TypeCategory) (s :: Stage) a = Typed
  { Typed cat s a -> a
_untyped :: a
  }

mkUnionMember :: TypeName -> UnionMember cat s
mkUnionMember :: TypeName -> UnionMember cat s
mkUnionMember TypeName
name = TypeName -> Bool -> UnionMember cat s
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> Bool -> UnionMember cat s
UnionMember TypeName
name Bool
True

data UnionMember (cat :: TypeCategory) (s :: Stage) = UnionMember
  { UnionMember cat s -> TypeName
memberName :: TypeName,
    UnionMember cat s -> Bool
visibility :: Bool
  }
  deriving (Int -> UnionMember cat s -> ShowS
[UnionMember cat s] -> ShowS
UnionMember cat s -> String
(Int -> UnionMember cat s -> ShowS)
-> (UnionMember cat s -> String)
-> ([UnionMember cat s] -> ShowS)
-> Show (UnionMember cat s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (cat :: TypeCategory) (s :: Stage).
Int -> UnionMember cat s -> ShowS
forall (cat :: TypeCategory) (s :: Stage).
[UnionMember cat s] -> ShowS
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> String
showList :: [UnionMember cat s] -> ShowS
$cshowList :: forall (cat :: TypeCategory) (s :: Stage).
[UnionMember cat s] -> ShowS
show :: UnionMember cat s -> String
$cshow :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> String
showsPrec :: Int -> UnionMember cat s -> ShowS
$cshowsPrec :: forall (cat :: TypeCategory) (s :: Stage).
Int -> UnionMember cat s -> ShowS
Show, UnionMember cat s -> Q Exp
UnionMember cat s -> Q (TExp (UnionMember cat s))
(UnionMember cat s -> Q Exp)
-> (UnionMember cat s -> Q (TExp (UnionMember cat s)))
-> Lift (UnionMember cat s)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Q Exp
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Q (TExp (UnionMember cat s))
liftTyped :: UnionMember cat s -> Q (TExp (UnionMember cat s))
$cliftTyped :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Q (TExp (UnionMember cat s))
lift :: UnionMember cat s -> Q Exp
$clift :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Q Exp
Lift, UnionMember cat s -> UnionMember cat s -> Bool
(UnionMember cat s -> UnionMember cat s -> Bool)
-> (UnionMember cat s -> UnionMember cat s -> Bool)
-> Eq (UnionMember cat s)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> UnionMember cat s -> Bool
/= :: UnionMember cat s -> UnionMember cat s -> Bool
$c/= :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> UnionMember cat s -> Bool
== :: UnionMember cat s -> UnionMember cat s -> Bool
$c== :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> UnionMember cat s -> Bool
Eq)

type DataUnion s = [UnionMember OUT s]

type DataInputUnion s = [UnionMember IN s]

instance RenderGQL (UnionMember cat s) where
  render :: UnionMember cat s -> Rendering
render = TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
render (TypeName -> Rendering)
-> (UnionMember cat s -> TypeName)
-> UnionMember cat s
-> Rendering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnionMember cat s -> TypeName
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName

instance Msg (UnionMember cat s) where
  msg :: UnionMember cat s -> Message
msg = TypeName -> Message
forall a. Msg a => a -> Message
msg (TypeName -> Message)
-> (UnionMember cat s -> TypeName) -> UnionMember cat s -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnionMember cat s -> TypeName
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName

instance KeyOf TypeName (UnionMember cat s) where
  keyOf :: UnionMember cat s -> TypeName
keyOf = UnionMember cat s -> TypeName
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName

-- scalar
------------------------------------------------------------------
newtype ScalarDefinition = ScalarDefinition
  {ScalarDefinition -> Value VALID -> Either Text (Value VALID)
validateValue :: Value VALID -> Either Token (Value VALID)}

instance Show ScalarDefinition where
  show :: ScalarDefinition -> String
show ScalarDefinition
_ = String
"ScalarDefinition"

instance Lift ScalarDefinition where
  lift :: ScalarDefinition -> Q Exp
lift ScalarDefinition
_ = [|ScalarDefinition pure|]

#if MIN_VERSION_template_haskell(2,16,0)
  liftTyped :: ScalarDefinition -> Q (TExp ScalarDefinition)
liftTyped ScalarDefinition
_ = [||ScalarDefinition pure||]
#endif

-- ENUM VALUE
data DataEnumValue s = DataEnumValue
  { DataEnumValue s -> Maybe Text
enumDescription :: Maybe Description,
    DataEnumValue s -> TypeName
enumName :: TypeName,
    DataEnumValue s -> [Directive s]
enumDirectives :: [Directive s]
  }
  deriving (Int -> DataEnumValue s -> ShowS
[DataEnumValue s] -> ShowS
DataEnumValue s -> String
(Int -> DataEnumValue s -> ShowS)
-> (DataEnumValue s -> String)
-> ([DataEnumValue s] -> ShowS)
-> Show (DataEnumValue s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Stage). Int -> DataEnumValue s -> ShowS
forall (s :: Stage). [DataEnumValue s] -> ShowS
forall (s :: Stage). DataEnumValue s -> String
showList :: [DataEnumValue s] -> ShowS
$cshowList :: forall (s :: Stage). [DataEnumValue s] -> ShowS
show :: DataEnumValue s -> String
$cshow :: forall (s :: Stage). DataEnumValue s -> String
showsPrec :: Int -> DataEnumValue s -> ShowS
$cshowsPrec :: forall (s :: Stage). Int -> DataEnumValue s -> ShowS
Show, DataEnumValue s -> Q Exp
DataEnumValue s -> Q (TExp (DataEnumValue s))
(DataEnumValue s -> Q Exp)
-> (DataEnumValue s -> Q (TExp (DataEnumValue s)))
-> Lift (DataEnumValue s)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (s :: Stage). DataEnumValue s -> Q Exp
forall (s :: Stage). DataEnumValue s -> Q (TExp (DataEnumValue s))
liftTyped :: DataEnumValue s -> Q (TExp (DataEnumValue s))
$cliftTyped :: forall (s :: Stage). DataEnumValue s -> Q (TExp (DataEnumValue s))
lift :: DataEnumValue s -> Q Exp
$clift :: forall (s :: Stage). DataEnumValue s -> Q Exp
Lift)

instance RenderGQL (DataEnumValue s) where
  render :: DataEnumValue s -> Rendering
render DataEnumValue {TypeName
enumName :: TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName} = TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
render TypeName
enumName

-- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema
---------------------------------------------------------------------------
-- SchemaDefinition :
--    schema Directives[Const](opt) { RootOperationTypeDefinition(list)}
--
-- RootOperationTypeDefinition :
--    OperationType: NamedType

data Schema (s :: Stage) = Schema
  { Schema s -> TypeLib s
types :: TypeLib s,
    Schema s -> TypeDefinition OBJECT s
query :: TypeDefinition OBJECT s,
    Schema s -> Maybe (TypeDefinition OBJECT s)
mutation :: Maybe (TypeDefinition OBJECT s),
    Schema s -> Maybe (TypeDefinition OBJECT s)
subscription :: Maybe (TypeDefinition OBJECT s),
    Schema s -> [DirectiveDefinition s]
directiveDefinitions :: [DirectiveDefinition s]
  }
  deriving (Int -> Schema s -> ShowS
[Schema s] -> ShowS
Schema s -> String
(Int -> Schema s -> ShowS)
-> (Schema s -> String) -> ([Schema s] -> ShowS) -> Show (Schema s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Stage). Int -> Schema s -> ShowS
forall (s :: Stage). [Schema s] -> ShowS
forall (s :: Stage). Schema s -> String
showList :: [Schema s] -> ShowS
$cshowList :: forall (s :: Stage). [Schema s] -> ShowS
show :: Schema s -> String
$cshow :: forall (s :: Stage). Schema s -> String
showsPrec :: Int -> Schema s -> ShowS
$cshowsPrec :: forall (s :: Stage). Int -> Schema s -> ShowS
Show, Schema s -> Q Exp
Schema s -> Q (TExp (Schema s))
(Schema s -> Q Exp)
-> (Schema s -> Q (TExp (Schema s))) -> Lift (Schema s)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (s :: Stage). Schema s -> Q Exp
forall (s :: Stage). Schema s -> Q (TExp (Schema s))
liftTyped :: Schema s -> Q (TExp (Schema s))
$cliftTyped :: forall (s :: Stage). Schema s -> Q (TExp (Schema s))
lift :: Schema s -> Q Exp
$clift :: forall (s :: Stage). Schema s -> Q Exp
Lift)

instance
  ( Monad m,
    Failure ValidationErrors m
  ) =>
  SemigroupM
    m
    (Schema s)
  where
  mergeM :: [Ref] -> Schema s -> Schema s -> m (Schema s)
mergeM [Ref]
_ Schema s
s1 Schema s
s2 =
    TypeLib s
-> TypeDefinition OBJECT s
-> Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> [DirectiveDefinition s]
-> Schema s
forall (s :: Stage).
TypeLib s
-> TypeDefinition OBJECT s
-> Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> [DirectiveDefinition s]
-> Schema s
Schema
      (TypeLib s
 -> TypeDefinition OBJECT s
 -> Maybe (TypeDefinition OBJECT s)
 -> Maybe (TypeDefinition OBJECT s)
 -> [DirectiveDefinition s]
 -> Schema s)
-> m (TypeLib s)
-> m (TypeDefinition OBJECT s
      -> Maybe (TypeDefinition OBJECT s)
      -> Maybe (TypeDefinition OBJECT s)
      -> [DirectiveDefinition s]
      -> Schema s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Schema s -> TypeLib s
forall (s :: Stage). Schema s -> TypeLib s
types Schema s
s1 TypeLib s -> TypeLib s -> m (TypeLib s)
forall (m :: * -> *) a. SemigroupM m a => a -> a -> m a
<:> Schema s -> TypeLib s
forall (s :: Stage). Schema s -> TypeLib s
types Schema s
s2)
      m (TypeDefinition OBJECT s
   -> Maybe (TypeDefinition OBJECT s)
   -> Maybe (TypeDefinition OBJECT s)
   -> [DirectiveDefinition s]
   -> Schema s)
-> m (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s)
      -> Maybe (TypeDefinition OBJECT s)
      -> [DirectiveDefinition s]
      -> Schema s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeDefinition OBJECT s
-> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)
forall (m :: * -> *) (s :: Stage).
(Monad m, Failure ValidationErrors m) =>
TypeDefinition OBJECT s
-> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)
mergeOperation (Schema s -> TypeDefinition OBJECT s
forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query Schema s
s1) (Schema s -> TypeDefinition OBJECT s
forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query Schema s
s2)
      m (Maybe (TypeDefinition OBJECT s)
   -> Maybe (TypeDefinition OBJECT s)
   -> [DirectiveDefinition s]
   -> Schema s)
-> m (Maybe (TypeDefinition OBJECT s))
-> m (Maybe (TypeDefinition OBJECT s)
      -> [DirectiveDefinition s] -> Schema s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
forall (m :: * -> *) (s :: Stage).
(Monad m, Failure ValidationErrors m) =>
Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
mergeOptional (Schema s -> Maybe (TypeDefinition OBJECT s)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation Schema s
s1) (Schema s -> Maybe (TypeDefinition OBJECT s)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation Schema s
s2)
      m (Maybe (TypeDefinition OBJECT s)
   -> [DirectiveDefinition s] -> Schema s)
-> m (Maybe (TypeDefinition OBJECT s))
-> m ([DirectiveDefinition s] -> Schema s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
forall (m :: * -> *) (s :: Stage).
(Monad m, Failure ValidationErrors m) =>
Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
mergeOptional (Schema s -> Maybe (TypeDefinition OBJECT s)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
subscription Schema s
s1) (Schema s -> Maybe (TypeDefinition OBJECT s)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
subscription Schema s
s2)
      m ([DirectiveDefinition s] -> Schema s)
-> m [DirectiveDefinition s] -> m (Schema s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DirectiveDefinition s] -> m [DirectiveDefinition s]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema s -> [DirectiveDefinition s]
forall (s :: Stage). Schema s -> [DirectiveDefinition s]
directiveDefinitions Schema s
s1 [DirectiveDefinition s]
-> [DirectiveDefinition s] -> [DirectiveDefinition s]
forall a. Semigroup a => a -> a -> a
<> Schema s -> [DirectiveDefinition s]
forall (s :: Stage). Schema s -> [DirectiveDefinition s]
directiveDefinitions Schema s
s2)

mergeOptional ::
  (Monad m, Failure ValidationErrors m) =>
  Maybe (TypeDefinition OBJECT s) ->
  Maybe (TypeDefinition OBJECT s) ->
  m (Maybe (TypeDefinition OBJECT s))
mergeOptional :: Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
mergeOptional Maybe (TypeDefinition OBJECT s)
Nothing Maybe (TypeDefinition OBJECT s)
y = Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TypeDefinition OBJECT s)
y
mergeOptional (Just TypeDefinition OBJECT s
x) Maybe (TypeDefinition OBJECT s)
Nothing = Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s)
forall a. a -> Maybe a
Just TypeDefinition OBJECT s
x)
mergeOptional (Just TypeDefinition OBJECT s
x) (Just TypeDefinition OBJECT s
y) = TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s)
forall a. a -> Maybe a
Just (TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s))
-> m (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeDefinition OBJECT s
-> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)
forall (m :: * -> *) (s :: Stage).
(Monad m, Failure ValidationErrors m) =>
TypeDefinition OBJECT s
-> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)
mergeOperation TypeDefinition OBJECT s
x TypeDefinition OBJECT s
y

mergeOperation ::
  (Monad m, Failure ValidationErrors m) =>
  TypeDefinition OBJECT s ->
  TypeDefinition OBJECT s ->
  m (TypeDefinition OBJECT s)
mergeOperation :: TypeDefinition OBJECT s
-> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)
mergeOperation
  TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject [TypeName]
i1 FieldsDefinition OUT s
fields1}
  TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject [TypeName]
i2 FieldsDefinition OUT s
fields2, Directives s
Maybe Text
TypeName
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Text
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Text
..} =
    do
      FieldsDefinition OUT s
fields <- FieldsDefinition OUT s
fields1 FieldsDefinition OUT s
-> FieldsDefinition OUT s -> m (FieldsDefinition OUT s)
forall (m :: * -> *) a. SemigroupM m a => a -> a -> m a
<:> FieldsDefinition OUT s
fields2
      TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s))
-> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)
forall a b. (a -> b) -> a -> b
$ TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Text
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition {typeContent :: TypeContent TRUE OBJECT s
typeContent = [TypeName]
-> FieldsDefinition OUT s
-> TypeContent (ELEM OBJECT OBJECT) OBJECT s
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject ([TypeName]
i1 [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
i2) FieldsDefinition OUT s
fields, Directives s
Maybe Text
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Text
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Text
..}

data SchemaDefinition = SchemaDefinition
  { SchemaDefinition -> Directives CONST
schemaDirectives :: Directives CONST,
    SchemaDefinition
-> OrdMap OperationType RootOperationTypeDefinition
unSchemaDefinition :: OrdMap OperationType RootOperationTypeDefinition
  }
  deriving (Int -> SchemaDefinition -> ShowS
[SchemaDefinition] -> ShowS
SchemaDefinition -> String
(Int -> SchemaDefinition -> ShowS)
-> (SchemaDefinition -> String)
-> ([SchemaDefinition] -> ShowS)
-> Show SchemaDefinition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaDefinition] -> ShowS
$cshowList :: [SchemaDefinition] -> ShowS
show :: SchemaDefinition -> String
$cshow :: SchemaDefinition -> String
showsPrec :: Int -> SchemaDefinition -> ShowS
$cshowsPrec :: Int -> SchemaDefinition -> ShowS
Show)

instance RenderGQL SchemaDefinition where
  render :: SchemaDefinition -> Rendering
render = [RootOperationTypeDefinition] -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderSchemaDefinition ([RootOperationTypeDefinition] -> Rendering)
-> (SchemaDefinition -> [RootOperationTypeDefinition])
-> SchemaDefinition
-> Rendering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdMap OperationType RootOperationTypeDefinition
-> [RootOperationTypeDefinition]
forall a coll. Elems a coll => coll -> [a]
elems (OrdMap OperationType RootOperationTypeDefinition
 -> [RootOperationTypeDefinition])
-> (SchemaDefinition
    -> OrdMap OperationType RootOperationTypeDefinition)
-> SchemaDefinition
-> [RootOperationTypeDefinition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaDefinition
-> OrdMap OperationType RootOperationTypeDefinition
unSchemaDefinition

renderSchemaDefinition :: RenderGQL a => [a] -> Rendering
renderSchemaDefinition :: [a] -> Rendering
renderSchemaDefinition [a]
entries = Rendering
"schema" Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> [a] -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderObject [a]
entries Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
newline

instance Selectable OperationType RootOperationTypeDefinition SchemaDefinition where
  selectOr :: d
-> (RootOperationTypeDefinition -> d)
-> OperationType
-> SchemaDefinition
-> d
selectOr d
fallback RootOperationTypeDefinition -> d
f OperationType
key SchemaDefinition {OrdMap OperationType RootOperationTypeDefinition
unSchemaDefinition :: OrdMap OperationType RootOperationTypeDefinition
unSchemaDefinition :: SchemaDefinition
-> OrdMap OperationType RootOperationTypeDefinition
unSchemaDefinition} =
    d
-> (RootOperationTypeDefinition -> d)
-> OperationType
-> OrdMap OperationType RootOperationTypeDefinition
-> d
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr d
fallback RootOperationTypeDefinition -> d
f OperationType
key OrdMap OperationType RootOperationTypeDefinition
unSchemaDefinition

instance NameCollision SchemaDefinition where
  nameCollision :: SchemaDefinition -> ValidationError
nameCollision SchemaDefinition
_ = ValidationError
"There can Be only One SchemaDefinition."

instance KeyOf TypeName SchemaDefinition where
  keyOf :: SchemaDefinition -> TypeName
keyOf SchemaDefinition
_ = TypeName
"schema"

data RawTypeDefinition
  = RawSchemaDefinition SchemaDefinition
  | RawTypeDefinition (TypeDefinition ANY CONST)
  | RawDirectiveDefinition (DirectiveDefinition CONST)
  deriving (Int -> RawTypeDefinition -> ShowS
[RawTypeDefinition] -> ShowS
RawTypeDefinition -> String
(Int -> RawTypeDefinition -> ShowS)
-> (RawTypeDefinition -> String)
-> ([RawTypeDefinition] -> ShowS)
-> Show RawTypeDefinition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawTypeDefinition] -> ShowS
$cshowList :: [RawTypeDefinition] -> ShowS
show :: RawTypeDefinition -> String
$cshow :: RawTypeDefinition -> String
showsPrec :: Int -> RawTypeDefinition -> ShowS
$cshowsPrec :: Int -> RawTypeDefinition -> ShowS
Show)

data RootOperationTypeDefinition = RootOperationTypeDefinition
  { RootOperationTypeDefinition -> OperationType
rootOperationType :: OperationType,
    RootOperationTypeDefinition -> TypeName
rootOperationTypeDefinitionName :: TypeName
  }
  deriving (Int -> RootOperationTypeDefinition -> ShowS
[RootOperationTypeDefinition] -> ShowS
RootOperationTypeDefinition -> String
(Int -> RootOperationTypeDefinition -> ShowS)
-> (RootOperationTypeDefinition -> String)
-> ([RootOperationTypeDefinition] -> ShowS)
-> Show RootOperationTypeDefinition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RootOperationTypeDefinition] -> ShowS
$cshowList :: [RootOperationTypeDefinition] -> ShowS
show :: RootOperationTypeDefinition -> String
$cshow :: RootOperationTypeDefinition -> String
showsPrec :: Int -> RootOperationTypeDefinition -> ShowS
$cshowsPrec :: Int -> RootOperationTypeDefinition -> ShowS
Show, RootOperationTypeDefinition -> RootOperationTypeDefinition -> Bool
(RootOperationTypeDefinition
 -> RootOperationTypeDefinition -> Bool)
-> (RootOperationTypeDefinition
    -> RootOperationTypeDefinition -> Bool)
-> Eq RootOperationTypeDefinition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RootOperationTypeDefinition -> RootOperationTypeDefinition -> Bool
$c/= :: RootOperationTypeDefinition -> RootOperationTypeDefinition -> Bool
== :: RootOperationTypeDefinition -> RootOperationTypeDefinition -> Bool
$c== :: RootOperationTypeDefinition -> RootOperationTypeDefinition -> Bool
Eq)

instance NameCollision RootOperationTypeDefinition where
  nameCollision :: RootOperationTypeDefinition -> ValidationError
nameCollision RootOperationTypeDefinition {OperationType
rootOperationType :: OperationType
rootOperationType :: RootOperationTypeDefinition -> OperationType
rootOperationType} =
    ValidationError
"There can Be only One TypeDefinition for schema." ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> OperationType -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation OperationType
rootOperationType

instance KeyOf OperationType RootOperationTypeDefinition where
  keyOf :: RootOperationTypeDefinition -> OperationType
keyOf = RootOperationTypeDefinition -> OperationType
rootOperationType

instance RenderGQL RootOperationTypeDefinition where
  render :: RootOperationTypeDefinition -> Rendering
render
    RootOperationTypeDefinition
      { OperationType
rootOperationType :: OperationType
rootOperationType :: RootOperationTypeDefinition -> OperationType
rootOperationType,
        TypeName
rootOperationTypeDefinitionName :: TypeName
rootOperationTypeDefinitionName :: RootOperationTypeDefinition -> TypeName
rootOperationTypeDefinitionName
      } = OperationType -> TypeName -> Rendering
forall name value.
(RenderGQL name, RenderGQL value) =>
name -> value -> Rendering
renderEntry OperationType
rootOperationType TypeName
rootOperationTypeDefinitionName

type TypeLib s = SafeHashMap TypeName (TypeDefinition ANY s)

instance Selectable TypeName (TypeDefinition ANY s) (Schema s) where
  selectOr :: d -> (TypeDefinition ANY s -> d) -> TypeName -> Schema s -> d
selectOr d
fb TypeDefinition ANY s -> d
f TypeName
name Schema s
lib = d
-> (TypeDefinition ANY s -> d) -> Maybe (TypeDefinition ANY s) -> d
forall b a. b -> (a -> b) -> Maybe a -> b
maybe d
fb TypeDefinition ANY s -> d
f (TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
forall (s :: Stage).
TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
lookupDataType TypeName
name Schema s
lib)

instance Elems (TypeDefinition ANY s) (Schema s) where
  elems :: Schema s -> [TypeDefinition ANY s]
elems Schema {[DirectiveDefinition s]
Maybe (TypeDefinition OBJECT s)
TypeLib s
TypeDefinition OBJECT s
directiveDefinitions :: [DirectiveDefinition s]
subscription :: Maybe (TypeDefinition OBJECT s)
mutation :: Maybe (TypeDefinition OBJECT s)
query :: TypeDefinition OBJECT s
types :: TypeLib s
directiveDefinitions :: forall (s :: Stage). Schema s -> [DirectiveDefinition s]
subscription :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
query :: forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
types :: forall (s :: Stage). Schema s -> TypeLib s
..} =
    TypeLib s -> [TypeDefinition ANY s]
forall a coll. Elems a coll => coll -> [a]
elems TypeLib s
types
      [TypeDefinition ANY s]
-> [TypeDefinition ANY s] -> [TypeDefinition ANY s]
forall a. Semigroup a => a -> a -> a
<> (Maybe (TypeDefinition OBJECT s) -> [TypeDefinition ANY s])
-> [Maybe (TypeDefinition OBJECT s)] -> [TypeDefinition ANY s]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Maybe (TypeDefinition OBJECT s) -> [TypeDefinition ANY s]
forall (s :: Stage).
Maybe (TypeDefinition OBJECT s) -> [TypeDefinition ANY s]
fromOperation [TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s)
forall a. a -> Maybe a
Just TypeDefinition OBJECT s
query, Maybe (TypeDefinition OBJECT s)
mutation, Maybe (TypeDefinition OBJECT s)
subscription]

instance
  ( Monad m,
    Failure ValidationErrors m
  ) =>
  FromElems m (TypeDefinition ANY s) (Schema s)
  where
  fromElems :: [TypeDefinition ANY s] -> m (Schema s)
fromElems [TypeDefinition ANY s]
types =
    (RootOperationTypeDefinition
 -> m (Maybe (TypeDefinition OBJECT s)))
-> (RootOperationTypeDefinition, RootOperationTypeDefinition,
    RootOperationTypeDefinition)
-> m (Maybe (TypeDefinition OBJECT s),
      Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
forall (t :: * -> *) a b.
Applicative t =>
(a -> t b) -> (a, a, a) -> t (b, b, b)
traverse3
      ([TypeDefinition ANY s]
-> RootOperationTypeDefinition
-> m (Maybe (TypeDefinition OBJECT s))
forall (m :: * -> *) (s :: Stage).
(Applicative m, Failure ValidationErrors m) =>
[TypeDefinition ANY s]
-> RootOperationTypeDefinition
-> m (Maybe (TypeDefinition OBJECT s))
popByKey [TypeDefinition ANY s]
types)
      ( OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition OperationType
Query TypeName
"Query",
        OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition OperationType
Mutation TypeName
"Mutation",
        OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition OperationType
Subscription TypeName
"Subscription"
      )
      m (Maybe (TypeDefinition OBJECT s),
   Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> ((Maybe (TypeDefinition OBJECT s),
     Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
    -> m (Schema s))
-> m (Schema s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TypeDefinition ANY s]
-> (Maybe (TypeDefinition OBJECT s),
    Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> m (Schema s)
forall (f :: * -> *) (cat :: TypeCategory) (s :: Stage).
(Monad f, Failure ValidationErrors f) =>
[TypeDefinition cat s]
-> (Maybe (TypeDefinition OBJECT s),
    Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> f (Schema s)
defineSchemaWith [TypeDefinition ANY s]
types

defineSchemaWith ::
  ( Monad f,
    Failure ValidationErrors f
  ) =>
  [TypeDefinition cat s] ->
  ( Maybe (TypeDefinition OBJECT s),
    Maybe (TypeDefinition OBJECT s),
    Maybe (TypeDefinition OBJECT s)
  ) ->
  f (Schema s)
defineSchemaWith :: [TypeDefinition cat s]
-> (Maybe (TypeDefinition OBJECT s),
    Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> f (Schema s)
defineSchemaWith [TypeDefinition cat s]
oTypes (Just TypeDefinition OBJECT s
query, Maybe (TypeDefinition OBJECT s)
mutation, Maybe (TypeDefinition OBJECT s)
subscription) = do
  let types :: [TypeDefinition cat s]
types = [Maybe (TypeDefinition OBJECT s)]
-> [TypeDefinition cat s] -> [TypeDefinition cat s]
forall (c1 :: TypeCategory) (s :: Stage) (c2 :: TypeCategory).
[Maybe (TypeDefinition c1 s)]
-> [TypeDefinition c2 s] -> [TypeDefinition c2 s]
excludeTypes [TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s)
forall a. a -> Maybe a
Just TypeDefinition OBJECT s
query, Maybe (TypeDefinition OBJECT s)
mutation, Maybe (TypeDefinition OBJECT s)
subscription] [TypeDefinition cat s]
oTypes
  let schema :: Schema s
schema = (TypeDefinition OBJECT s -> Schema s
forall (s :: Stage). TypeDefinition OBJECT s -> Schema s
initTypeLib TypeDefinition OBJECT s
query) {Maybe (TypeDefinition OBJECT s)
mutation :: Maybe (TypeDefinition OBJECT s)
mutation :: Maybe (TypeDefinition OBJECT s)
mutation, Maybe (TypeDefinition OBJECT s)
subscription :: Maybe (TypeDefinition OBJECT s)
subscription :: Maybe (TypeDefinition OBJECT s)
subscription}
  (Schema s -> TypeDefinition cat s -> f (Schema s))
-> Schema s -> [TypeDefinition cat s] -> f (Schema s)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((TypeDefinition cat s -> Schema s -> f (Schema s))
-> Schema s -> TypeDefinition cat s -> f (Schema s)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeDefinition cat s -> Schema s -> f (Schema s)
forall (m :: * -> *) (cat :: TypeCategory) (s :: Stage).
(Monad m, Failure ValidationErrors m) =>
TypeDefinition cat s -> Schema s -> m (Schema s)
safeDefineType) Schema s
schema [TypeDefinition cat s]
types
defineSchemaWith [TypeDefinition cat s]
_ (Maybe (TypeDefinition OBJECT s)
Nothing, Maybe (TypeDefinition OBJECT s)
_, Maybe (TypeDefinition OBJECT s)
_) = ValidationErrors -> f (Schema s)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure [ValidationError
"Query root type must be provided." :: ValidationError]

excludeTypes :: [Maybe (TypeDefinition c1 s)] -> [TypeDefinition c2 s] -> [TypeDefinition c2 s]
excludeTypes :: [Maybe (TypeDefinition c1 s)]
-> [TypeDefinition c2 s] -> [TypeDefinition c2 s]
excludeTypes [Maybe (TypeDefinition c1 s)]
exclusionTypes = (TypeDefinition c2 s -> Bool)
-> [TypeDefinition c2 s] -> [TypeDefinition c2 s]
forall a. (a -> Bool) -> [a] -> [a]
filter ((TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [TypeName]
blacklist) (TypeName -> Bool)
-> (TypeDefinition c2 s -> TypeName) -> TypeDefinition c2 s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDefinition c2 s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName)
  where
    blacklist :: [TypeName]
    blacklist :: [TypeName]
blacklist = (TypeDefinition c1 s -> TypeName)
-> [TypeDefinition c1 s] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeDefinition c1 s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName ([Maybe (TypeDefinition c1 s)] -> [TypeDefinition c1 s]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (TypeDefinition c1 s)]
exclusionTypes)

withDirectives ::
  [DirectiveDefinition s] ->
  Schema s ->
  Schema s
withDirectives :: [DirectiveDefinition s] -> Schema s -> Schema s
withDirectives [DirectiveDefinition s]
dirs Schema {[DirectiveDefinition s]
Maybe (TypeDefinition OBJECT s)
TypeLib s
TypeDefinition OBJECT s
directiveDefinitions :: [DirectiveDefinition s]
subscription :: Maybe (TypeDefinition OBJECT s)
mutation :: Maybe (TypeDefinition OBJECT s)
query :: TypeDefinition OBJECT s
types :: TypeLib s
directiveDefinitions :: forall (s :: Stage). Schema s -> [DirectiveDefinition s]
subscription :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
query :: forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
types :: forall (s :: Stage). Schema s -> TypeLib s
..} =
  Schema :: forall (s :: Stage).
TypeLib s
-> TypeDefinition OBJECT s
-> Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> [DirectiveDefinition s]
-> Schema s
Schema
    { directiveDefinitions :: [DirectiveDefinition s]
directiveDefinitions = [DirectiveDefinition s]
directiveDefinitions [DirectiveDefinition s]
-> [DirectiveDefinition s] -> [DirectiveDefinition s]
forall a. Semigroup a => a -> a -> a
<> [DirectiveDefinition s]
dirs,
      Maybe (TypeDefinition OBJECT s)
TypeLib s
TypeDefinition OBJECT s
subscription :: Maybe (TypeDefinition OBJECT s)
mutation :: Maybe (TypeDefinition OBJECT s)
query :: TypeDefinition OBJECT s
types :: TypeLib s
subscription :: Maybe (TypeDefinition OBJECT s)
mutation :: Maybe (TypeDefinition OBJECT s)
query :: TypeDefinition OBJECT s
types :: TypeLib s
..
    }

buildSchema ::
  (Monad m, Failure ValidationErrors m) =>
  ( Maybe SchemaDefinition,
    [TypeDefinition ANY s],
    [DirectiveDefinition s]
  ) ->
  m (Schema s)
buildSchema :: (Maybe SchemaDefinition, [TypeDefinition ANY s],
 [DirectiveDefinition s])
-> m (Schema s)
buildSchema (Maybe SchemaDefinition
Nothing, [TypeDefinition ANY s]
types, [DirectiveDefinition s]
dirs) = [DirectiveDefinition s] -> Schema s -> Schema s
forall (s :: Stage).
[DirectiveDefinition s] -> Schema s -> Schema s
withDirectives [DirectiveDefinition s]
dirs (Schema s -> Schema s) -> m (Schema s) -> m (Schema s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDefinition ANY s] -> m (Schema s)
forall k (m :: k -> *) a (coll :: k).
FromElems m a coll =>
[a] -> m coll
fromElems [TypeDefinition ANY s]
types
buildSchema (Just SchemaDefinition
schemaDef, [TypeDefinition ANY s]
types, [DirectiveDefinition s]
dirs) =
  [DirectiveDefinition s] -> Schema s -> Schema s
forall (s :: Stage).
[DirectiveDefinition s] -> Schema s -> Schema s
withDirectives
    [DirectiveDefinition s]
dirs
    (Schema s -> Schema s) -> m (Schema s) -> m (Schema s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( (OperationType -> m (Maybe (TypeDefinition OBJECT s)))
-> (OperationType, OperationType, OperationType)
-> m (Maybe (TypeDefinition OBJECT s),
      Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
forall (t :: * -> *) a b.
Applicative t =>
(a -> t b) -> (a, a, a) -> t (b, b, b)
traverse3 OperationType -> m (Maybe (TypeDefinition OBJECT s))
selectOp (OperationType
Query, OperationType
Mutation, OperationType
Subscription)
            m (Maybe (TypeDefinition OBJECT s),
   Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> ((Maybe (TypeDefinition OBJECT s),
     Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
    -> m (Schema s))
-> m (Schema s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TypeDefinition ANY s]
-> (Maybe (TypeDefinition OBJECT s),
    Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> m (Schema s)
forall (f :: * -> *) (cat :: TypeCategory) (s :: Stage).
(Monad f, Failure ValidationErrors f) =>
[TypeDefinition cat s]
-> (Maybe (TypeDefinition OBJECT s),
    Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> f (Schema s)
defineSchemaWith [TypeDefinition ANY s]
types
        )
  where
    selectOp :: OperationType -> m (Maybe (TypeDefinition OBJECT s))
selectOp OperationType
op = SchemaDefinition
-> OperationType
-> [TypeDefinition ANY s]
-> m (Maybe (TypeDefinition OBJECT s))
forall (f :: * -> *) (s :: Stage).
(Monad f, Failure ValidationErrors f) =>
SchemaDefinition
-> OperationType
-> [TypeDefinition ANY s]
-> f (Maybe (TypeDefinition OBJECT s))
selectOperation SchemaDefinition
schemaDef OperationType
op [TypeDefinition ANY s]
types

traverse3 :: Applicative t => (a -> t b) -> (a, a, a) -> t (b, b, b)
traverse3 :: (a -> t b) -> (a, a, a) -> t (b, b, b)
traverse3 a -> t b
f (a
a1, a
a2, a
a3) = (,,) (b -> b -> b -> (b, b, b)) -> t b -> t (b -> b -> (b, b, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> t b
f a
a1 t (b -> b -> (b, b, b)) -> t b -> t (b -> (b, b, b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> t b
f a
a2 t (b -> (b, b, b)) -> t b -> t (b, b, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> t b
f a
a3

typeReference ::
  (Monad m, Failure ValidationErrors m) =>
  [TypeDefinition ANY s] ->
  RootOperationTypeDefinition ->
  m (Maybe (TypeDefinition OBJECT s))
typeReference :: [TypeDefinition ANY s]
-> RootOperationTypeDefinition
-> m (Maybe (TypeDefinition OBJECT s))
typeReference [TypeDefinition ANY s]
types RootOperationTypeDefinition
rootOperation =
  [TypeDefinition ANY s]
-> RootOperationTypeDefinition
-> m (Maybe (TypeDefinition OBJECT s))
forall (m :: * -> *) (s :: Stage).
(Applicative m, Failure ValidationErrors m) =>
[TypeDefinition ANY s]
-> RootOperationTypeDefinition
-> m (Maybe (TypeDefinition OBJECT s))
popByKey [TypeDefinition ANY s]
types RootOperationTypeDefinition
rootOperation
    m (Maybe (TypeDefinition OBJECT s))
-> (Maybe (TypeDefinition OBJECT s)
    -> m (Maybe (TypeDefinition OBJECT s)))
-> m (Maybe (TypeDefinition OBJECT s))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe (TypeDefinition OBJECT s))
-> (TypeDefinition OBJECT s -> m (Maybe (TypeDefinition OBJECT s)))
-> Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (ValidationErrors -> m (Maybe (TypeDefinition OBJECT s))
forall error (f :: * -> *) v. Failure error f => error -> f v
failure [ValidationError
"Unknown type " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation (RootOperationTypeDefinition -> TypeName
rootOperationTypeDefinitionName RootOperationTypeDefinition
rootOperation) ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"."])
      (Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TypeDefinition OBJECT s)
 -> m (Maybe (TypeDefinition OBJECT s)))
-> (TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s))
-> TypeDefinition OBJECT s
-> m (Maybe (TypeDefinition OBJECT s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s)
forall a. a -> Maybe a
Just)

selectOperation ::
  ( Monad f,
    Failure ValidationErrors f
  ) =>
  SchemaDefinition ->
  OperationType ->
  [TypeDefinition ANY s] ->
  f (Maybe (TypeDefinition OBJECT s))
selectOperation :: SchemaDefinition
-> OperationType
-> [TypeDefinition ANY s]
-> f (Maybe (TypeDefinition OBJECT s))
selectOperation SchemaDefinition
schemaDef OperationType
operationType [TypeDefinition ANY s]
lib =
  f (Maybe (TypeDefinition OBJECT s))
-> (RootOperationTypeDefinition
    -> f (Maybe (TypeDefinition OBJECT s)))
-> OperationType
-> SchemaDefinition
-> f (Maybe (TypeDefinition OBJECT s))
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr (Maybe (TypeDefinition OBJECT s)
-> f (Maybe (TypeDefinition OBJECT s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TypeDefinition OBJECT s)
forall a. Maybe a
Nothing) ([TypeDefinition ANY s]
-> RootOperationTypeDefinition
-> f (Maybe (TypeDefinition OBJECT s))
forall (m :: * -> *) (s :: Stage).
(Monad m, Failure ValidationErrors m) =>
[TypeDefinition ANY s]
-> RootOperationTypeDefinition
-> m (Maybe (TypeDefinition OBJECT s))
typeReference [TypeDefinition ANY s]
lib) OperationType
operationType SchemaDefinition
schemaDef

initTypeLib :: TypeDefinition OBJECT s -> Schema s
initTypeLib :: TypeDefinition OBJECT s -> Schema s
initTypeLib TypeDefinition OBJECT s
query =
  Schema :: forall (s :: Stage).
TypeLib s
-> TypeDefinition OBJECT s
-> Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> [DirectiveDefinition s]
-> Schema s
Schema
    { types :: TypeLib s
types = TypeLib s
forall a coll. Collection a coll => coll
empty,
      query :: TypeDefinition OBJECT s
query = TypeDefinition OBJECT s
query,
      mutation :: Maybe (TypeDefinition OBJECT s)
mutation = Maybe (TypeDefinition OBJECT s)
forall a. Maybe a
Nothing,
      subscription :: Maybe (TypeDefinition OBJECT s)
subscription = Maybe (TypeDefinition OBJECT s)
forall a. Maybe a
Nothing,
      directiveDefinitions :: [DirectiveDefinition s]
directiveDefinitions = [DirectiveDefinition s]
forall a coll. Collection a coll => coll
empty
    }

isType :: TypeName -> TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s)
isType :: TypeName -> TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s)
isType TypeName
name TypeDefinition OBJECT s
x
  | TypeName
name TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeDefinition OBJECT s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition OBJECT s
x = TypeDefinition ANY s -> Maybe (TypeDefinition ANY s)
forall a. a -> Maybe a
Just (TypeDefinition OBJECT s -> TypeDefinition ANY s
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
ToCategory a k ANY =>
a k s -> a ANY s
toAny TypeDefinition OBJECT s
x)
  | Bool
otherwise = Maybe (TypeDefinition ANY s)
forall a. Maybe a
Nothing

lookupDataType :: TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
lookupDataType :: TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
lookupDataType TypeName
name Schema {TypeLib s
types :: TypeLib s
types :: forall (s :: Stage). Schema s -> TypeLib s
types, TypeDefinition OBJECT s
query :: TypeDefinition OBJECT s
query :: forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query, Maybe (TypeDefinition OBJECT s)
mutation :: Maybe (TypeDefinition OBJECT s)
mutation :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation, Maybe (TypeDefinition OBJECT s)
subscription :: Maybe (TypeDefinition OBJECT s)
subscription :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
subscription} =
  TypeName -> TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s)
forall (s :: Stage).
TypeName -> TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s)
isType TypeName
name TypeDefinition OBJECT s
query
    Maybe (TypeDefinition ANY s)
-> Maybe (TypeDefinition ANY s) -> Maybe (TypeDefinition ANY s)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe (TypeDefinition OBJECT s)
mutation Maybe (TypeDefinition OBJECT s)
-> (TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s))
-> Maybe (TypeDefinition ANY s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeName -> TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s)
forall (s :: Stage).
TypeName -> TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s)
isType TypeName
name)
    Maybe (TypeDefinition ANY s)
-> Maybe (TypeDefinition ANY s) -> Maybe (TypeDefinition ANY s)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe (TypeDefinition OBJECT s)
subscription Maybe (TypeDefinition OBJECT s)
-> (TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s))
-> Maybe (TypeDefinition ANY s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeName -> TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s)
forall (s :: Stage).
TypeName -> TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s)
isType TypeName
name)
    Maybe (TypeDefinition ANY s)
-> Maybe (TypeDefinition ANY s) -> Maybe (TypeDefinition ANY s)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (TypeDefinition ANY s)
-> (TypeDefinition ANY s -> Maybe (TypeDefinition ANY s))
-> TypeName
-> TypeLib s
-> Maybe (TypeDefinition ANY s)
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr Maybe (TypeDefinition ANY s)
forall a. Maybe a
Nothing TypeDefinition ANY s -> Maybe (TypeDefinition ANY s)
forall a. a -> Maybe a
Just TypeName
name TypeLib s
types

-- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types
-------------------------------------------------------------------------
-- TypeDefinition :
--   ScalarTypeDefinition
--   ObjectTypeDefinition
--   InterfaceTypeDefinition
--   UnionTypeDefinition
--   EnumTypeDefinition
--   InputObjectTypeDefinition

data TypeDefinition (a :: TypeCategory) (s :: Stage) = TypeDefinition
  { TypeDefinition a s -> Maybe Text
typeDescription :: Maybe Description,
    TypeDefinition a s -> TypeName
typeName :: TypeName,
    TypeDefinition a s -> Directives s
typeDirectives :: Directives s,
    TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE a s
  }
  deriving (Int -> TypeDefinition a s -> ShowS
[TypeDefinition a s] -> ShowS
TypeDefinition a s -> String
(Int -> TypeDefinition a s -> ShowS)
-> (TypeDefinition a s -> String)
-> ([TypeDefinition a s] -> ShowS)
-> Show (TypeDefinition a s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (a :: TypeCategory) (s :: Stage).
Int -> TypeDefinition a s -> ShowS
forall (a :: TypeCategory) (s :: Stage).
[TypeDefinition a s] -> ShowS
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> String
showList :: [TypeDefinition a s] -> ShowS
$cshowList :: forall (a :: TypeCategory) (s :: Stage).
[TypeDefinition a s] -> ShowS
show :: TypeDefinition a s -> String
$cshow :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> String
showsPrec :: Int -> TypeDefinition a s -> ShowS
$cshowsPrec :: forall (a :: TypeCategory) (s :: Stage).
Int -> TypeDefinition a s -> ShowS
Show, TypeDefinition a s -> Q Exp
TypeDefinition a s -> Q (TExp (TypeDefinition a s))
(TypeDefinition a s -> Q Exp)
-> (TypeDefinition a s -> Q (TExp (TypeDefinition a s)))
-> Lift (TypeDefinition a s)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Q Exp
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Q (TExp (TypeDefinition a s))
liftTyped :: TypeDefinition a s -> Q (TExp (TypeDefinition a s))
$cliftTyped :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Q (TExp (TypeDefinition a s))
lift :: TypeDefinition a s -> Q Exp
$clift :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Q Exp
Lift)

instance KeyOf TypeName (TypeDefinition a s) where
  keyOf :: TypeDefinition a s -> TypeName
keyOf = TypeDefinition a s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName

instance NameCollision (TypeDefinition cat s) where
  nameCollision :: TypeDefinition cat s -> ValidationError
nameCollision TypeDefinition cat s
x = ValidationError
"There can Be only One TypeDefinition Named " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation (TypeDefinition cat s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition cat s
x) ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"."

instance
  ToCategory (TypeContent TRUE) cat cat' =>
  ToCategory TypeDefinition cat cat'
  where
  toCategory :: TypeDefinition cat s -> TypeDefinition cat' s
toCategory TypeDefinition {TypeContent TRUE cat s
typeContent :: TypeContent TRUE cat s
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent, Directives s
Maybe Text
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Text
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Text
..} =
    TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Text
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
      { typeContent :: TypeContent TRUE cat' s
typeContent = TypeContent TRUE cat s -> TypeContent TRUE cat' s
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (k' :: TypeCategory) (s :: Stage).
ToCategory a k k' =>
a k s -> a k' s
toCategory TypeContent TRUE cat s
typeContent,
        Directives s
Maybe Text
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Text
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Text
..
      }

possibleTypes :: TypeDefinition a s -> Schema s' -> [TypeName]
possibleTypes :: TypeDefinition a s -> Schema s' -> [TypeName]
possibleTypes
  TypeDefinition
    { TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName,
      typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {[TypeName]
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
objectImplements :: [TypeName]
objectImplements}
    }
  Schema s'
_ = TypeName
typeName TypeName -> [TypeName] -> [TypeName]
forall a. a -> [a] -> [a]
: [TypeName]
objectImplements
possibleTypes TypeDefinition {typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName = TypeName
name, typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInterface {}} Schema s'
schema =
  TypeName
name TypeName -> [TypeName] -> [TypeName]
forall a. a -> [a] -> [a]
: (TypeDefinition ANY s' -> TypeName)
-> [TypeDefinition ANY s'] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeDefinition ANY s' -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeName -> Schema s' -> [TypeDefinition ANY s']
forall (s :: Stage). TypeName -> Schema s -> [TypeDefinition ANY s]
possibleInterfaceTypes TypeName
name Schema s'
schema)
possibleTypes TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName} Schema s'
_ = [TypeName
typeName]

possibleInterfaceTypes ::
  TypeName ->
  Schema s ->
  [TypeDefinition ANY s]
possibleInterfaceTypes :: TypeName -> Schema s -> [TypeDefinition ANY s]
possibleInterfaceTypes TypeName
name Schema s
schema = (TypeDefinition ANY s -> Maybe (TypeDefinition ANY s))
-> [TypeDefinition ANY s] -> [TypeDefinition ANY s]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TypeName -> TypeDefinition ANY s -> Maybe (TypeDefinition ANY s)
forall (c :: TypeCategory) (s :: Stage).
TypeName -> TypeDefinition c s -> Maybe (TypeDefinition c s)
isPossibleInterfaceType TypeName
name) (Schema s -> [TypeDefinition ANY s]
forall a coll. Elems a coll => coll -> [a]
elems Schema s
schema)

isPossibleInterfaceType ::
  TypeName ->
  TypeDefinition c s ->
  Maybe (TypeDefinition c s)
isPossibleInterfaceType :: TypeName -> TypeDefinition c s -> Maybe (TypeDefinition c s)
isPossibleInterfaceType TypeName
name typeDef :: TypeDefinition c s
typeDef@TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName, typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {[TypeName]
objectImplements :: [TypeName]
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
objectImplements}}
  | TypeName
name TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (TypeName
typeName TypeName -> [TypeName] -> [TypeName]
forall a. a -> [a] -> [a]
: [TypeName]
objectImplements) = TypeDefinition c s -> Maybe (TypeDefinition c s)
forall a. a -> Maybe a
Just TypeDefinition c s
typeDef
isPossibleInterfaceType TypeName
_ TypeDefinition c s
_ = Maybe (TypeDefinition c s)
forall a. Maybe a
Nothing

instance
  (FromCategory (TypeContent TRUE) cat cat') =>
  FromCategory TypeDefinition cat cat'
  where
  fromCategory :: TypeDefinition cat s -> Maybe (TypeDefinition cat' s)
fromCategory TypeDefinition {TypeContent TRUE cat s
typeContent :: TypeContent TRUE cat s
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent, Directives s
Maybe Text
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Text
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Text
..} = TypeContent TRUE cat' s -> TypeDefinition cat' s
bla (TypeContent TRUE cat' s -> TypeDefinition cat' s)
-> Maybe (TypeContent TRUE cat' s) -> Maybe (TypeDefinition cat' s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContent TRUE cat s -> Maybe (TypeContent TRUE cat' s)
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (k' :: TypeCategory) (s :: Stage).
FromCategory a k k' =>
a k s -> Maybe (a k' s)
fromCategory TypeContent TRUE cat s
typeContent
    where
      bla :: TypeContent TRUE cat' s -> TypeDefinition cat' s
bla TypeContent TRUE cat' s
x = TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Text
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition {typeContent :: TypeContent TRUE cat' s
typeContent = TypeContent TRUE cat' s
x, Directives s
Maybe Text
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Text
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Text
..}

data
  TypeContent
    (b :: Bool)
    (a :: TypeCategory)
    (s :: Stage)
  where
  DataScalar ::
    { TypeContent (ELEM LEAF a) a s -> ScalarDefinition
dataScalar :: ScalarDefinition
    } ->
    TypeContent (ELEM LEAF a) a s
  DataEnum ::
    { TypeContent (ELEM LEAF a) a s -> DataEnum s
enumMembers :: DataEnum s
    } ->
    TypeContent (ELEM LEAF a) a s
  DataInputObject ::
    { TypeContent (ELEM IN a) a s -> FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
    } ->
    TypeContent (ELEM IN a) a s
  DataInputUnion ::
    { TypeContent (ELEM IN a) a s -> DataInputUnion s
inputUnionMembers :: DataInputUnion s
    } ->
    TypeContent (ELEM IN a) a s
  DataObject ::
    { TypeContent (ELEM OBJECT a) a s -> [TypeName]
objectImplements :: [TypeName],
      TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
    } ->
    TypeContent (ELEM OBJECT a) a s
  DataUnion ::
    { TypeContent (ELEM OUT a) a s -> DataUnion s
unionMembers :: DataUnion s
    } ->
    TypeContent (ELEM OUT a) a s
  DataInterface ::
    { TypeContent (ELEM IMPLEMENTABLE a) a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
    } ->
    TypeContent (ELEM IMPLEMENTABLE a) a s

deriving instance Show (TypeContent a b s)

deriving instance Lift (TypeContent a b s)

instance ToCategory (TypeContent TRUE) a ANY where
  toCategory :: TypeContent TRUE a s -> TypeContent TRUE ANY s
toCategory DataScalar {ScalarDefinition
dataScalar :: ScalarDefinition
dataScalar :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM LEAF a) a s -> ScalarDefinition
..} = DataScalar :: forall (a :: TypeCategory) (s :: Stage).
ScalarDefinition -> TypeContent (ELEM LEAF a) a s
DataScalar {ScalarDefinition
dataScalar :: ScalarDefinition
dataScalar :: ScalarDefinition
..}
  toCategory DataEnum {DataEnum s
enumMembers :: DataEnum s
enumMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM LEAF a) a s -> DataEnum s
..} = DataEnum :: forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (ELEM LEAF a) a s
DataEnum {DataEnum s
enumMembers :: DataEnum s
enumMembers :: DataEnum s
..}
  toCategory DataInputObject {FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IN a) a s -> FieldsDefinition IN s
..} = DataInputObject :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> TypeContent (ELEM IN a) a s
DataInputObject {FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
..}
  toCategory DataInputUnion {DataInputUnion s
inputUnionMembers :: DataInputUnion s
inputUnionMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IN a) a s -> DataInputUnion s
..} = DataInputUnion :: forall (s :: Stage) (a :: TypeCategory).
DataInputUnion s -> TypeContent (ELEM IN a) a s
DataInputUnion {DataInputUnion s
inputUnionMembers :: DataInputUnion s
inputUnionMembers :: DataInputUnion s
..}
  toCategory DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
..} = DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
..}
  toCategory DataUnion {DataUnion s
unionMembers :: DataUnion s
unionMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OUT a) a s -> DataUnion s
..} = DataUnion :: forall (s :: Stage) (a :: TypeCategory).
DataUnion s -> TypeContent (ELEM OUT a) a s
DataUnion {DataUnion s
unionMembers :: DataUnion s
unionMembers :: DataUnion s
..}
  toCategory DataInterface {FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IMPLEMENTABLE a) a s -> FieldsDefinition OUT s
..} = DataInterface :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent (ELEM IMPLEMENTABLE a) a s
DataInterface {FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
..}

instance ToCategory (TypeContent TRUE) OBJECT IMPLEMENTABLE where
  toCategory :: TypeContent TRUE OBJECT s -> TypeContent TRUE IMPLEMENTABLE s
toCategory DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
..} = DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
..}

instance FromCategory (TypeContent TRUE) ANY IN where
  fromCategory :: TypeContent TRUE ANY s -> Maybe (TypeContent TRUE IN s)
fromCategory DataScalar {ScalarDefinition
dataScalar :: ScalarDefinition
dataScalar :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM LEAF a) a s -> ScalarDefinition
..} = TypeContent TRUE IN s -> Maybe (TypeContent TRUE IN s)
forall a. a -> Maybe a
Just DataScalar :: forall (a :: TypeCategory) (s :: Stage).
ScalarDefinition -> TypeContent (ELEM LEAF a) a s
DataScalar {ScalarDefinition
dataScalar :: ScalarDefinition
dataScalar :: ScalarDefinition
..}
  fromCategory DataEnum {DataEnum s
enumMembers :: DataEnum s
enumMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM LEAF a) a s -> DataEnum s
..} = TypeContent TRUE IN s -> Maybe (TypeContent TRUE IN s)
forall a. a -> Maybe a
Just DataEnum :: forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (ELEM LEAF a) a s
DataEnum {DataEnum s
enumMembers :: DataEnum s
enumMembers :: DataEnum s
..}
  fromCategory DataInputObject {FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IN a) a s -> FieldsDefinition IN s
..} = TypeContent TRUE IN s -> Maybe (TypeContent TRUE IN s)
forall a. a -> Maybe a
Just DataInputObject :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> TypeContent (ELEM IN a) a s
DataInputObject {FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
..}
  fromCategory DataInputUnion {DataInputUnion s
inputUnionMembers :: DataInputUnion s
inputUnionMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IN a) a s -> DataInputUnion s
..} = TypeContent TRUE IN s -> Maybe (TypeContent TRUE IN s)
forall a. a -> Maybe a
Just DataInputUnion :: forall (s :: Stage) (a :: TypeCategory).
DataInputUnion s -> TypeContent (ELEM IN a) a s
DataInputUnion {DataInputUnion s
inputUnionMembers :: DataInputUnion s
inputUnionMembers :: DataInputUnion s
..}
  fromCategory TypeContent TRUE ANY s
_ = Maybe (TypeContent TRUE IN s)
forall a. Maybe a
Nothing

instance FromCategory (TypeContent TRUE) ANY OUT where
  fromCategory :: TypeContent TRUE ANY s -> Maybe (TypeContent TRUE OUT s)
fromCategory DataScalar {ScalarDefinition
dataScalar :: ScalarDefinition
dataScalar :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM LEAF a) a s -> ScalarDefinition
..} = TypeContent TRUE OUT s -> Maybe (TypeContent TRUE OUT s)
forall a. a -> Maybe a
Just DataScalar :: forall (a :: TypeCategory) (s :: Stage).
ScalarDefinition -> TypeContent (ELEM LEAF a) a s
DataScalar {ScalarDefinition
dataScalar :: ScalarDefinition
dataScalar :: ScalarDefinition
..}
  fromCategory DataEnum {DataEnum s
enumMembers :: DataEnum s
enumMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM LEAF a) a s -> DataEnum s
..} = TypeContent TRUE OUT s -> Maybe (TypeContent TRUE OUT s)
forall a. a -> Maybe a
Just DataEnum :: forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (ELEM LEAF a) a s
DataEnum {DataEnum s
enumMembers :: DataEnum s
enumMembers :: DataEnum s
..}
  fromCategory DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
..} = TypeContent TRUE OUT s -> Maybe (TypeContent TRUE OUT s)
forall a. a -> Maybe a
Just DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
..}
  fromCategory DataUnion {DataUnion s
unionMembers :: DataUnion s
unionMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OUT a) a s -> DataUnion s
..} = TypeContent TRUE OUT s -> Maybe (TypeContent TRUE OUT s)
forall a. a -> Maybe a
Just DataUnion :: forall (s :: Stage) (a :: TypeCategory).
DataUnion s -> TypeContent (ELEM OUT a) a s
DataUnion {DataUnion s
unionMembers :: DataUnion s
unionMembers :: DataUnion s
..}
  fromCategory DataInterface {FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IMPLEMENTABLE a) a s -> FieldsDefinition OUT s
..} = TypeContent TRUE OUT s -> Maybe (TypeContent TRUE OUT s)
forall a. a -> Maybe a
Just DataInterface :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent (ELEM IMPLEMENTABLE a) a s
DataInterface {FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
..}
  fromCategory TypeContent TRUE ANY s
_ = Maybe (TypeContent TRUE OUT s)
forall a. Maybe a
Nothing

instance FromCategory (TypeContent TRUE) ANY OBJECT where
  fromCategory :: TypeContent TRUE ANY s -> Maybe (TypeContent TRUE OBJECT s)
fromCategory DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
..} = TypeContent TRUE OBJECT s -> Maybe (TypeContent TRUE OBJECT s)
forall a. a -> Maybe a
Just DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
..}
  fromCategory TypeContent TRUE ANY s
_ = Maybe (TypeContent TRUE OBJECT s)
forall a. Maybe a
Nothing

instance FromCategory (TypeContent TRUE) ANY IMPLEMENTABLE where
  fromCategory :: TypeContent TRUE ANY s -> Maybe (TypeContent TRUE IMPLEMENTABLE s)
fromCategory DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
..} = TypeContent TRUE IMPLEMENTABLE s
-> Maybe (TypeContent TRUE IMPLEMENTABLE s)
forall a. a -> Maybe a
Just DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
..}
  fromCategory DataInterface {FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IMPLEMENTABLE a) a s -> FieldsDefinition OUT s
..} = TypeContent TRUE IMPLEMENTABLE s
-> Maybe (TypeContent TRUE IMPLEMENTABLE s)
forall a. a -> Maybe a
Just DataInterface :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent (ELEM IMPLEMENTABLE a) a s
DataInterface {FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
..}
  fromCategory TypeContent TRUE ANY s
_ = Maybe (TypeContent TRUE IMPLEMENTABLE s)
forall a. Maybe a
Nothing

mkType :: TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType :: TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
typeName TypeContent TRUE a s
typeContent =
  TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Text
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
    { TypeName
typeName :: TypeName
typeName :: TypeName
typeName,
      typeDescription :: Maybe Text
typeDescription = Maybe Text
forall a. Maybe a
Nothing,
      typeDirectives :: Directives s
typeDirectives = [],
      TypeContent TRUE a s
typeContent :: TypeContent TRUE a s
typeContent :: TypeContent TRUE a s
typeContent
    }

createScalarType :: ELEM LEAF a ~ TRUE => TypeName -> TypeDefinition a s
createScalarType :: TypeName -> TypeDefinition a s
createScalarType TypeName
typeName = TypeName -> TypeContent TRUE a s -> TypeDefinition a s
forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
typeName (TypeContent TRUE a s -> TypeDefinition a s)
-> TypeContent TRUE a s -> TypeDefinition a s
forall a b. (a -> b) -> a -> b
$ ScalarDefinition -> TypeContent (ELEM LEAF a) a s
forall (a :: TypeCategory) (s :: Stage).
ScalarDefinition -> TypeContent (ELEM LEAF a) a s
DataScalar ((Value VALID -> Either Text (Value VALID)) -> ScalarDefinition
ScalarDefinition Value VALID -> Either Text (Value VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

mkEnumContent :: ELEM LEAF a ~ TRUE => [TypeName] -> TypeContent TRUE a s
mkEnumContent :: [TypeName] -> TypeContent TRUE a s
mkEnumContent [TypeName]
typeData = DataEnum s -> TypeContent (ELEM LEAF a) a s
forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (ELEM LEAF a) a s
DataEnum ((TypeName -> DataEnumValue s) -> [TypeName] -> DataEnum s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeName -> DataEnumValue s
forall (s :: Stage). TypeName -> DataEnumValue s
mkEnumValue [TypeName]
typeData)

mkUnionContent :: [TypeName] -> TypeContent TRUE OUT s
mkUnionContent :: [TypeName] -> TypeContent TRUE OUT s
mkUnionContent [TypeName]
typeData = DataUnion s -> TypeContent (ELEM OUT OUT) OUT s
forall (s :: Stage) (a :: TypeCategory).
DataUnion s -> TypeContent (ELEM OUT a) a s
DataUnion (DataUnion s -> TypeContent (ELEM OUT OUT) OUT s)
-> DataUnion s -> TypeContent (ELEM OUT OUT) OUT s
forall a b. (a -> b) -> a -> b
$ (TypeName -> UnionMember OUT s) -> [TypeName] -> DataUnion s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeName -> UnionMember OUT s
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkUnionMember [TypeName]
typeData

mkEnumValue :: TypeName -> DataEnumValue s
mkEnumValue :: TypeName -> DataEnumValue s
mkEnumValue TypeName
enumName =
  DataEnumValue :: forall (s :: Stage).
Maybe Text -> TypeName -> [Directive s] -> DataEnumValue s
DataEnumValue
    { TypeName
enumName :: TypeName
enumName :: TypeName
enumName,
      enumDescription :: Maybe Text
enumDescription = Maybe Text
forall a. Maybe a
Nothing,
      enumDirectives :: [Directive s]
enumDirectives = []
    }

isEntNode :: TypeContent TRUE a s -> Bool
isEntNode :: TypeContent TRUE a s -> Bool
isEntNode DataScalar {} = Bool
True
isEntNode DataEnum {} = Bool
True
isEntNode TypeContent TRUE a s
_ = Bool
False

kindOf :: TypeDefinition a s -> TypeKind
kindOf :: TypeDefinition a s -> TypeKind
kindOf TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName, TypeContent TRUE a s
typeContent :: TypeContent TRUE a s
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent} = TypeContent TRUE a s -> TypeKind
__kind TypeContent TRUE a s
typeContent
  where
    __kind :: TypeContent TRUE a s -> TypeKind
__kind DataScalar {} = TypeKind
KindScalar
    __kind DataEnum {} = TypeKind
KindEnum
    __kind DataInputObject {} = TypeKind
KindInputObject
    __kind DataObject {} = Maybe OperationType -> TypeKind
KindObject (TypeName -> Maybe OperationType
toOperationType TypeName
typeName)
    __kind DataUnion {} = TypeKind
KindUnion
    __kind DataInputUnion {} = TypeKind
KindInputUnion
    __kind DataInterface {} = TypeKind
KindInterface

fromOperation :: Maybe (TypeDefinition OBJECT s) -> [TypeDefinition ANY s]
fromOperation :: Maybe (TypeDefinition OBJECT s) -> [TypeDefinition ANY s]
fromOperation (Just TypeDefinition OBJECT s
datatype) = [TypeDefinition OBJECT s -> TypeDefinition ANY s
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
ToCategory a k ANY =>
a k s -> a ANY s
toAny TypeDefinition OBJECT s
datatype]
fromOperation Maybe (TypeDefinition OBJECT s)
Nothing = []

safeDefineType ::
  ( Monad m,
    Failure ValidationErrors m
  ) =>
  TypeDefinition cat s ->
  Schema s ->
  m (Schema s)
safeDefineType :: TypeDefinition cat s -> Schema s -> m (Schema s)
safeDefineType dt :: TypeDefinition cat s
dt@TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName, typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInputUnion DataInputUnion s
enumKeys} Schema s
lib = do
  SafeHashMap TypeName (TypeDefinition ANY s)
types <- TypeDefinition ANY s
-> SafeHashMap TypeName (TypeDefinition ANY s)
-> m (SafeHashMap TypeName (TypeDefinition ANY s))
forall a k (m :: * -> *).
(NameCollision a, KeyOf k a, Monad m,
 Failure ValidationErrors m) =>
a -> SafeHashMap k a -> m (SafeHashMap k a)
insert TypeDefinition ANY s
unionTags (Schema s -> SafeHashMap TypeName (TypeDefinition ANY s)
forall (s :: Stage). Schema s -> TypeLib s
types Schema s
lib) m (SafeHashMap TypeName (TypeDefinition ANY s))
-> (SafeHashMap TypeName (TypeDefinition ANY s)
    -> m (SafeHashMap TypeName (TypeDefinition ANY s)))
-> m (SafeHashMap TypeName (TypeDefinition ANY s))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeDefinition ANY s
-> SafeHashMap TypeName (TypeDefinition ANY s)
-> m (SafeHashMap TypeName (TypeDefinition ANY s))
forall a k (m :: * -> *).
(NameCollision a, KeyOf k a, Monad m,
 Failure ValidationErrors m) =>
a -> SafeHashMap k a -> m (SafeHashMap k a)
insert (TypeDefinition cat s -> TypeDefinition ANY s
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
ToCategory a k ANY =>
a k s -> a ANY s
toAny TypeDefinition cat s
dt)
  Schema s -> m (Schema s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema s
lib {SafeHashMap TypeName (TypeDefinition ANY s)
types :: SafeHashMap TypeName (TypeDefinition ANY s)
types :: SafeHashMap TypeName (TypeDefinition ANY s)
types}
  where
    unionTags :: TypeDefinition ANY s
unionTags =
      TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Text
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
        { typeName :: TypeName
typeName = TypeName
typeName TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
"Tags",
          typeDescription :: Maybe Text
typeDescription = Maybe Text
forall a. Maybe a
Nothing,
          typeDirectives :: Directives s
typeDirectives = [],
          typeContent :: TypeContent TRUE ANY s
typeContent = [TypeName] -> TypeContent TRUE ANY s
forall (a :: TypeCategory) (s :: Stage).
(ELEM LEAF a ~ TRUE) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent ((UnionMember IN s -> TypeName) -> DataInputUnion s -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnionMember IN s -> TypeName
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName DataInputUnion s
enumKeys)
        }
safeDefineType TypeDefinition cat s
datatype Schema s
lib = do
  SafeHashMap TypeName (TypeDefinition ANY s)
types <- TypeDefinition ANY s
-> SafeHashMap TypeName (TypeDefinition ANY s)
-> m (SafeHashMap TypeName (TypeDefinition ANY s))
forall a k (m :: * -> *).
(NameCollision a, KeyOf k a, Monad m,
 Failure ValidationErrors m) =>
a -> SafeHashMap k a -> m (SafeHashMap k a)
insert (TypeDefinition cat s -> TypeDefinition ANY s
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
ToCategory a k ANY =>
a k s -> a ANY s
toAny TypeDefinition cat s
datatype) (Schema s -> SafeHashMap TypeName (TypeDefinition ANY s)
forall (s :: Stage). Schema s -> TypeLib s
types Schema s
lib)
  Schema s -> m (Schema s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema s
lib {SafeHashMap TypeName (TypeDefinition ANY s)
types :: SafeHashMap TypeName (TypeDefinition ANY s)
types :: SafeHashMap TypeName (TypeDefinition ANY s)
types}

lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a
lookupWith :: (a -> k) -> k -> [a] -> Maybe a
lookupWith a -> k
f k
key = (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
key) (k -> Bool) -> (a -> k) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> k
f)

popByKey ::
  (Applicative m, Failure ValidationErrors m) =>
  [TypeDefinition ANY s] ->
  RootOperationTypeDefinition ->
  m (Maybe (TypeDefinition OBJECT s))
popByKey :: [TypeDefinition ANY s]
-> RootOperationTypeDefinition
-> m (Maybe (TypeDefinition OBJECT s))
popByKey [TypeDefinition ANY s]
types (RootOperationTypeDefinition OperationType
opType TypeName
name) = case (TypeDefinition ANY s -> TypeName)
-> TypeName
-> [TypeDefinition ANY s]
-> Maybe (TypeDefinition ANY s)
forall k a. Eq k => (a -> k) -> k -> [a] -> Maybe a
lookupWith TypeDefinition ANY s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeName
name [TypeDefinition ANY s]
types of
  Just dt :: TypeDefinition ANY s
dt@TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {}} ->
    Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition ANY s -> Maybe (TypeDefinition OBJECT s)
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
FromCategory a ANY k =>
a ANY s -> Maybe (a k s)
fromAny TypeDefinition ANY s
dt)
  Just {} ->
    ValidationErrors -> m (Maybe (TypeDefinition OBJECT s))
forall error (f :: * -> *) v. Failure error f => error -> f v
failure
      [ String -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation (OperationType -> String
forall a. Show a => a -> String
show OperationType
opType)
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" root type must be Object type if provided, it cannot be "
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation TypeName
name
      ]
  Maybe (TypeDefinition ANY s)
_ -> Maybe (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TypeDefinition OBJECT s)
forall a. Maybe a
Nothing

__inputname :: FieldName
__inputname :: FieldName
__inputname = FieldName
"inputname"

mkInputUnionFields :: TypeName -> [UnionMember IN s] -> FieldsDefinition IN s
mkInputUnionFields :: TypeName -> [UnionMember IN s] -> FieldsDefinition IN s
mkInputUnionFields TypeName
name [UnionMember IN s]
members = [FieldDefinition IN s] -> FieldsDefinition IN s
forall (cat :: TypeCategory) (s :: Stage).
[FieldDefinition cat s] -> FieldsDefinition cat s
unsafeFromFields ([FieldDefinition IN s] -> FieldsDefinition IN s)
-> [FieldDefinition IN s] -> FieldsDefinition IN s
forall a b. (a -> b) -> a -> b
$ FieldDefinition IN s
fieldTag FieldDefinition IN s
-> [FieldDefinition IN s] -> [FieldDefinition IN s]
forall a. a -> [a] -> [a]
: (UnionMember IN s -> FieldDefinition IN s)
-> [UnionMember IN s] -> [FieldDefinition IN s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnionMember IN s -> FieldDefinition IN s
forall (s :: Stage). UnionMember IN s -> FieldDefinition IN s
mkUnionField [UnionMember IN s]
members
  where
    fieldTag :: FieldDefinition IN s
fieldTag =
      FieldDefinition :: forall (cat :: TypeCategory) (s :: Stage).
Maybe Text
-> FieldName
-> TypeRef
-> Maybe (FieldContent TRUE cat s)
-> [Directive s]
-> FieldDefinition cat s
FieldDefinition
        { fieldName :: FieldName
fieldName = FieldName
__inputname,
          fieldDescription :: Maybe Text
fieldDescription = Maybe Text
forall a. Maybe a
Nothing,
          fieldContent :: Maybe (FieldContent TRUE IN s)
fieldContent = Maybe (FieldContent TRUE IN s)
forall a. Maybe a
Nothing,
          fieldType :: TypeRef
fieldType = TypeName -> TypeRef
mkTypeRef (TypeName
name TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
"Tags"),
          fieldDirectives :: [Directive s]
fieldDirectives = []
        }

mkUnionField :: UnionMember IN s -> FieldDefinition IN s
mkUnionField :: UnionMember IN s -> FieldDefinition IN s
mkUnionField UnionMember {TypeName
memberName :: TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName} =
  FieldDefinition :: forall (cat :: TypeCategory) (s :: Stage).
Maybe Text
-> FieldName
-> TypeRef
-> Maybe (FieldContent TRUE cat s)
-> [Directive s]
-> FieldDefinition cat s
FieldDefinition
    { fieldName :: FieldName
fieldName = TypeName -> FieldName
toFieldName TypeName
memberName,
      fieldDescription :: Maybe Text
fieldDescription = Maybe Text
forall a. Maybe a
Nothing,
      fieldContent :: Maybe (FieldContent TRUE IN s)
fieldContent = Maybe (FieldContent TRUE IN s)
forall a. Maybe a
Nothing,
      fieldType :: TypeRef
fieldType =
        TypeRef :: TypeName -> Maybe String -> [TypeWrapper] -> TypeRef
TypeRef
          { typeConName :: TypeName
typeConName = TypeName
memberName,
            typeWrappers :: [TypeWrapper]
typeWrappers = [TypeWrapper
TypeMaybe],
            typeArgs :: Maybe String
typeArgs = Maybe String
forall a. Maybe a
Nothing
          },
      fieldDirectives :: [Directive s]
fieldDirectives = []
    }

--
-- OTHER
--------------------------------------------------------------------------------------------------

instance RenderGQL (Schema s) where
  render :: Schema s -> Rendering
render Schema s
schema =
    Rendering -> [Rendering] -> Rendering
intercalate Rendering
newline ((TypeDefinition ANY s -> Rendering)
-> [TypeDefinition ANY s] -> [Rendering]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeDefinition ANY s -> Rendering
forall a. RenderGQL a => a -> Rendering
render [TypeDefinition ANY s]
visibleTypes [Rendering] -> [Rendering] -> [Rendering]
forall a. Semigroup a => a -> a -> a
<> [[RootOperationTypeDefinition] -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderSchemaDefinition [RootOperationTypeDefinition]
entries])
    where
      entries :: [RootOperationTypeDefinition]
entries =
        OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition OperationType
Query (TypeDefinition OBJECT s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeDefinition OBJECT s -> TypeName)
-> TypeDefinition OBJECT s -> TypeName
forall a b. (a -> b) -> a -> b
$ Schema s -> TypeDefinition OBJECT s
forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query Schema s
schema)
          RootOperationTypeDefinition
-> [RootOperationTypeDefinition] -> [RootOperationTypeDefinition]
forall a. a -> [a] -> [a]
: [Maybe RootOperationTypeDefinition]
-> [RootOperationTypeDefinition]
forall a. [Maybe a] -> [a]
catMaybes
            [ OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition OperationType
Mutation (TypeName -> RootOperationTypeDefinition)
-> (TypeDefinition OBJECT s -> TypeName)
-> TypeDefinition OBJECT s
-> RootOperationTypeDefinition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDefinition OBJECT s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeDefinition OBJECT s -> RootOperationTypeDefinition)
-> Maybe (TypeDefinition OBJECT s)
-> Maybe RootOperationTypeDefinition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema s -> Maybe (TypeDefinition OBJECT s)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation Schema s
schema,
              OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition OperationType
Subscription (TypeName -> RootOperationTypeDefinition)
-> (TypeDefinition OBJECT s -> TypeName)
-> TypeDefinition OBJECT s
-> RootOperationTypeDefinition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDefinition OBJECT s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeDefinition OBJECT s -> RootOperationTypeDefinition)
-> Maybe (TypeDefinition OBJECT s)
-> Maybe RootOperationTypeDefinition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema s -> Maybe (TypeDefinition OBJECT s)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
subscription Schema s
schema
            ]
      visibleTypes :: [TypeDefinition ANY s]
visibleTypes = (TypeDefinition ANY s -> Bool)
-> [TypeDefinition ANY s] -> [TypeDefinition ANY s]
forall a. (a -> Bool) -> [a] -> [a]
filter (TypeName -> Bool
isNotSystemTypeName (TypeName -> Bool)
-> (TypeDefinition ANY s -> TypeName)
-> TypeDefinition ANY s
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDefinition ANY s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName) (Schema s -> [TypeDefinition ANY s]
forall a coll. Elems a coll => coll -> [a]
elems Schema s
schema)

instance RenderGQL (TypeDefinition a s) where
  render :: TypeDefinition a s -> Rendering
render TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName, TypeContent TRUE a s
typeContent :: TypeContent TRUE a s
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent} = TypeContent TRUE a s -> Rendering
__render TypeContent TRUE a s
typeContent Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
newline
    where
      __render :: TypeContent TRUE a s -> Rendering
__render DataInterface {FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IMPLEMENTABLE a) a s -> FieldsDefinition OUT s
interfaceFields} = Rendering
"interface " Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
render TypeName
typeName Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> FieldsDefinition OUT s -> Rendering
forall a. RenderGQL a => a -> Rendering
render FieldsDefinition OUT s
interfaceFields
      __render DataScalar {} = Rendering
"scalar " Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
render TypeName
typeName
      __render (DataEnum DataEnum s
tags) = Rendering
"enum " Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
render TypeName
typeName Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> DataEnum s -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderObject DataEnum s
tags
      __render (DataUnion DataUnion s
members) =
        Rendering
"union "
          Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
render TypeName
typeName
          Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
" = "
          Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> DataUnion s -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderMembers DataUnion s
members
      __render (DataInputObject FieldsDefinition IN s
fields) = Rendering
"input " Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
render TypeName
typeName Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> FieldsDefinition IN s -> Rendering
forall a. RenderGQL a => a -> Rendering
render FieldsDefinition IN s
fields
      __render (DataInputUnion DataInputUnion s
members) = Rendering
"input " Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
render TypeName
typeName Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> FieldsDefinition IN s -> Rendering
forall a. RenderGQL a => a -> Rendering
render FieldsDefinition IN s
fields
        where
          fields :: FieldsDefinition IN s
fields = TypeName -> DataInputUnion s -> FieldsDefinition IN s
forall (s :: Stage).
TypeName -> [UnionMember IN s] -> FieldsDefinition IN s
mkInputUnionFields TypeName
typeName DataInputUnion s
members
      __render DataObject {FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectFields} = Rendering
"type " Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
render TypeName
typeName Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> FieldsDefinition OUT s -> Rendering
forall a. RenderGQL a => a -> Rendering
render FieldsDefinition OUT s
objectFields