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

module Data.Morpheus.Parsing.Document.TypeSystem
  ( parseSchemaWithoutValidation,
    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 typeDescription typeName objectImplements typeDirectives objectFields =
  TypeDefinition
    { typeContent = DataObject {objectImplements, objectFields},
      ..
    }
{-# 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 typeDescription =
  label "ScalarTypeDefinition"
    $ TypeDefinition typeDescription
    <$> typeDeclaration "scalar"
    <*> optionalDirectives
    <*> pure (DataScalar (ScalarDefinition 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 typeDescription =
  label "ObjectTypeDefinition"
    $ mkObject typeDescription
    <$> typeDeclaration "type"
    <*> optionalImplementsInterfaces
    <*> optionalDirectives
    <*> fieldsDefinition
{-# INLINEABLE objectTypeDefinition #-}

optionalImplementsInterfaces :: Parser [TypeName]
optionalImplementsInterfaces = implements <|> pure []
  where
    implements =
      label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd 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 typeDescription =
  label "InterfaceTypeDefinition"
    $ TypeDefinition typeDescription
    <$> typeDeclaration "interface"
    <*> optionalDirectives
    <*> (DataInterface <$> 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 typeDescription =
  label "UnionTypeDefinition"
    $ TypeDefinition typeDescription
    <$> typeDeclaration "union"
    <*> optionalDirectives
    <*> (DataUnion <$> unionMemberTypes)
  where
    unionMemberTypes =
      lift
        . fromElems
        =<< equal
        *> pipe (mkUnionMember <$> 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 typeDescription =
  label "EnumTypeDefinition"
    $ TypeDefinition typeDescription
    <$> typeDeclaration "enum"
    <*> optionalDirectives
    <*> (DataEnum <$> collection 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 typeDescription =
  label "InputObjectTypeDefinition"
    $ TypeDefinition
      typeDescription
    <$> typeDeclaration "input"
    <*> optionalDirectives
    <*> (DataInputObject <$> 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 directiveDefinitionDescription =
  label "DirectiveDefinition"
    $ DirectiveDefinition
    <$> ( keyword "directive"
            *> at
            *> parseName
        )
    <*> pure directiveDefinitionDescription
    <*> optionalCollection argumentsDefinition
    <*> (optional (keyword "repeatable") *> keyword "on" *> pipe 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 _schemaDescription =
  label "SchemaDefinition"
    $ keyword "schema"
    *> ( SchemaDefinition
           <$> optionalDirectives
           <*> setOf parseRootOperationTypeDefinition
       )
{-# INLINEABLE parseSchemaDefinition #-}

parseRootOperationTypeDefinition :: Parser RootOperationTypeDefinition
parseRootOperationTypeDefinition =
  RootOperationTypeDefinition
    <$> (parseOperationType <* colon)
    <*> parseTypeName
{-# INLINEABLE parseRootOperationTypeDefinition #-}

parseTypeSystemUnit ::
  Parser RawTypeDefinition
parseTypeSystemUnit =
  label "TypeDefinition"
    $ do
      description <- optDescription
      -- scalar | enum |  input | object | union | interface
      parseTypeDef description
        <|> RawSchemaDefinition
        <$> parseSchemaDefinition description
        <|> RawDirectiveDefinition
        <$> parseDirectiveDefinition description
  where
    parseTypeDef description =
      RawTypeDefinition
        <$> ( objectTypeDefinition description
                <|> inputObjectTypeDefinition description
                <|> interfaceTypeDefinition description
                <|> unionTypeDefinition description
                <|> enumTypeDefinition description
                <|> scalarTypeDefinition description
            )
{-# INLINEABLE parseTypeSystemUnit #-}

typePartition ::
  [RawTypeDefinition] ->
  ( [SchemaDefinition],
    [TypeDefinition ANY CONST],
    [DirectiveDefinition CONST]
  )
typePartition = foldr' split ([], [], [])

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

--  split (RawDirectiveDefinition d)

withSchemaDefinition ::
  ( [SchemaDefinition],
    [TypeDefinition ANY s],
    [DirectiveDefinition CONST]
  ) ->
  GQLResult (Maybe SchemaDefinition, [TypeDefinition ANY s], DirectivesDefinition CONST)
withSchemaDefinition ([], t, dirs) = (Nothing,t,) <$> fromElems dirs
withSchemaDefinition ([x], t, dirs) = (Just x,t,) <$> fromElems dirs
withSchemaDefinition (x : xs, _, _) = throwErrors (nameCollision <$> (x :| xs))

parseRawTypeDefinitions :: Parser [RawTypeDefinition]
parseRawTypeDefinitions =
  label "TypeSystemDefinitions"
    $ ignoredTokens
    *> manyTill parseTypeSystemUnit eof

typeSystemDefinition ::
  ByteString ->
  GQLResult
    ( Maybe SchemaDefinition,
      [TypeDefinition ANY CONST],
      DirectivesDefinition CONST
    )
typeSystemDefinition =
  processParser parseRawTypeDefinitions
    >=> withSchemaDefinition
    . typePartition

parseDefinitions :: ByteString -> GQLResult [RawTypeDefinition]
parseDefinitions = processParser parseRawTypeDefinitions

parseTypeDefinitions :: ByteString -> GQLResult [TypeDefinition ANY CONST]
parseTypeDefinitions = fmap (\d -> [td | RawTypeDefinition td <- d]) . parseDefinitions

parseSchemaWithoutValidation :: ByteString -> GQLResult (Schema CONST)
parseSchemaWithoutValidation = typeSystemDefinition >=> buildSchema
