{-# 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 :: f a -> Text -> Maybe Text
lookupDescription f a
proxy Text
name = Text
name Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` f a -> Map Text Text
forall a (f :: * -> *). GQLType a => f a -> Map Text Text
getDescriptions f a
proxy

lookupDirectives :: GQLType a => f a -> Text -> Directives CONST
lookupDirectives :: f a -> Text -> Directives CONST
lookupDirectives f a
proxy Text
name = Directives CONST -> Maybe (Directives CONST) -> Directives CONST
forall a. a -> Maybe a -> a
fromMaybe Directives CONST
forall coll. Empty coll => coll
empty (Maybe (Directives CONST) -> Directives CONST)
-> Maybe (Directives CONST) -> Directives CONST
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Map Text (Directives CONST) -> Maybe (Directives CONST)
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` f a -> Map Text (Directives CONST)
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 :: KindedType kind a -> Text -> Maybe (FieldContent TRUE kind CONST)
lookupFieldContent proxy :: KindedType kind a
proxy@KindedType kind a
InputType Text
key = Value CONST -> FieldContent TRUE kind CONST
forall (s :: Stage) (cat :: TypeCategory).
Value s -> FieldContent (IN <=? cat) cat s
DefaultInputValue (Value CONST -> FieldContent TRUE kind CONST)
-> Maybe (Value CONST) -> Maybe (FieldContent TRUE kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
key Text -> Map Text (Value CONST) -> Maybe (Value CONST)
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` KindedType kind a -> Map Text (Value CONST)
forall a (f :: * -> *). GQLType a => f a -> Map Text (Value CONST)
defaultValues KindedType kind a
proxy
lookupFieldContent KindedType kind a
OutputType Text
_ = Maybe (FieldContent TRUE kind CONST)
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} = String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (NonEmpty GQLError -> String
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 :: (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 =
  TypeFingerprint
-> (f kind a -> SchemaT c (TypeDefinition kind CONST))
-> f kind a
-> SchemaT c ()
forall a (cat' :: TypeCategory) (cat :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (TypeDefinition cat CONST))
-> a
-> SchemaT cat' ()
updateSchema
    (TypeData -> TypeFingerprint
gqlFingerprint (TypeData -> TypeFingerprint) -> TypeData -> TypeFingerprint
forall a b. (a -> b) -> a -> b
$ f kind a -> TypeData
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 =
      (TypeContent TRUE kind CONST -> TypeDefinition kind CONST)
-> SchemaT c (TypeContent TRUE kind CONST)
-> SchemaT c (TypeDefinition kind CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( Maybe Text
-> TypeName
-> Directives CONST
-> TypeContent TRUE kind CONST
-> TypeDefinition kind CONST
forall (a :: TypeCategory) (s :: Stage).
Maybe Text
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
            (f kind a -> Maybe Text
forall a (f :: * -> *). GQLType a => f a -> Maybe Text
description f kind a
proxy)
            (TypeData -> TypeName
gqlTypeName (f kind a -> TypeData
forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData f kind a
proxy))
            Directives CONST
forall coll. Empty coll => coll
empty
        )
        (SchemaT c (TypeContent TRUE kind CONST)
 -> SchemaT c (TypeDefinition kind CONST))
-> (f kind a -> SchemaT c (TypeContent TRUE kind CONST))
-> f kind a
-> SchemaT c (TypeDefinition kind CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f kind a -> SchemaT c (TypeContent TRUE kind CONST)
f