content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  
  module Data.Morpheus.Client.Schema.JSON.Parse
    ( decodeIntrospection,
    )
  where
  
  import Control.Monad.Except (MonadError (throwError))
  import Data.Aeson
  import Data.ByteString.Lazy (ByteString)
  import Data.Morpheus.Client.Schema.JSON.TypeKind (TypeKind (..))
  import qualified Data.Morpheus.Client.Schema.JSON.TypeRef as Ref
  import Data.Morpheus.Client.Schema.JSON.Types
    ( EnumValue (..),
      Field (..),
      InputValue (..),
      Introspection (..),
      JSONResponse (..),
      Schema (..),
      Type (..),
    )
  import Data.Morpheus.Core
    ( defaultConfig,
      validateSchema,
    )
  import Data.Morpheus.Internal.Ext
    ( GQLResult,
    )
  import Data.Morpheus.Internal.Utils
    ( empty,
      fromElems,
    )
  import Data.Morpheus.Types.Internal.AST
    ( ANY,
      ArgumentDefinition (..),
      CONST,
      FieldDefinition,
      GQLError,
      IN,
      OUT,
      OperationType (..),
      RootOperationTypeDefinition (..),
      SchemaDefinition (..),
      TypeContent (..),
      TypeDefinition (..),
      TypeRef (..),
      TypeWrapper (..),
      VALID,
      buildSchema,
      createScalarType,
      mkEnumContent,
      mkField,
      mkMaybeType,
      mkObjectField,
      mkType,
      mkUnionContent,
      msg,
      toAny,
    )
  import qualified Data.Morpheus.Types.Internal.AST as AST
    ( Schema,
    )
  import Relude hiding
    ( ByteString,
      Type,
      empty,
      fromList,
      show,
    )
  import Prelude (show)
  
  decoderError :: GQLError -> GQLResult a
  decoderError = throwError
  
  decodeIntrospection :: ByteString -> GQLResult (AST.Schema VALID)
  decodeIntrospection jsonDoc = case jsonSchema of
    Left errors -> decoderError $ msg errors
    Right
      JSONResponse
        { responseData =
            Just
              Introspection
                { __schema =
                    schema@Schema {types}
                }
        } -> do
        schemaDef <- mkSchemaDef schema
        gqlTypes <- concat <$> traverse parse types
        buildSchema (Just schemaDef, gqlTypes, empty) >>= validate
    Right res -> decoderError (msg $ show res)
    where
      validate :: AST.Schema CONST -> GQLResult (AST.Schema VALID)
      validate = validateSchema False defaultConfig
      jsonSchema :: Either String (JSONResponse Introspection)
      jsonSchema = eitherDecode jsonDoc
  
  mkSchemaDef ::
    (Monad m, MonadError GQLError m) =>
    Schema ->
    m SchemaDefinition
  mkSchemaDef
    Schema
      { queryType,
        mutationType,
        subscriptionType
      } =
      SchemaDefinition empty
        <$> fromElems
          ( catMaybes
              [ Just (RootOperationTypeDefinition OPERATION_QUERY $ Ref.name queryType),
                RootOperationTypeDefinition OPERATION_MUTATION . Ref.name <$> mutationType,
                RootOperationTypeDefinition OPERATION_SUBSCRIPTION . Ref.name <$> subscriptionType
              ]
          )
  
  class ParseJSONSchema a b where
    parse :: a -> GQLResult b
  
  instance ParseJSONSchema Type [TypeDefinition ANY CONST] where
    parse Type {name = Just typeName, kind = SCALAR} =
      pure [createScalarType typeName]
    parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} =
      pure [mkType typeName $ mkEnumContent (fmap enumName enums)]
    parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} =
      case traverse name unions of
        Nothing -> decoderError "ERROR: GQL ERROR"
        Just uni -> pure [toAny $ mkType typeName $ mkUnionContent uni]
    parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} =
      do
        (fields :: [FieldDefinition IN CONST]) <- traverse parse iFields
        fs <- fromElems fields
        pure [mkType typeName $ DataInputObject fs]
    parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} =
      do
        (fields :: [FieldDefinition OUT CONST]) <- traverse parse oFields
        fs <- fromElems fields
        pure [mkType typeName $ DataObject [] fs]
    parse _ = pure []
  
  instance ParseJSONSchema Field (FieldDefinition OUT CONST) where
    parse Field {fieldName, fieldArgs, fieldType} = do
      TypeRef typename wrappers <- fieldTypeFromJSON fieldType
      args <- traverse genArg fieldArgs >>= fromElems
      pure $ mkObjectField args fieldName wrappers typename
      where
        genArg InputValue {inputName = argName, inputType = argType} =
          ArgumentDefinition . mkField Nothing argName <$> fieldTypeFromJSON argType
  
  instance ParseJSONSchema InputValue (FieldDefinition IN CONST) where
    parse InputValue {inputName, inputType} = mkField Nothing inputName <$> fieldTypeFromJSON inputType
  
  fieldTypeFromJSON :: Type -> GQLResult TypeRef
  fieldTypeFromJSON Type {kind = NON_NULL, ofType = Just ofType} = withListNonNull <$> fieldTypeFromJSON ofType
  fieldTypeFromJSON Type {kind = LIST, ofType = Just ofType} = withList <$> fieldTypeFromJSON ofType
  fieldTypeFromJSON Type {name = Just name} = pure (TypeRef name mkMaybeType)
  fieldTypeFromJSON x = decoderError $ "Unsupported Field" <> msg (show x)
  
  withList :: TypeRef -> TypeRef
  withList (TypeRef name x) = TypeRef name (TypeList x False)
  
  withListNonNull :: TypeRef -> TypeRef
  withListNonNull (TypeRef name (TypeList y _)) = TypeRef name (TypeList y True)
  withListNonNull (TypeRef name (BaseType _)) = TypeRef name (BaseType True)
  