{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Parsing.Document.TypeSystem
  ( parseSchema,
    parseTypeDefinitions,
    parseDefinitions,
  )
where

import Data.ByteString.Lazy (ByteString)
import Data.Foldable (foldr')
import Data.Mergeable (NameCollision (nameCollision), throwErrors)
import Data.Morpheus.Ext.Result
  ( GQLResult,
  )
import Data.Morpheus.Internal.Utils
  ( fromElems,
  )
import Data.Morpheus.Parsing.Internal.Internal
  ( Parser,
    processParser,
  )
import Data.Morpheus.Parsing.Internal.Pattern
  ( argumentsDefinition,
    enumValueDefinition,
    fieldsDefinition,
    inputFieldsDefinition,
    optionalDirectives,
    parseDirectiveLocation,
    parseOperationType,
    typeDeclaration,
  )
import Data.Morpheus.Parsing.Internal.Terms
  ( at,
    collection,
    colon,
    equal,
    ignoredTokens,
    keyword,
    optDescription,
    optionalCollection,
    parseName,
    parseTypeName,
    pipe,
    sepByAnd,
    setOf,
  )
import Data.Morpheus.Parsing.Internal.Value
  ( Parse (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    CONST,
    Description,
    DirectiveDefinition (..),
    Directives,
    DirectivesDefinition,
    FieldsDefinition,
    OBJECT,
    OUT,
    RawTypeDefinition (..),
    RootOperationTypeDefinition (..),
    ScalarDefinition (..),
    Schema,
    SchemaDefinition (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    Value,
    buildSchema,
    mkUnionMember,
    type (<=!),
  )
import Relude hiding (ByteString)
import Text.Megaparsec
  ( eof,
    label,
    manyTill,
  )

mkObject ::
  (OBJECT <=! a) =>
  Maybe Description ->
  TypeName ->
  [TypeName] ->
  Directives s ->
  FieldsDefinition OUT s ->
  TypeDefinition a s
mkObject :: forall (a :: TypeCategory) (s :: Stage).
(OBJECT <=! a) =>
Maybe Description
-> TypeName
-> [TypeName]
-> Directives s
-> FieldsDefinition OUT s
-> TypeDefinition a s
mkObject Maybe Description
typeDescription TypeName
typeName [TypeName]
objectImplements Directives s
typeDirectives FieldsDefinition OUT s
objectFields =
  TypeDefinition
    { typeContent :: TypeContent TRUE a s
typeContent = DataObject {[TypeName]
objectImplements :: [TypeName]
objectImplements :: [TypeName]
objectImplements, FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields},
      Maybe Description
Directives s
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
..
    }
{-# INLINEABLE mkObject #-}

-- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars
--
--  ScalarTypeDefinition:
--    Description(opt) scalar Name Directives(Const)(opt)
--
scalarTypeDefinition ::
  Parse (Value s) =>
  Maybe Description ->
  Parser (TypeDefinition ANY s)
scalarTypeDefinition :: forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
scalarTypeDefinition Maybe Description
typeDescription =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"ScalarTypeDefinition" forall a b. (a -> b) -> a -> b
$
    forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition Maybe Description
typeDescription
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser TypeName
typeDeclaration ByteString
"scalar"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (s :: Stage). Parse (Value s) => Parser (Directives s)
optionalDirectives
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (a :: TypeCategory) (s :: Stage).
ScalarDefinition -> TypeContent (LEAF <=? a) a s
DataScalar ((Value VALID -> Either Description (Value VALID))
-> ScalarDefinition
ScalarDefinition forall (f :: * -> *) a. Applicative f => a -> f a
pure))
{-# INLINEABLE scalarTypeDefinition #-}

-- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects
--
--  ObjectTypeDefinition:
--    Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt)
--
--  ImplementsInterfaces
--    implements &(opt) NamedType
--    ImplementsInterfaces & NamedType
--
--  FieldsDefinition
--    { FieldDefinition(list) }
--
--  FieldDefinition
--    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)
--
objectTypeDefinition ::
  Parse (Value s) =>
  Maybe Description ->
  Parser (TypeDefinition ANY s)
objectTypeDefinition :: forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
objectTypeDefinition Maybe Description
typeDescription =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"ObjectTypeDefinition" forall a b. (a -> b) -> a -> b
$
    forall (a :: TypeCategory) (s :: Stage).
(OBJECT <=! a) =>
Maybe Description
-> TypeName
-> [TypeName]
-> Directives s
-> FieldsDefinition OUT s
-> TypeDefinition a s
mkObject Maybe Description
typeDescription
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser TypeName
typeDeclaration ByteString
"type"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [TypeName]
optionalImplementsInterfaces
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (s :: Stage). Parse (Value s) => Parser (Directives s)
optionalDirectives
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (s :: Stage).
Parse (Value s) =>
Parser (FieldsDefinition OUT s)
fieldsDefinition
{-# INLINEABLE objectTypeDefinition #-}

optionalImplementsInterfaces :: Parser [TypeName]
optionalImplementsInterfaces :: Parser [TypeName]
optionalImplementsInterfaces = Parser [TypeName]
implements forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    implements :: Parser [TypeName]
implements =
      forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"ImplementsInterfaces" forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ()
keyword ByteString
"implements" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parser a -> Parser [a]
sepByAnd Parser TypeName
parseTypeName
{-# INLINEABLE optionalImplementsInterfaces #-}

-- Interfaces: https://graphql.github.io/graphql-spec/June2018/#sec-Interfaces
--
--  InterfaceTypeDefinition
--    Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt)
--
interfaceTypeDefinition ::
  Parse (Value s) =>
  Maybe Description ->
  Parser (TypeDefinition ANY s)
interfaceTypeDefinition :: forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
interfaceTypeDefinition Maybe Description
typeDescription =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"InterfaceTypeDefinition" forall a b. (a -> b) -> a -> b
$
    forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition Maybe Description
typeDescription
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser TypeName
typeDeclaration ByteString
"interface"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (s :: Stage). Parse (Value s) => Parser (Directives s)
optionalDirectives
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent (IMPLEMENTABLE <=? a) a s
DataInterface forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage).
Parse (Value s) =>
Parser (FieldsDefinition OUT s)
fieldsDefinition)
{-# INLINEABLE interfaceTypeDefinition #-}

-- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions
--
--  UnionTypeDefinition:
--    Description(opt) union Name Directives(Const)(opt) UnionMemberTypes(opt)
--
--  UnionMemberTypes:
--    = |(opt) NamedType
--      UnionMemberTypes | NamedType
--
unionTypeDefinition ::
  Parse (Value s) =>
  Maybe Description ->
  Parser (TypeDefinition ANY s)
unionTypeDefinition :: forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
unionTypeDefinition Maybe Description
typeDescription =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"UnionTypeDefinition" forall a b. (a -> b) -> a -> b
$
    forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition Maybe Description
typeDescription
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser TypeName
typeDeclaration ByteString
"union"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (s :: Stage). Parse (Value s) => Parser (Directives s)
optionalDirectives
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (s :: Stage) (a :: TypeCategory).
UnionTypeDefinition OUT s -> TypeContent (OUT <=? a) a s
DataUnion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  MyError ByteString GQLResult (OrdMap TypeName (UnionMember OUT s))
unionMemberTypes)
  where
    unionMemberTypes :: ParsecT
  MyError ByteString GQLResult (OrdMap TypeName (UnionMember OUT s))
unionMemberTypes =
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser ()
equal
          forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parser a -> Parser [a]
pipe (forall (cat :: TypeCategory) (s :: Stage).
TypeName -> UnionMember cat s
mkUnionMember forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TypeName
parseTypeName)
{-# INLINEABLE unionTypeDefinition #-}

-- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums
--
--  EnumTypeDefinition
--    Description(opt) enum Name Directives(Const)(opt) EnumValuesDefinition(opt)
--
--  EnumValuesDefinition
--    { EnumValueDefinition(list) }
--
--  EnumValueDefinition
--    Description(opt) EnumValue Directives(Const)(opt)
--
enumTypeDefinition ::
  Parse (Value s) =>
  Maybe Description ->
  Parser (TypeDefinition ANY s)
enumTypeDefinition :: forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
enumTypeDefinition Maybe Description
typeDescription =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"EnumTypeDefinition" forall a b. (a -> b) -> a -> b
$
    forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition Maybe Description
typeDescription
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser TypeName
typeDeclaration ByteString
"enum"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (s :: Stage). Parse (Value s) => Parser (Directives s)
optionalDirectives
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (LEAF <=? a) a s
DataEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser [a]
collection forall (s :: Stage). Parse (Value s) => Parser (DataEnumValue s)
enumValueDefinition)
{-# INLINEABLE enumTypeDefinition #-}

-- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects
--
--   InputObjectTypeDefinition
--     Description(opt) input Name  Directives(Const)(opt) InputFieldsDefinition(opt)
--
--   InputFieldsDefinition:
--     { InputValueDefinition(list) }
--
inputObjectTypeDefinition ::
  Parse (Value s) =>
  Maybe Description ->
  Parser (TypeDefinition ANY s)
inputObjectTypeDefinition :: forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
inputObjectTypeDefinition Maybe Description
typeDescription =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"InputObjectTypeDefinition" forall a b. (a -> b) -> a -> b
$
    forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
      Maybe Description
typeDescription
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser TypeName
typeDeclaration ByteString
"input"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (s :: Stage). Parse (Value s) => Parser (Directives s)
optionalDirectives
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> TypeContent (INPUT_OBJECT <=? a) a s
DataInputObject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage).
Parse (Value s) =>
Parser (InputFieldsDefinition s)
inputFieldsDefinition)
{-# INLINEABLE inputObjectTypeDefinition #-}

-- 3.13 DirectiveDefinition
--
--  DirectiveDefinition:
--     Description[opt] directive @ Name ArgumentsDefinition[opt] repeatable[opt] on DirectiveLocations
--
--  DirectiveLocations:
--    DirectiveLocations | DirectiveLocation
--    |[opt] DirectiveLocation
parseDirectiveDefinition ::
  Parse (Value s) =>
  Maybe Description ->
  Parser (DirectiveDefinition s)
parseDirectiveDefinition :: forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (DirectiveDefinition s)
parseDirectiveDefinition Maybe Description
directiveDefinitionDescription =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"DirectiveDefinition" forall a b. (a -> b) -> a -> b
$
    forall (s :: Stage).
FieldName
-> Maybe Description
-> ArgumentsDefinition s
-> [DirectiveLocation]
-> DirectiveDefinition s
DirectiveDefinition
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( ByteString -> Parser ()
keyword ByteString
"directive"
              forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
at
              forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (t :: NAME). Parser (Name t)
parseName
          )
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Description
directiveDefinitionDescription
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall c. Empty c => Parser c -> Parser c
optionalCollection forall (s :: Stage).
Parse (Value s) =>
Parser (ArgumentsDefinition s)
argumentsDefinition
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ByteString -> Parser ()
keyword ByteString
"repeatable") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Parser ()
keyword ByteString
"on" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parser a -> Parser [a]
pipe Parser DirectiveLocation
parseDirectiveLocation)
{-# INLINEABLE parseDirectiveDefinition #-}

-- 3.2 Schema
-- SchemaDefinition:
--    schema Directives[Const,opt]
--      { RootOperationTypeDefinition(list) }
--
--  RootOperationTypeDefinition:
--    OperationType: NamedType

-- data SchemaDefinition = SchemaDefinition
--   { query :: TypeName,
--     mutation :: Maybe TypeName,
--     subscription :: Maybe TypeName
--   }
parseSchemaDefinition :: Maybe Description -> Parser SchemaDefinition
parseSchemaDefinition :: Maybe Description -> Parser SchemaDefinition
parseSchemaDefinition Maybe Description
_schemaDescription =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"SchemaDefinition" forall a b. (a -> b) -> a -> b
$
    ByteString -> Parser ()
keyword ByteString
"schema"
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ( Directives CONST
-> OrdMap OperationType RootOperationTypeDefinition
-> SchemaDefinition
SchemaDefinition
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage). Parse (Value s) => Parser (Directives s)
optionalDirectives
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (map :: * -> * -> *) k a.
(FromList GQLResult map k a, KeyOf k a) =>
Parser a -> Parser (map k a)
setOf Parser RootOperationTypeDefinition
parseRootOperationTypeDefinition
         )
{-# INLINEABLE parseSchemaDefinition #-}

parseRootOperationTypeDefinition :: Parser RootOperationTypeDefinition
parseRootOperationTypeDefinition :: Parser RootOperationTypeDefinition
parseRootOperationTypeDefinition =
  OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT MyError ByteString GQLResult OperationType
parseOperationType forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
colon)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TypeName
parseTypeName
{-# INLINEABLE parseRootOperationTypeDefinition #-}

parseTypeSystemUnit ::
  Parser RawTypeDefinition
parseTypeSystemUnit :: Parser RawTypeDefinition
parseTypeSystemUnit =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"TypeDefinition" forall a b. (a -> b) -> a -> b
$
    do
      Maybe Description
description <- Parser (Maybe Description)
optDescription
      -- scalar | enum |  input | object | union | interface
      Maybe Description -> Parser RawTypeDefinition
parseTypeDef Maybe Description
description
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SchemaDefinition -> RawTypeDefinition
RawSchemaDefinition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Description -> Parser SchemaDefinition
parseSchemaDefinition Maybe Description
description
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DirectiveDefinition CONST -> RawTypeDefinition
RawDirectiveDefinition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (DirectiveDefinition s)
parseDirectiveDefinition Maybe Description
description
  where
    parseTypeDef :: Maybe Description -> Parser RawTypeDefinition
parseTypeDef Maybe Description
description =
      TypeDefinition ANY CONST -> RawTypeDefinition
RawTypeDefinition
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
objectTypeDefinition Maybe Description
description
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
inputObjectTypeDefinition Maybe Description
description
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
interfaceTypeDefinition Maybe Description
description
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
unionTypeDefinition Maybe Description
description
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
enumTypeDefinition Maybe Description
description
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (s :: Stage).
Parse (Value s) =>
Maybe Description -> Parser (TypeDefinition ANY s)
scalarTypeDefinition Maybe Description
description
            )
{-# INLINEABLE parseTypeSystemUnit #-}

typePartition ::
  [RawTypeDefinition] ->
  ( [SchemaDefinition],
    [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST]
  )
typePartition :: [RawTypeDefinition]
-> ([SchemaDefinition], [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST])
typePartition = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' RawTypeDefinition
-> ([SchemaDefinition], [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST])
-> ([SchemaDefinition], [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST])
split ([], [], [])

split ::
  RawTypeDefinition ->
  ( [SchemaDefinition],
    [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST]
  ) ->
  ( [SchemaDefinition],
    [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST]
  )
split :: RawTypeDefinition
-> ([SchemaDefinition], [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST])
-> ([SchemaDefinition], [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST])
split (RawSchemaDefinition SchemaDefinition
schema) ([SchemaDefinition]
schemas, [TypeDefinition ANY CONST]
types, [DirectiveDefinition CONST]
dirs) = (SchemaDefinition
schema forall a. a -> [a] -> [a]
: [SchemaDefinition]
schemas, [TypeDefinition ANY CONST]
types, [DirectiveDefinition CONST]
dirs)
split (RawTypeDefinition TypeDefinition ANY CONST
ty) ([SchemaDefinition]
schemas, [TypeDefinition ANY CONST]
types, [DirectiveDefinition CONST]
dirs) = ([SchemaDefinition]
schemas, TypeDefinition ANY CONST
ty forall a. a -> [a] -> [a]
: [TypeDefinition ANY CONST]
types, [DirectiveDefinition CONST]
dirs)
split (RawDirectiveDefinition DirectiveDefinition CONST
dir) ([SchemaDefinition]
schemas, [TypeDefinition ANY CONST]
types, [DirectiveDefinition CONST]
dirs) = ([SchemaDefinition]
schemas, [TypeDefinition ANY CONST]
types, DirectiveDefinition CONST
dir forall a. a -> [a] -> [a]
: [DirectiveDefinition CONST]
dirs)

--  split (RawDirectiveDefinition d)

withSchemaDefinition ::
  ( [SchemaDefinition],
    [TypeDefinition ANY s],
    [DirectiveDefinition CONST]
  ) ->
  GQLResult (Maybe SchemaDefinition, [TypeDefinition ANY s], DirectivesDefinition CONST)
withSchemaDefinition :: forall (s :: Stage).
([SchemaDefinition], [TypeDefinition ANY s],
 [DirectiveDefinition CONST])
-> GQLResult
     (Maybe SchemaDefinition, [TypeDefinition ANY s],
      DirectivesDefinition CONST)
withSchemaDefinition ([], [TypeDefinition ANY s]
t, [DirectiveDefinition CONST]
dirs) = (forall a. Maybe a
Nothing,[TypeDefinition ANY s]
t,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems [DirectiveDefinition CONST]
dirs
withSchemaDefinition ([SchemaDefinition
x], [TypeDefinition ANY s]
t, [DirectiveDefinition CONST]
dirs) = (forall a. a -> Maybe a
Just SchemaDefinition
x,[TypeDefinition ANY s]
t,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems [DirectiveDefinition CONST]
dirs
withSchemaDefinition (SchemaDefinition
x : [SchemaDefinition]
xs, [TypeDefinition ANY s]
_, [DirectiveDefinition CONST]
_) = forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b
throwErrors (forall e a. NameCollision e a => a -> e
nameCollision forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SchemaDefinition
x forall a. a -> [a] -> NonEmpty a
:| [SchemaDefinition]
xs))

parseRawTypeDefinitions :: Parser [RawTypeDefinition]
parseRawTypeDefinitions :: Parser [RawTypeDefinition]
parseRawTypeDefinitions =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"TypeSystemDefinitions" forall a b. (a -> b) -> a -> b
$
    Parser ()
ignoredTokens
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill Parser RawTypeDefinition
parseTypeSystemUnit forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

typeSystemDefinition ::
  ByteString ->
  GQLResult
    ( Maybe SchemaDefinition,
      [TypeDefinition ANY CONST],
      DirectivesDefinition CONST
    )
typeSystemDefinition :: ByteString
-> GQLResult
     (Maybe SchemaDefinition, [TypeDefinition ANY CONST],
      DirectivesDefinition CONST)
typeSystemDefinition =
  forall a. Parser a -> ByteString -> GQLResult a
processParser Parser [RawTypeDefinition]
parseRawTypeDefinitions
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (s :: Stage).
([SchemaDefinition], [TypeDefinition ANY s],
 [DirectiveDefinition CONST])
-> GQLResult
     (Maybe SchemaDefinition, [TypeDefinition ANY s],
      DirectivesDefinition CONST)
withSchemaDefinition forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RawTypeDefinition]
-> ([SchemaDefinition], [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST])
typePartition

parseDefinitions :: ByteString -> GQLResult [RawTypeDefinition]
parseDefinitions :: ByteString -> GQLResult [RawTypeDefinition]
parseDefinitions = forall a. Parser a -> ByteString -> GQLResult a
processParser Parser [RawTypeDefinition]
parseRawTypeDefinitions

parseTypeDefinitions :: ByteString -> GQLResult [TypeDefinition ANY CONST]
parseTypeDefinitions :: ByteString -> GQLResult [TypeDefinition ANY CONST]
parseTypeDefinitions = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[RawTypeDefinition]
d -> [TypeDefinition ANY CONST
td | RawTypeDefinition TypeDefinition ANY CONST
td <- [RawTypeDefinition]
d]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> GQLResult [RawTypeDefinition]
parseDefinitions

parseSchema :: ByteString -> GQLResult (Schema CONST)
parseSchema :: ByteString -> GQLResult (Schema CONST)
parseSchema = ByteString
-> GQLResult
     (Maybe SchemaDefinition, [TypeDefinition ANY CONST],
      DirectivesDefinition CONST)
typeSystemDefinition forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) (s :: Stage).
(Monad m, MonadError GQLError m) =>
(Maybe SchemaDefinition, [TypeDefinition ANY s],
 DirectivesDefinition s)
-> m (Schema s)
buildSchema