content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DefaultSignatures #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  
  module Data.Morpheus.Server.Types.GQLType
    ( GQLType (..),
      GQLValue (..),
      InputTypeNamespace (..),
      GQLResolver (..),
      ignoreUndefined,
      withGQL,
      withDir,
      withValue,
      withRes,
      kindedProxy,
      IgnoredResolver,
      enumDirective,
      enumDirective',
      fieldDirective,
      fieldDirective',
      typeDirective,
    )
  where
  
  -- MORPHEUS
  
  {- ORMOLU_DISABLE -}
  import qualified Data.HashMap.Strict as M
  import qualified Language.Haskell.TH as TH
  {- ORMOLU_ENABLE -}
  
  import Control.Monad.Except (MonadError (throwError))
  import Data.Morpheus.App.Internal.Resolving
    ( MonadResolver,
      Resolver,
      ResolverState,
      ResolverValue,
      SubscriptionField,
    )
  import Data.Morpheus.Generic
    ( Gmap,
      symbolName,
    )
  import Data.Morpheus.Internal.Ext (GQLResult)
  import Data.Morpheus.Internal.Utils (empty, singleton)
  import Data.Morpheus.Server.Deriving.Internal.Type
    ( deriveInterfaceDefinition,
      toTypeDefinition,
    )
  import Data.Morpheus.Server.Deriving.Kinded.Arguments
    ( DeriveFieldArguments (..),
      HasArguments,
    )
  import Data.Morpheus.Server.Deriving.Kinded.Resolver (KindedResolver (..))
  import Data.Morpheus.Server.Deriving.Kinded.Type
    ( DERIVE_TYPE,
      DeriveKindedType (..),
      deriveScalarDefinition,
      deriveTypeGuardUnions,
      scanNode,
    )
  import Data.Morpheus.Server.Deriving.Kinded.Value (KindedValue (..))
  import Data.Morpheus.Server.Deriving.Utils.GScan
    ( FreeCatType,
      ScanRef,
      freeLeaf,
    )
  import Data.Morpheus.Server.Deriving.Utils.Kinded
    ( CatType (..),
      Kinded (..),
      inputType,
      isIN,
      mapCat,
    )
  import Data.Morpheus.Server.Deriving.Utils.Types (GQLTypeNode (..), GQLTypeNodeExtension (..))
  import Data.Morpheus.Server.Deriving.Utils.Use
    ( GQLTypeCTX (..),
      GQLValueCTX (..),
      UseDeriving (..),
      UseGQLType (..),
      UseResolver (..),
    )
  import Data.Morpheus.Server.Types.Directives
    ( GDirectiveUsage (..),
      GDirectiveUsages (..),
      GQLDirective (..),
      allUsages,
      applyTypeName,
    )
  import Data.Morpheus.Server.Types.Internal
    ( TypeData (..),
      mkTypeData,
    )
  import Data.Morpheus.Server.Types.Kind
    ( CUSTOM,
      DIRECTIVE,
      DerivingKind,
      SCALAR,
      TYPE,
      WRAPPER,
    )
  import Data.Morpheus.Server.Types.NamedResolvers (NamedResolverT (..))
  import Data.Morpheus.Server.Types.TypeName
    ( TypeFingerprint (..),
      typeableFingerprint,
      typeableTypename,
    )
  import Data.Morpheus.Server.Types.Types
    ( Arg,
      Pair,
      TypeGuard,
      Undefined (..),
      __typenameUndefined,
    )
  import Data.Morpheus.Server.Types.Visitors (VisitType (..))
  import Data.Morpheus.Types.ID (ID)
  import Data.Morpheus.Types.Internal.AST
    ( ArgumentsDefinition,
      CONST,
      DirectiveLocation (..),
      FieldDefinition,
      FieldName,
      GQLError,
      IN,
      Msg (msg),
      OUT,
      QUERY,
      ScalarDefinition (..),
      TRUE,
      TypeContent (..),
      TypeName,
      TypeRef (..),
      TypeWrapper (..),
      VALID,
      Value (..),
      internal,
      mkBaseType,
      mkField,
      packName,
      toNullable,
      unitTypeName,
    )
  import Data.Sequence (Seq)
  import Data.Vector (Vector)
  import GHC.Generics
  import GHC.TypeLits (KnownSymbol)
  import Relude hiding (Seq, Undefined, empty, fromList, intercalate)
  
  ignoreUndefined :: forall f a. (GQLType a) => f a -> Maybe (f a)
  ignoreUndefined proxy
    | gqlFingerprint (__type (OutputType :: CatType OUT a)) == InternalFingerprint __typenameUndefined = Nothing
    | otherwise = Just proxy
  
  deriveTypeData ::
    forall c (a :: Type).
    (Typeable a) =>
    CatType c a ->
    DirectiveUsages ->
    TypeData
  deriveTypeData proxy GDirectiveUsages {typeDirectives} =
    TypeData
      { gqlTypeName = foldr (`applyTypeName` isIN proxy) (typeableTypename (Proxy @a)) typeDirectives,
        gqlWrappers = mkBaseType,
        gqlFingerprint = typeableFingerprint proxy
      }
  
  list :: TypeWrapper -> TypeWrapper
  list = flip TypeList True
  
  wrapper :: (TypeWrapper -> TypeWrapper) -> TypeData -> TypeData
  wrapper f TypeData {..} = TypeData {gqlWrappers = f gqlWrappers, ..}
  
  type Lifted a = (PARAM (KIND a) a)
  
  kindedProxy :: f a -> Proxy (f' (KIND a) a)
  kindedProxy _ = Proxy
  
  kindedCatType :: CatType cat a -> CatType cat (f (KIND a) (Lifted a))
  kindedCatType InputType = InputType
  kindedCatType OutputType = OutputType
  
  type IgnoredResolver = (Resolver QUERY () Identity)
  
  -- lifts monadic object types with specific monad
  type family PARAM k a where
    PARAM TYPE (t m) = t IgnoredResolver
    PARAM k a = a
  
  type DERIVE_T a = (DeriveKindedType WITH_DERIVING (KIND a) (Lifted a))
  
  cantBeInputType :: (MonadError GQLError m, GQLType a) => CatType cat a -> m b
  cantBeInputType proxy = throwError $ internal $ "type " <> msg (gqlTypeName $ __type proxy) <> "can't be a input type"
  
  -- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'.
  --
  --  @
  --    ... deriving (Generic, GQLType)
  --  @
  --
  -- if you want to add description
  --
  --  @
  --       ... deriving (Generic)
  --
  --     instance GQLType ... where
  --        directives _ = typeDirective (Describe "some text")
  --  @
  class GQLType a where
    type KIND a :: DerivingKind
    type KIND a = TYPE
  
    directives :: f a -> DirectiveUsages
    directives _ = mempty
  
    __type :: CatType cat a -> TypeData
    default __type :: (Typeable a) => CatType cat a -> TypeData
    __type proxy = deriveTypeData proxy (directives proxy)
  
    __deriveType :: CatType c a -> GQLResult (GQLTypeNode c)
    default __deriveType :: (DERIVE_T a) => CatType c a -> GQLResult (GQLTypeNode c)
    __deriveType = deriveKindedType withDir . kindedCatType
  
    __exploreRef :: CatType c a -> [ScanRef FreeCatType GQLType]
    default __exploreRef :: (DERIVE_T a) => CatType c a -> [ScanRef FreeCatType GQLType]
    __exploreRef = exploreKindedRefs withDir . kindedCatType
  
    __deriveFieldArguments :: CatType c a -> GQLResult (ArgumentsDefinition CONST)
    default __deriveFieldArguments :: (DeriveFieldArguments WITH_GQL (HasArguments a)) => CatType c a -> GQLResult (ArgumentsDefinition CONST)
    __deriveFieldArguments OutputType = deriveFieldArguments withGQL (Proxy @(HasArguments a))
    __deriveFieldArguments InputType = pure empty
  
  instance GQLType Int where
    type KIND Int = SCALAR
    __type = mkTypeData "Int"
  
  instance GQLType Double where
    type KIND Double = SCALAR
    __type = mkTypeData "Float"
  
  instance GQLType Float where
    type KIND Float = SCALAR
    __type = mkTypeData "Float32"
  
  instance GQLType Text where
    type KIND Text = SCALAR
    __type = mkTypeData "String"
  
  instance GQLType Bool where
    type KIND Bool = SCALAR
    __type = mkTypeData "Boolean"
  
  instance GQLType ID where
    type KIND ID = SCALAR
    __type = mkTypeData "ID"
  
  instance GQLType (Value CONST) where
    type KIND (Value CONST) = CUSTOM
    __type = mkTypeData "INTERNAL_VALUE"
    __deriveType = deriveScalarDefinition (const $ ScalarDefinition pure) withDir
    __exploreRef _ = []
  
  -- WRAPPERS
  instance GQLType () where
    __type = mkTypeData unitTypeName
  
  instance (Typeable m) => GQLType (Undefined m) where
    __type = mkTypeData __typenameUndefined
  
  instance (GQLType a) => GQLType (Maybe a) where
    type KIND (Maybe a) = WRAPPER
    __type = wrapper toNullable . __type . mapCat (Proxy @a)
  
  instance (GQLType a) => GQLType [a] where
    type KIND [a] = WRAPPER
    __type = wrapper list . __type . mapCat (Proxy @a)
  
  instance (GQLType a) => GQLType (Set a) where
    type KIND (Set a) = WRAPPER
    __type = __type . mapCat (Proxy @[a])
  
  instance (GQLType a) => GQLType (NonEmpty a) where
    type KIND (NonEmpty a) = WRAPPER
    __type = __type . mapCat (Proxy @[a])
  
  instance (GQLType a) => GQLType (Seq a) where
    type KIND (Seq a) = WRAPPER
    __type = __type . mapCat (Proxy @[a])
  
  instance (GQLType a) => GQLType (Vector a) where
    type KIND (Vector a) = WRAPPER
    __type = __type . mapCat (Proxy @[a])
  
  instance (GQLType a) => GQLType (SubscriptionField a) where
    type KIND (SubscriptionField a) = WRAPPER
    __type = __type . mapCat (Proxy @a)
    __exploreRef = __exploreRef . mapCat (Proxy @a)
  
  instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where
    directives _ = typeDirective InputTypeNamespace {inputTypeNamespace = "Input"}
  
  -- Manual
  
  instance (GQLType b, GQLType a, Gmap GQLType (Rep a)) => GQLType (a -> b) where
    type KIND (a -> b) = CUSTOM
    __type = __type . mapCat (Proxy @b)
    __deriveType OutputType = __deriveType (OutputType :: CatType OUT b)
    __deriveType proxy = cantBeInputType proxy
    __exploreRef _ =
      scanNode False withGQL (InputType :: CatType IN a)
        <> __exploreRef (OutputType :: CatType OUT b)
  
  instance (GQLType k, GQLType v, Typeable k, Typeable v) => GQLType (Map k v) where
    type KIND (Map k v) = CUSTOM
    __type = __type . mapCat (Proxy @[Pair k v])
    __deriveType = __deriveType . mapCat (Proxy @[(k, v)])
    __exploreRef = __exploreRef . mapCat (Proxy @(Pair k v))
  
  instance (GQLType a) => GQLType (Resolver o e m a) where
    type KIND (Resolver o e m a) = CUSTOM
    __type = __type . mapCat (Proxy @a)
    __deriveType = __deriveType . mapCat (Proxy @a)
    __exploreRef = __exploreRef . mapCat (Proxy @a)
  
  instance (Typeable k, Typeable v, GQLType k, GQLType v) => GQLType (k, v) where
    __type = __type . mapCat (Proxy @(Pair k v))
    directives _ = typeDirective InputTypeNamespace {inputTypeNamespace = "Input"}
    __exploreRef = __exploreRef . mapCat (Proxy @(Pair k v))
  
  instance (KnownSymbol name, GQLType value) => GQLType (Arg name value) where
    type KIND (Arg name value) = CUSTOM
    __type = __type . mapCat (Proxy @value)
    __deriveType OutputType = cantBeInputType (OutputType :: CatType OUT (Arg name value))
    __deriveType p@InputType = (`GQLTypeNode` []) <$> toTypeDefinition withDir p content
      where
        content :: TypeContent TRUE IN CONST
        content = DataInputObject (singleton argName field)
        argName = symbolName (Proxy @name)
        field :: FieldDefinition IN CONST
        field = mkField Nothing argName (TypeRef gqlTypeName gqlWrappers)
        TypeData {gqlTypeName, gqlWrappers} = __type (InputType :: CatType IN value)
  
    __exploreRef OutputType = []
    __exploreRef InputType = __exploreRef (InputType :: CatType IN value)
  
  instance (DERIVE_TYPE GQLType i, DERIVE_TYPE GQLType u) => GQLType (TypeGuard i u) where
    type KIND (TypeGuard i u) = CUSTOM
    __type = __type . mapCat (Proxy @i)
    __deriveType OutputType = do
      unions <- deriveTypeGuardUnions (withDir, union)
      let imp = ImplementsExtension (useTypename withGQL interface) unions
      (cont, ext) <- deriveInterfaceDefinition withDir interface
      pure $ GQLTypeNode cont (imp : ext)
      where
        interface = OutputType :: CatType OUT i
        union = OutputType :: CatType OUT u
    __deriveType proxy = cantBeInputType proxy
    __exploreRef InputType = []
    __exploreRef ref@OutputType =
      [freeLeaf (useFingerprint withGQL ref) ref]
        <> __exploreRef union
        <> __exploreRef interface
      where
        interface = OutputType :: CatType OUT i
        union = OutputType :: CatType OUT u
  
  instance (GQLType a) => GQLType (NamedResolverT m a) where
    type KIND (NamedResolverT m a) = CUSTOM
    __type = __type . mapCat (Proxy :: Proxy a)
    __deriveType = __deriveType . mapCat (Proxy @a)
    __deriveFieldArguments = __deriveFieldArguments . mapCat (Proxy @a)
    __exploreRef = __exploreRef . mapCat (Proxy :: Proxy a)
  
  type DirectiveUsages = GDirectiveUsages GQLType GQLValue
  
  type DirectiveConstraint a = (GQLDirective a, GQLType a, KIND a ~ DIRECTIVE, GQLValue a)
  
  type DirectiveUsage = GDirectiveUsage GQLType GQLValue
  
  newtype InputTypeNamespace = InputTypeNamespace {inputTypeNamespace :: Text}
    deriving (Generic)
  
  instance GQLType InputTypeNamespace where
    type KIND InputTypeNamespace = DIRECTIVE
  
  instance GQLDirective InputTypeNamespace where
    excludeFromSchema _ = True
    type
      DIRECTIVE_LOCATIONS InputTypeNamespace =
        '[ 'LOCATION_OBJECT,
           'LOCATION_ENUM,
           'LOCATION_INPUT_OBJECT,
           'LOCATION_UNION,
           'LOCATION_SCALAR,
           'LOCATION_INTERFACE
         ]
  
  instance VisitType InputTypeNamespace where
    visitTypeName InputTypeNamespace {inputTypeNamespace} isInput name
      | isInput = inputTypeNamespace <> name
      | otherwise = name
  
  withValue :: GQLValueCTX GQLValue
  withValue =
    GQLValueCTX
      { __useDecodeValue = decodeValue,
        __useEncodeValue = encodeValue
      }
  
  withGQL :: WITH_GQL
  withGQL =
    GQLTypeCTX
      { __useFingerprint = gqlFingerprint . __type,
        __useTypename = gqlTypeName . __type,
        __useTypeData = __type,
        __useDeriveNode = __deriveType,
        __useExploreRef = \p -> __exploreRef p <> concatMap exploreDirective (allUsages (directives p)),
        __useDeriveFieldArgs = __deriveFieldArguments
      }
  
  typeDirective :: (DirectiveConstraint a) => a -> DirectiveUsages
  typeDirective x = GDirectiveUsages [GDirectiveUsage x] mempty mempty
  
  fieldDirective :: (DirectiveConstraint a) => FieldName -> a -> DirectiveUsages
  fieldDirective name x = GDirectiveUsages mempty (M.singleton name [GDirectiveUsage x]) mempty
  
  fieldDirective' :: (DirectiveConstraint a) => TH.Name -> a -> DirectiveUsages
  fieldDirective' name = fieldDirective (packName name)
  
  enumDirective :: (DirectiveConstraint a) => TypeName -> a -> DirectiveUsages
  enumDirective name x = GDirectiveUsages mempty mempty (M.singleton name [GDirectiveUsage x])
  
  enumDirective' :: (DirectiveConstraint a) => TH.Name -> a -> DirectiveUsages
  enumDirective' name = enumDirective (packName name)
  
  exploreDirective :: DirectiveUsage -> [ScanRef FreeCatType GQLType]
  exploreDirective (GDirectiveUsage x) = __exploreRef $ inputType $ Identity x
  
  withDir :: WITH_DERIVING
  withDir =
    UseDeriving
      { useDirectives = directives,
        __useGQL = withGQL,
        __useValue = withValue
      }
  
  type WITH_GQL = GQLTypeCTX GQLType
  
  type WITH_DERIVING = UseDeriving GQLType GQLValue
  
  type WITH_RESOLVER = UseResolver GQLResolver GQLType GQLValue
  
  class (GQLType a) => GQLValue a where
    decodeValue :: Value VALID -> ResolverState a
    encodeValue :: a -> GQLResult (Value CONST)
  
  instance (GQLType a, KindedValue WITH_DERIVING (KIND a) a) => GQLValue a where
    encodeValue value = encodeKindedValue withDir (Kinded value :: Kinded (KIND a) a)
    decodeValue = decodeKindedValue withDir (Proxy @(KIND a))
  
  class (MonadResolver m) => GQLResolver (m :: Type -> Type) resolver where
    deriveResolver :: resolver -> m (ResolverValue m)
  
  instance (MonadResolver m, KindedResolver WITH_RESOLVER (KIND a) m a) => GQLResolver m a where
    deriveResolver resolver = kindedResolver withRes (Kinded resolver :: Kinded (KIND a) a)
  
  withRes :: UseResolver GQLResolver GQLType GQLValue
  withRes =
    UseResolver
      { useEncodeResolver = deriveResolver,
        resDrv = withDir
      }
  