{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Schema.Internal
  ( KindedType (..),
    TyContentM,
    TyContent,
    fromSchema,
    updateByContent,
    lookupDescription,
    lookupDirectives,
    lookupFieldContent,
  )
where

-- MORPHEUS
import qualified Data.Map as M
import Data.Morpheus.App.Internal.Resolving
  ( Result (..),
  )
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Internal.Utils (empty)
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CategoryValue (..),
    KindedType (..),
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (..),
    TypeData (..),
    __typeData,
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    updateSchema,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    Description,
    Directives,
    FieldContent (..),
    Schema (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    VALID,
  )
import Language.Haskell.TH (Exp, Q)
import Relude hiding (empty)

lookupDescription :: GQLType a => f a -> Text -> Maybe Description
lookupDescription :: forall a (f :: * -> *). GQLType a => f a -> Text -> Maybe Text
lookupDescription f a
proxy Text
name = Text
name forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` forall a (f :: * -> *). GQLType a => f a -> Map Text Text
getDescriptions f a
proxy

lookupDirectives :: GQLType a => f a -> Text -> Directives CONST
lookupDirectives :: forall a (f :: * -> *).
GQLType a =>
f a -> Text -> Directives CONST
lookupDirectives f a
proxy Text
name = forall a. a -> Maybe a -> a
fromMaybe forall coll. Empty coll => coll
empty forall a b. (a -> b) -> a -> b
$ Text
name forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` forall a (f :: * -> *).
GQLType a =>
f a -> Map Text (Directives CONST)
getDirectives f a
proxy

lookupFieldContent ::
  GQLType a =>
  KindedType kind a ->
  Text ->
  Maybe (FieldContent TRUE kind CONST)
lookupFieldContent :: forall a (kind :: TypeCategory).
GQLType a =>
KindedType kind a -> Text -> Maybe (FieldContent TRUE kind CONST)
lookupFieldContent proxy :: KindedType kind a
proxy@KindedType kind a
InputType Text
key = forall (s :: Stage) (cat :: TypeCategory).
Value s -> FieldContent ('IN <=? cat) cat s
DefaultInputValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
key forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` forall a (f :: * -> *). GQLType a => f a -> Map Text (Value CONST)
defaultValues KindedType kind a
proxy
lookupFieldContent KindedType kind a
OutputType Text
_ = forall a. Maybe a
Nothing

fromSchema :: GQLResult (Schema VALID) -> Q Exp
fromSchema :: GQLResult (Schema VALID) -> Q Exp
fromSchema Success {} = [|()|]
fromSchema Failure {NonEmpty GQLError
errors :: forall err a. Result err a -> NonEmpty err
errors :: NonEmpty GQLError
errors} = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall b a. (Show a, IsString b) => a -> b
show NonEmpty GQLError
errors)

type TyContentM kind = SchemaT kind (TyContent kind)

type TyContent kind = Maybe (FieldContent TRUE kind CONST)

updateByContent ::
  (GQLType a, CategoryValue kind) =>
  (f kind a -> SchemaT c (TypeContent TRUE kind CONST)) ->
  f kind a ->
  SchemaT c ()
updateByContent :: forall a (kind :: TypeCategory) (f :: TypeCategory -> * -> *)
       (c :: TypeCategory).
(GQLType a, CategoryValue kind) =>
(f kind a -> SchemaT c (TypeContent TRUE kind CONST))
-> f kind a -> SchemaT c ()
updateByContent f kind a -> SchemaT c (TypeContent TRUE kind CONST)
f f kind a
proxy =
  forall a (cat' :: TypeCategory) (cat :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (TypeDefinition cat CONST))
-> a
-> SchemaT cat' ()
updateSchema
    (TypeData -> TypeFingerprint
gqlFingerprint forall a b. (a -> b) -> a -> b
$ forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData f kind a
proxy)
    f kind a -> SchemaT c (TypeDefinition kind CONST)
deriveD
    f kind a
proxy
  where
    deriveD :: f kind a -> SchemaT c (TypeDefinition kind CONST)
deriveD =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( forall (a :: TypeCategory) (s :: Stage).
Maybe Text
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
            (forall a (f :: * -> *). GQLType a => f a -> Maybe Text
description f kind a
proxy)
            (TypeData -> TypeName
gqlTypeName (forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData f kind a
proxy))
            forall coll. Empty coll => coll
empty
        )
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. f kind a -> SchemaT c (TypeContent TRUE kind CONST)
f