{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}

module Data.Morpheus.Rendering.RenderIntrospection
  ( render,
    createObjectType,
  )
where

import Data.Maybe (isJust)
-- Morpheus

import Data.Morpheus.Internal.Utils
  ( Failure,
    elems,
    failure,
    fromElems,
    selectBy,
    selectOr,
  )
import qualified Data.Morpheus.Rendering.RenderGQL as GQL (RenderGQL (..))
import Data.Morpheus.Schema.TypeKind (TypeKind (..))
import qualified Data.Morpheus.Types.Internal.AST as AST (TypeKind (..))
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    ArgumentsDefinition (..),
    DataEnumValue (..),
    DataTypeWrapper (..),
    Description,
    DirectiveDefinition (..),
    DirectiveLocation,
    Directives,
    FieldContent (..),
    FieldDefinition (..),
    FieldName (..),
    FieldsDefinition,
    GQLErrors,
    IN,
    Message,
    OUT,
    Object,
    ObjectEntry (..),
    QUERY,
    RESOLVED,
    Schema,
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeName (..),
    TypeRef (..),
    UnionMember (..),
    VALID,
    Value (..),
    createInputUnionFields,
    fieldVisibility,
    kindOf,
    lookupDeprecated,
    lookupDeprecatedReason,
    msg,
    toGQLWrapper,
  )
import Data.Morpheus.Types.Internal.Resolving
  ( Context (..),
    ResModel,
    Resolver,
    mkBoolean,
    mkList,
    mkNull,
    mkObject,
    mkString,
    unsafeInternalContext,
  )
import Data.Semigroup ((<>))
import Data.Text (pack)

type Result e m a = Resolver QUERY e m a

class
  ( Monad m,
    Failure Message m,
    Failure GQLErrors m
  ) =>
  WithSchema m
  where
  getSchema :: m Schema

instance Monad m => WithSchema (Resolver QUERY e m) where
  getSchema = schema <$> unsafeInternalContext

selectType ::
  WithSchema m =>
  TypeName ->
  m (TypeDefinition ANY)
selectType name =
  getSchema
    >>= selectBy (" INTERNAL: INTROSPECTION Type not Found: \"" <> msg name <> "\"") name

class RenderIntrospection a where
  render ::
    (Monad m) =>
    a ->
    Resolver QUERY e m (ResModel QUERY e m)

instance RenderIntrospection TypeName where
  render = pure . mkString . readTypeName

instance RenderIntrospection FieldName where
  render = pure . mkString . readName

instance RenderIntrospection Description where
  render = pure . mkString

instance RenderIntrospection TypeKind where
  render = pure . mkString . pack . show

instance RenderIntrospection a => RenderIntrospection [a] where
  render ls = mkList <$> traverse render ls

instance RenderIntrospection DirectiveDefinition where
  render
    DirectiveDefinition
      { directiveDefinitionName,
        directiveDefinitionDescription,
        directiveDefinitionLocations,
        directiveDefinitionArgs
      } =
      pure $
        mkObject
          "__Directive"
          [ renderName directiveDefinitionName,
            description directiveDefinitionDescription,
            ("locations", render directiveDefinitionLocations),
            ("args", render directiveDefinitionArgs)
          ]

instance RenderIntrospection DirectiveLocation where
  render locations = pure $ mkString (pack $ show locations)

instance RenderIntrospection (TypeDefinition a) where
  render
    TypeDefinition
      { typeName,
        typeDescription,
        typeContent
      } = pure $ renderContent typeContent
      where
        __type :: Monad m => TypeKind -> [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] -> ResModel QUERY e m
        __type kind = mkType kind typeName typeDescription
        renderContent :: Monad m => TypeContent bool a -> ResModel QUERY e m
        renderContent DataScalar {} = __type SCALAR []
        renderContent (DataEnum enums) = __type ENUM [("enumValues", render enums)]
        renderContent (DataInputObject inputFiels) =
          __type
            INPUT_OBJECT
            [("inputFields", render inputFiels)]
        renderContent DataObject {objectImplements, objectFields} =
          createObjectType typeName typeDescription objectImplements objectFields
        renderContent (DataUnion union) =
          __type
            UNION
            [("possibleTypes", render union)]
        renderContent (DataInputUnion members) =
          __type
            INPUT_OBJECT
            [ ( "inputFields",
                render
                  $ createInputUnionFields typeName
                  $ filter visibility members
              )
            ]
        renderContent (DataInterface fields) =
          __type
            INTERFACE
            [ ("fields", render fields),
              ("possibleTypes", interfacePossibleTypes typeName)
            ]

instance RenderIntrospection (UnionMember OUT) where
  render UnionMember {memberName} = selectType memberName >>= render

instance RenderIntrospection (FieldDefinition cat) => RenderIntrospection (FieldsDefinition cat) where
  render = render . filter fieldVisibility . elems

instance RenderIntrospection (FieldDefinition OUT) where
  render FieldDefinition {..} =
    pure
      $ mkObject "__Field"
      $ [ renderName fieldName,
          description fieldDescription,
          type' fieldType,
          ("args", maybe (pure $ mkList []) render fieldContent)
        ]
        <> renderDeprecated fieldDirectives

instance RenderIntrospection (FieldContent TRUE OUT) where
  render (FieldArgs args) = render args

instance RenderIntrospection ArgumentsDefinition where
  render ArgumentsDefinition {arguments} = mkList <$> traverse render (elems arguments)

instance RenderIntrospection (FieldDefinition IN) where
  render FieldDefinition {..} =
    pure $
      mkObject
        "__InputValue"
        [ renderName fieldName,
          description fieldDescription,
          type' fieldType,
          defaultValue fieldType (fmap defaultInputValue fieldContent)
        ]

