{-# 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
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