instance RenderIntrospection DataEnumValue where
  render DataEnumValue {enumName, enumDescription, enumDirectives} =
    pure $ mkObject "__Field" $
      [ renderName enumName,
        description enumDescription
      ]
        <> renderDeprecated enumDirectives

instance RenderIntrospection TypeRef where
  render TypeRef {typeConName, typeWrappers} = do
    kind <- lookupKind typeConName
    let currentType = mkType kind typeConName Nothing []
    pure $ foldr wrap currentType (toGQLWrapper typeWrappers)
    where
      wrap :: Monad m => DataTypeWrapper -> ResModel QUERY e m -> ResModel QUERY e m
      wrap wrapper contentType =
        mkObject
          "__Type"
          [ renderKind (wrapperKind wrapper),
            ("ofType", pure contentType)
          ]
      wrapperKind ListType = LIST
      wrapperKind NonNullType = NON_NULL

interfacePossibleTypes ::
  (Monad m) =>
  TypeName ->
  Resolver QUERY e m (ResModel QUERY e m)
interfacePossibleTypes interfaceName =
  mkList
    <$> ( getSchema
            >>= sequence
              . concatMap implements
              . elems
        )
  where
    implements typeDef@TypeDefinition {typeContent = DataObject {objectImplements}, ..}
      | interfaceName `elem` objectImplements = [render typeDef]
    implements _ = []

renderDeprecated ::
  (Monad m) =>
  Directives VALID ->
  [(FieldName, Resolver QUERY e m (ResModel QUERY e m))]
renderDeprecated dirs =
  [ ("isDeprecated", pure $ mkBoolean (isJust $ lookupDeprecated dirs)),
    ("deprecationReason", opt (pure . mkString) (lookupDeprecated dirs >>= lookupDeprecatedReason))
  ]

description :: Monad m => Maybe Description -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))
description desc = ("description", opt render desc)

lookupKind :: (Monad m) => TypeName -> Result e m TypeKind
lookupKind = fmap (renderTypeKind . kindOf) . selectType

renderTypeKind :: AST.TypeKind -> TypeKind
renderTypeKind AST.KindScalar = SCALAR
renderTypeKind (AST.KindObject _) = OBJECT
renderTypeKind AST.KindUnion = UNION
renderTypeKind AST.KindInputUnion = INPUT_OBJECT
renderTypeKind AST.KindEnum = ENUM
renderTypeKind AST.KindInputObject = INPUT_OBJECT
renderTypeKind AST.KindList = LIST
renderTypeKind AST.KindNonNull = NON_NULL
renderTypeKind AST.KindInterface = INTERFACE

mkType ::
  (Monad m, RenderIntrospection name) =>
  TypeKind ->
  name ->
  Maybe Description ->
  [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] ->
  ResModel QUERY e m
mkType kind name desc etc =
  mkObject
    "__Type"
    ( [ renderKind kind,
        renderName name,
        description desc
      ]
        <> etc
    )

createObjectType ::
  Monad m => TypeName -> Maybe Description -> [TypeName] -> FieldsDefinition OUT -> ResModel QUERY e m
createObjectType name desc interfaces fields =
  mkType OBJECT name desc [("fields", render fields), ("interfaces", mkList <$> traverse implementedInterface interfaces)]

implementedInterface ::
  (Monad m) =>
  TypeName ->
  Resolver QUERY e m (ResModel QUERY e m)
implementedInterface name =
  selectType name
    >>= renderContent
  where
    renderContent typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef
    renderContent _ = failure ("Type " <> msg name <> " must be an Interface" :: Message)

opt :: Monad m => (a -> Resolver QUERY e m (ResModel QUERY e m)) -> Maybe a -> Resolver QUERY e m (ResModel QUERY e m)
opt f (Just x) = f x
opt _ Nothing = pure mkNull

renderName ::
  ( RenderIntrospection name,
    Monad m
  ) =>
  name ->
  (FieldName, Resolver QUERY e m (ResModel QUERY e m))
renderName = ("name",) . render

renderKind :: Monad m => TypeKind -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))
renderKind = ("kind",) . render

type' :: Monad m => TypeRef -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))
type' ref = ("type", render ref)

defaultValue ::
  Monad m =>
  TypeRef ->
  Maybe (Value RESOLVED) ->
  ( FieldName,
    Resolver QUERY e m (ResModel QUERY e m)
  )
defaultValue
  typeRef
  value =
    ( "defaultValue",
      opt
        ( fmap
            (mkString . GQL.render)
            . fulfill typeRef
            . Just
        )
        value
    )

fulfill ::
  WithSchema m =>
  TypeRef ->
  Maybe (Value RESOLVED) ->
  m (Value RESOLVED)
fulfill TypeRef {typeConName} (Just (Object fields)) =
  selectType typeConName
    >>= \case
      TypeDefinition
        { typeContent =
            DataInputObject {inputObjectFields}
        } ->
          Object
            <$> ( traverse
                    (handleField fields)
                    (elems inputObjectFields)
                    >>= fromElems
                )
      _ -> failure (msg typeConName <> "is not must be Object")
fulfill typeRef (Just (List values)) =
  List <$> traverse (fulfill typeRef . Just) values
fulfill _ (Just v) = pure v
fulfill _ Nothing = pure Null

handleField ::
  WithSchema m =>
  Object RESOLVED ->
  FieldDefinition IN ->
  m (ObjectEntry RESOLVED)
handleField
  fields
  FieldDefinition
    { fieldName,
      fieldType,
      fieldContent = x
    } =
    ObjectEntry fieldName
      <$> fulfill
        fieldType
        ( selectOr
            (fmap defaultInputValue x)
            (Just . entryValue)
            fieldName
            fields
        )