{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Schema
  ( compileTimeSchemaValidation,
    deriveSchema,
    SCHEMA,
  )
where

import Control.Monad.Except (MonadError (..))
import Data.Map (alter, findWithDefault, insert)
import Data.Morpheus.Core (defaultConfig, validateSchema)
import Data.Morpheus.Generic (CBox, runCBox)
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Internal.Utils (IsMap (..), toAssoc)
import Data.Morpheus.Server.Deriving.Utils.GScan
  ( FreeCatType (..),
    scanFree,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded (outputType)
import Data.Morpheus.Server.Deriving.Utils.Types (CatType (OutputType), GQLTypeNode (..), GQLTypeNodeExtension (..), NodeTypeVariant (..), coerceObject, fromSchema, nodeToType)
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseGQLType (useDeriveNode, useExploreRef, useFingerprint),
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (..),
    IgnoredResolver,
    ignoreUndefined,
    withGQL,
  )
import Data.Morpheus.Server.Types.TypeName (TypeFingerprint (..))
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    CONST,
    DirectiveDefinition,
    OBJECT,
    OUT,
    Schema,
    TypeCategory (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    defineDirective,
    defineSchemaWith,
    mkEnumContent,
    mkType,
    msg,
    toAny,
    unitTypeName,
  )
import Language.Haskell.TH (Exp, Q)
import Relude hiding (empty)

type SCHEMA qu mu su =
  ( GQLType (qu IgnoredResolver),
    GQLType (mu IgnoredResolver),
    GQLType (su IgnoredResolver)
  )

-- | normal morpheus server validates schema at runtime (after the schema derivation).
--   this method allows you to validate it at compile time.
compileTimeSchemaValidation :: (SCHEMA qu mu su) => proxy (root m event qu mu su) -> Q Exp
compileTimeSchemaValidation :: forall {k} {k} {k} (qu :: (* -> *) -> *) (mu :: (* -> *) -> *)
       (su :: (* -> *) -> *) (proxy :: k -> *)
       (root :: k
                -> k -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k)
       (m :: k) (event :: k).
SCHEMA qu mu su =>
proxy (root m event qu mu su) -> Q Exp
compileTimeSchemaValidation = GQLResult (Schema VALID) -> Q Exp
fromSchema (GQLResult (Schema VALID) -> Q Exp)
-> (proxy (root m event qu mu su) -> GQLResult (Schema VALID))
-> proxy (root m event qu mu su)
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (proxy (root m event qu mu su) -> GQLResult (Schema CONST)
forall {k} {k} {k}
       (root :: k
                -> k -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k)
       (f :: k -> *) (m :: k) (e :: k) (qu :: (* -> *) -> *)
       (mu :: (* -> *) -> *) (su :: (* -> *) -> *).
SCHEMA qu mu su =>
f (root m e qu mu su) -> GQLResult (Schema CONST)
deriveSchema (proxy (root m event qu mu su) -> GQLResult (Schema CONST))
-> (Schema CONST -> GQLResult (Schema VALID))
-> proxy (root m event qu mu su)
-> GQLResult (Schema VALID)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool -> Config -> Schema CONST -> GQLResult (Schema VALID)
forall (s :: Stage).
ValidateSchema s =>
Bool -> Config -> Schema s -> GQLResult (Schema VALID)
validateSchema Bool
True Config
defaultConfig)

explore :: forall f (a :: (Type -> Type) -> Type). (GQLType (a IgnoredResolver)) => f a -> [CBox FreeCatType GQLType]
explore :: forall (f :: ((* -> *) -> *) -> *) (a :: (* -> *) -> *).
GQLType (a IgnoredResolver) =>
f a -> [CBox FreeCatType GQLType]
explore f a
_ = (forall (k' :: TypeCategory) a'.
 GQLType a' =>
 CatType k' a' -> [ScanRef FreeCatType GQLType])
-> CatType OUT (a IgnoredResolver) -> [CBox FreeCatType GQLType]
forall (c :: * -> Constraint) a (k :: TypeCategory).
c a =>
(forall (k' :: TypeCategory) a'.
 c a' =>
 CatType k' a' -> [ScanRef FreeCatType c])
-> CatType k a -> [CBox FreeCatType c]
scanFree (WITH_GQL -> CatType k' a' -> [ScanRef FreeCatType GQLType]
forall a (c :: TypeCategory).
GQLType a =>
WITH_GQL -> CatType c a -> [ScanRef FreeCatType GQLType]
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> [ScanRef FreeCatType con]
useExploreRef WITH_GQL
withGQL) (CatType OUT (a IgnoredResolver)
forall {k} (a :: k). CatType OUT a
OutputType :: CatType OUT (a IgnoredResolver))

toDerivation :: TypeFingerprint -> GQLTypeNode c -> (TypeFingerprint, GQLTypeNode ANY)
toDerivation :: forall (c :: TypeCategory).
TypeFingerprint
-> GQLTypeNode c -> (TypeFingerprint, GQLTypeNode ANY)
toDerivation TypeFingerprint
fp (GQLTypeNode TypeDefinition c CONST
node [GQLTypeNodeExtension]
xs) = (TypeFingerprint
fp, TypeDefinition ANY CONST
-> [GQLTypeNodeExtension] -> GQLTypeNode ANY
forall (c :: TypeCategory).
TypeDefinition c CONST -> [GQLTypeNodeExtension] -> GQLTypeNode c
GQLTypeNode (TypeDefinition c CONST -> TypeDefinition ANY CONST
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
ToCategory a k ANY =>
a k s -> a ANY s
toAny TypeDefinition c CONST
node) [GQLTypeNodeExtension]
xs)
toDerivation TypeFingerprint
fp (GQLDirectiveNode DirectiveDefinition CONST
node) = (TypeFingerprint
fp, DirectiveDefinition CONST -> GQLTypeNode ANY
forall (c :: TypeCategory).
DirectiveDefinition CONST -> GQLTypeNode c
GQLDirectiveNode DirectiveDefinition CONST
node)

resolveNode :: (GQLType a) => FreeCatType a -> GQLResult (TypeFingerprint, GQLTypeNode ANY)
resolveNode :: forall a.
GQLType a =>
FreeCatType a -> GQLResult (TypeFingerprint, GQLTypeNode ANY)
resolveNode (FreeCatType CatType c a
proxy) = TypeFingerprint
-> GQLTypeNode c -> (TypeFingerprint, GQLTypeNode ANY)
forall (c :: TypeCategory).
TypeFingerprint
-> GQLTypeNode c -> (TypeFingerprint, GQLTypeNode ANY)
toDerivation (WITH_GQL -> CatType c a -> TypeFingerprint
forall a (c :: TypeCategory).
GQLType a =>
WITH_GQL -> CatType c a -> TypeFingerprint
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeFingerprint
useFingerprint WITH_GQL
withGQL CatType c a
proxy) (GQLTypeNode c -> (TypeFingerprint, GQLTypeNode ANY))
-> Result GQLError (GQLTypeNode c)
-> GQLResult (TypeFingerprint, GQLTypeNode ANY)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WITH_GQL -> CatType c a -> Result GQLError (GQLTypeNode c)
forall a (c :: TypeCategory).
GQLType a =>
WITH_GQL -> CatType c a -> GQLResult (GQLTypeNode c)
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> GQLResult (GQLTypeNode c)
useDeriveNode WITH_GQL
withGQL CatType c a
proxy

deriveRoot :: (GQLType a) => f a -> GQLResult (TypeDefinition OBJECT CONST)
deriveRoot :: forall a (f :: * -> *).
GQLType a =>
f a -> GQLResult (TypeDefinition OBJECT CONST)
deriveRoot f a
prx = WITH_GQL -> CatType OUT a -> GQLResult (GQLTypeNode OUT)
forall a (c :: TypeCategory).
GQLType a =>
WITH_GQL -> CatType c a -> GQLResult (GQLTypeNode c)
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> GQLResult (GQLTypeNode c)
useDeriveNode WITH_GQL
withGQL (f a -> CatType OUT a
forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType f a
prx) GQLResult (GQLTypeNode OUT)
-> (GQLTypeNode OUT -> Result GQLError (TypeDefinition OUT CONST))
-> Result GQLError (TypeDefinition OUT CONST)
forall a b.
Result GQLError a -> (a -> Result GQLError b) -> Result GQLError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GQLTypeNode OUT -> Result GQLError (TypeDefinition OUT CONST)
forall (m :: * -> *) (c :: TypeCategory).
DerivingMonad m =>
GQLTypeNode c -> m (TypeDefinition c CONST)
nodeToType Result GQLError (TypeDefinition OUT CONST)
-> (TypeDefinition OUT CONST
    -> GQLResult (TypeDefinition OBJECT CONST))
-> GQLResult (TypeDefinition OBJECT CONST)
forall a b.
Result GQLError a -> (a -> Result GQLError b) -> Result GQLError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeDefinition OUT CONST -> GQLResult (TypeDefinition OBJECT CONST)
forall (m :: * -> *) (c :: TypeCategory).
DerivingMonad m =>
TypeDefinition c CONST -> m (TypeDefinition OBJECT CONST)
coerceObject

data SchemaState where
  SchemaState ::
    { SchemaState -> Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST),
      SchemaState -> Map TypeName [TypeName]
implements :: Map TypeName [TypeName],
      SchemaState -> Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)
    } ->
    SchemaState

instance Semigroup SchemaState where
  SchemaState Map TypeFingerprint (TypeDefinition ANY CONST)
t1 Map TypeName [TypeName]
i1 Map TypeFingerprint (DirectiveDefinition CONST)
d1 <> :: SchemaState -> SchemaState -> SchemaState
<> SchemaState Map TypeFingerprint (TypeDefinition ANY CONST)
t2 Map TypeName [TypeName]
i2 Map TypeFingerprint (DirectiveDefinition CONST)
d2 = Map TypeFingerprint (TypeDefinition ANY CONST)
-> Map TypeName [TypeName]
-> Map TypeFingerprint (DirectiveDefinition CONST)
-> SchemaState
SchemaState (Map TypeFingerprint (TypeDefinition ANY CONST)
t1 Map TypeFingerprint (TypeDefinition ANY CONST)
-> Map TypeFingerprint (TypeDefinition ANY CONST)
-> Map TypeFingerprint (TypeDefinition ANY CONST)
forall a. Semigroup a => a -> a -> a
<> Map TypeFingerprint (TypeDefinition ANY CONST)
t2) (Map TypeName [TypeName]
i1 Map TypeName [TypeName]
-> Map TypeName [TypeName] -> Map TypeName [TypeName]
forall a. Semigroup a => a -> a -> a
<> Map TypeName [TypeName]
i2) (Map TypeFingerprint (DirectiveDefinition CONST)
d1 Map TypeFingerprint (DirectiveDefinition CONST)
-> Map TypeFingerprint (DirectiveDefinition CONST)
-> Map TypeFingerprint (DirectiveDefinition CONST)
forall a. Semigroup a => a -> a -> a
<> Map TypeFingerprint (DirectiveDefinition CONST)
d2)

instance Monoid SchemaState where
  mempty :: SchemaState
mempty = Map TypeFingerprint (TypeDefinition ANY CONST)
-> Map TypeName [TypeName]
-> Map TypeFingerprint (DirectiveDefinition CONST)
-> SchemaState
SchemaState Map TypeFingerprint (TypeDefinition ANY CONST)
forall a. Monoid a => a
mempty Map TypeName [TypeName]
forall a. Monoid a => a
mempty Map TypeFingerprint (DirectiveDefinition CONST)
forall a. Monoid a => a
mempty

insertImplements :: Map TypeName [TypeName] -> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements :: forall (c :: TypeCategory).
Map TypeName [TypeName]
-> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements Map TypeName [TypeName]
implementsMap TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {[TypeName]
FieldsDefinition OUT CONST
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT CONST
objectImplements :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> [TypeName]
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
..}, Maybe Description
Directives CONST
TypeName
typeDescription :: Maybe Description
typeName :: TypeName
typeDirectives :: Directives CONST
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
..} = TypeDefinition {Maybe Description
Directives CONST
TypeName
TypeContent TRUE c CONST
TypeContent (OBJECT <=? c) c CONST
typeContent :: TypeContent TRUE c CONST
typeDescription :: Maybe Description
typeName :: TypeName
typeDirectives :: Directives CONST
typeDescription :: Maybe Description
typeName :: TypeName
typeDirectives :: Directives CONST
typeContent :: TypeContent (OBJECT <=? c) c CONST
..}
  where
    typeContent :: TypeContent (OBJECT <=? c) c CONST
typeContent = DataObject {objectImplements :: [TypeName]
objectImplements = [TypeName]
objectImplements [TypeName] -> [TypeName] -> [TypeName]
forall a. Semigroup a => a -> a -> a
<> [TypeName]
implements, FieldsDefinition OUT CONST
objectFields :: FieldsDefinition OUT CONST
objectFields :: FieldsDefinition OUT CONST
..}
    implements :: [TypeName]
implements = [TypeName] -> TypeName -> Map TypeName [TypeName] -> [TypeName]
forall k a. Ord k => a -> k -> Map k a -> a
findWithDefault [] TypeName
typeName Map TypeName [TypeName]
implementsMap
insertImplements Map TypeName [TypeName]
_ TypeDefinition c CONST
t = TypeDefinition c CONST
t

checkTypeCollisions :: [(TypeFingerprint, TypeDefinition k a)] -> GQLResult [TypeDefinition k a]
checkTypeCollisions :: forall (k :: TypeCategory) (a :: Stage).
[(TypeFingerprint, TypeDefinition k a)]
-> GQLResult [TypeDefinition k a]
checkTypeCollisions = (Map (TypeName, TypeFingerprint) (TypeDefinition k a)
 -> [TypeDefinition k a])
-> Result
     GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
-> Result GQLError [TypeDefinition k a]
forall a b. (a -> b) -> Result GQLError a -> Result GQLError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> [TypeDefinition k a]
forall a. Map (TypeName, TypeFingerprint) a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Result
   GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
 -> Result GQLError [TypeDefinition k a])
-> ([(TypeFingerprint, TypeDefinition k a)]
    -> Result
         GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a)))
-> [(TypeFingerprint, TypeDefinition k a)]
-> Result GQLError [TypeDefinition k a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (TypeName, TypeFingerprint) (TypeDefinition k a)
 -> (TypeFingerprint, TypeDefinition k a)
 -> Result
      GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a)))
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> [(TypeFingerprint, TypeDefinition k a)]
-> Result
     GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> (TypeFingerprint, TypeDefinition k a)
-> Result
     GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall (k :: TypeCategory) (a :: Stage).
Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> (TypeFingerprint, TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
collectTypes Map (TypeName, TypeFingerprint) (TypeDefinition k a)
forall a. Monoid a => a
mempty
  where
    collectTypes :: Map (TypeName, TypeFingerprint) (TypeDefinition k a) -> (TypeFingerprint, TypeDefinition k a) -> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
    collectTypes :: forall (k :: TypeCategory) (a :: Stage).
Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> (TypeFingerprint, TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
collectTypes Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum (TypeFingerprint
fp, TypeDefinition k a
typ) = GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
-> (TypeDefinition k a
    -> GQLResult
         (Map (TypeName, TypeFingerprint) (TypeDefinition k a)))
-> Maybe (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
addType (TypeDefinition k a
-> TypeDefinition k a
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
handleCollision TypeDefinition k a
typ) ((TypeName, TypeFingerprint)
key (TypeName, TypeFingerprint)
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> Maybe (TypeDefinition k a)
forall a.
(TypeName, TypeFingerprint)
-> Map (TypeName, TypeFingerprint) a -> Maybe a
forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
`lookup` Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum)
      where
        addType :: GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
addType = Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall a. a -> Result GQLError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (TypeName, TypeFingerprint) (TypeDefinition k a)
 -> GQLResult
      (Map (TypeName, TypeFingerprint) (TypeDefinition k a)))
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall a b. (a -> b) -> a -> b
$ (TypeName, TypeFingerprint)
-> TypeDefinition k a
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> Map (TypeName, TypeFingerprint) (TypeDefinition k a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert (TypeName, TypeFingerprint)
key TypeDefinition k a
typ Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum
        key :: (TypeName, TypeFingerprint)
key = (TypeDefinition k a -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition k a
typ, TypeFingerprint -> TypeFingerprint
withSameCategory TypeFingerprint
fp)
        handleCollision :: TypeDefinition k a
-> TypeDefinition k a
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
handleCollision t1 :: TypeDefinition k a
t1@TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataEnum {}} TypeDefinition k a
t2 | TypeDefinition k a
t1 TypeDefinition k a -> TypeDefinition k a -> Bool
forall a. Eq a => a -> a -> Bool
== TypeDefinition k a
t2 = Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall a. a -> Result GQLError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum
        handleCollision TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataScalar {}} TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataScalar {}} = Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall a. a -> Result GQLError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum
        handleCollision TypeDefinition {typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName = TypeName
name1} TypeDefinition k a
_ = TypeName
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
forall b. TypeName -> GQLResult b
failureRequirePrefix TypeName
name1

failureRequirePrefix :: TypeName -> GQLResult b
failureRequirePrefix :: forall b. TypeName -> GQLResult b
failureRequirePrefix TypeName
typename =
  GQLError -> Result GQLError b
forall a. GQLError -> Result GQLError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> Result GQLError b) -> GQLError -> Result GQLError b
forall a b. (a -> b) -> a -> b
$
    GQLError
"It appears that the Haskell type "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
typename
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" was used as both input and output type, which is not allowed by GraphQL specifications."
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"\n\n "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"If you use \"InputTypeNamespace\" directive, "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"you can override the default type names for "
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
typename
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" to solve this problem."

withSameCategory :: TypeFingerprint -> TypeFingerprint
withSameCategory :: TypeFingerprint -> TypeFingerprint
withSameCategory (TypeableFingerprint TypeCategory
_ [Fingerprint]
xs) = TypeCategory -> [Fingerprint] -> TypeFingerprint
TypeableFingerprint TypeCategory
OUT [Fingerprint]
xs
withSameCategory TypeFingerprint
x = TypeFingerprint
x

execNode :: (TypeFingerprint, GQLTypeNode ANY) -> SchemaState -> SchemaState
execNode :: (TypeFingerprint, GQLTypeNode ANY) -> SchemaState -> SchemaState
execNode (InternalFingerprint {}, GQLTypeNode ANY
_) SchemaState
s = SchemaState
s
execNode (TypeFingerprint
fp, GQLTypeNode TypeDefinition ANY CONST
t [GQLTypeNodeExtension]
xs) SchemaState
s = (GQLTypeNodeExtension -> SchemaState -> SchemaState)
-> SchemaState -> [GQLTypeNodeExtension] -> SchemaState
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GQLTypeNodeExtension -> SchemaState -> SchemaState
execExtension (SchemaState
s {typeDefinitions = insert fp t (typeDefinitions s)}) [GQLTypeNodeExtension]
xs
execNode (TypeFingerprint
fp, GQLDirectiveNode DirectiveDefinition CONST
d) SchemaState
s = SchemaState
s {directiveDefinitions = insert fp d (directiveDefinitions s)}

execExtension :: GQLTypeNodeExtension -> SchemaState -> SchemaState
execExtension :: GQLTypeNodeExtension -> SchemaState -> SchemaState
execExtension (ImplementsExtension TypeName
interface [TypeName]
types) SchemaState
s = SchemaState
s {implements = foldr insertInterface (implements s) types}
  where
    insertInterface :: TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]
insertInterface = (Maybe [TypeName] -> Maybe [TypeName])
-> TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
alter ([TypeName] -> Maybe [TypeName]
forall a. a -> Maybe a
Just ([TypeName] -> Maybe [TypeName])
-> (Maybe [TypeName] -> [TypeName])
-> Maybe [TypeName]
-> Maybe [TypeName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeName
interface TypeName -> [TypeName] -> [TypeName]
forall a. a -> [a] -> [a]
:) ([TypeName] -> [TypeName])
-> (Maybe [TypeName] -> [TypeName])
-> Maybe [TypeName]
-> [TypeName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeName] -> Maybe [TypeName] -> [TypeName]
forall a. a -> Maybe a -> a
fromMaybe [])
execExtension (UnionVariantsExtension [NodeTypeVariant]
nodes) SchemaState
s = (NodeTypeVariant -> SchemaState -> SchemaState)
-> SchemaState -> [NodeTypeVariant] -> SchemaState
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NodeTypeVariant -> SchemaState -> SchemaState
execNodeTypeVariant SchemaState
s [NodeTypeVariant]
nodes

execNodeTypeVariant :: NodeTypeVariant -> SchemaState -> SchemaState
execNodeTypeVariant :: NodeTypeVariant -> SchemaState -> SchemaState
execNodeTypeVariant (NodeTypeVariant TypeName
consName TypeContent TRUE ANY CONST
fields) SchemaState
s = SchemaState
s {typeDefinitions = insert fp t (typeDefinitions s)}
  where
    fp :: TypeFingerprint
fp = TypeName -> TypeFingerprint
CustomFingerprint TypeName
consName
    t :: TypeDefinition ANY CONST
t = TypeName -> TypeContent TRUE ANY CONST -> TypeDefinition ANY CONST
forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
consName TypeContent TRUE ANY CONST
fields
execNodeTypeVariant NodeTypeVariant
NodeUnitType SchemaState
s = SchemaState
s {typeDefinitions = insert fp t (typeDefinitions s)}
  where
    fp :: TypeFingerprint
fp = TypeName -> TypeFingerprint
CustomFingerprint TypeName
unitTypeName
    t :: TypeDefinition ANY s
t = TypeName -> TypeContent TRUE ANY s -> TypeDefinition ANY s
forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
unitTypeName ([TypeName] -> TypeContent TRUE ANY s
forall (a :: TypeCategory) (s :: Stage).
(LEAF <=! a) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent [TypeName
unitTypeName])

deriveSchema :: forall root f m e qu mu su. (SCHEMA qu mu su) => f (root m e qu mu su) -> GQLResult (Schema CONST)
deriveSchema :: forall {k} {k} {k}
       (root :: k
                -> k -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k)
       (f :: k -> *) (m :: k) (e :: k) (qu :: (* -> *) -> *)
       (mu :: (* -> *) -> *) (su :: (* -> *) -> *).
SCHEMA qu mu su =>
f (root m e qu mu su) -> GQLResult (Schema CONST)
deriveSchema f (root m e qu mu su)
_ = do
  TypeDefinition OBJECT CONST
query <- Proxy (qu IgnoredResolver)
-> GQLResult (TypeDefinition OBJECT CONST)
forall a (f :: * -> *).
GQLType a =>
f a -> GQLResult (TypeDefinition OBJECT CONST)
deriveRoot (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(qu IgnoredResolver))
  Maybe (TypeDefinition OBJECT CONST)
mutation <- (Proxy (mu IgnoredResolver)
 -> GQLResult (TypeDefinition OBJECT CONST))
-> Maybe (Proxy (mu IgnoredResolver))
-> Result GQLError (Maybe (TypeDefinition OBJECT CONST))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Proxy (mu IgnoredResolver)
-> GQLResult (TypeDefinition OBJECT CONST)
forall a (f :: * -> *).
GQLType a =>
f a -> GQLResult (TypeDefinition OBJECT CONST)
deriveRoot (Proxy (mu IgnoredResolver) -> Maybe (Proxy (mu IgnoredResolver))
forall (f :: * -> *) a. GQLType a => f a -> Maybe (f a)
ignoreUndefined (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(mu IgnoredResolver)))
  Maybe (TypeDefinition OBJECT CONST)
subscription <- (Proxy (su IgnoredResolver)
 -> GQLResult (TypeDefinition OBJECT CONST))
-> Maybe (Proxy (su IgnoredResolver))
-> Result GQLError (Maybe (TypeDefinition OBJECT CONST))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Proxy (su IgnoredResolver)
-> GQLResult (TypeDefinition OBJECT CONST)
forall a (f :: * -> *).
GQLType a =>
f a -> GQLResult (TypeDefinition OBJECT CONST)
deriveRoot (Proxy (su IgnoredResolver) -> Maybe (Proxy (su IgnoredResolver))
forall (f :: * -> *) a. GQLType a => f a -> Maybe (f a)
ignoreUndefined (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(su IgnoredResolver)))
  [(TypeFingerprint, GQLTypeNode ANY)]
typeNodes <- (CBox FreeCatType GQLType
 -> GQLResult (TypeFingerprint, GQLTypeNode ANY))
-> [CBox FreeCatType GQLType]
-> Result GQLError [(TypeFingerprint, GQLTypeNode ANY)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((forall a.
 GQLType a =>
 FreeCatType a -> GQLResult (TypeFingerprint, GQLTypeNode ANY))
-> CBox FreeCatType GQLType
-> GQLResult (TypeFingerprint, GQLTypeNode ANY)
forall {k} (c :: k -> Constraint) (f :: k -> *) b.
(forall (a :: k). c a => f a -> b) -> CBox f c -> b
runCBox FreeCatType a -> GQLResult (TypeFingerprint, GQLTypeNode ANY)
forall a.
GQLType a =>
FreeCatType a -> GQLResult (TypeFingerprint, GQLTypeNode ANY)
resolveNode) (Proxy qu -> [CBox FreeCatType GQLType]
forall (f :: ((* -> *) -> *) -> *) (a :: (* -> *) -> *).
GQLType (a IgnoredResolver) =>
f a -> [CBox FreeCatType GQLType]
explore (forall {k} (t :: k). Proxy t
forall (t :: (* -> *) -> *). Proxy t
Proxy @qu) [CBox FreeCatType GQLType]
-> [CBox FreeCatType GQLType] -> [CBox FreeCatType GQLType]
forall a. Semigroup a => a -> a -> a
<> Proxy mu -> [CBox FreeCatType GQLType]
forall (f :: ((* -> *) -> *) -> *) (a :: (* -> *) -> *).
GQLType (a IgnoredResolver) =>
f a -> [CBox FreeCatType GQLType]
explore (forall {k} (t :: k). Proxy t
forall (t :: (* -> *) -> *). Proxy t
Proxy @mu) [CBox FreeCatType GQLType]
-> [CBox FreeCatType GQLType] -> [CBox FreeCatType GQLType]
forall a. Semigroup a => a -> a -> a
<> Proxy su -> [CBox FreeCatType GQLType]
forall (f :: ((* -> *) -> *) -> *) (a :: (* -> *) -> *).
GQLType (a IgnoredResolver) =>
f a -> [CBox FreeCatType GQLType]
explore (forall {k} (t :: k). Proxy t
forall (t :: (* -> *) -> *). Proxy t
Proxy @su))
  let SchemaState {Map TypeName [TypeName]
Map TypeFingerprint (DirectiveDefinition CONST)
Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions :: SchemaState -> Map TypeFingerprint (TypeDefinition ANY CONST)
implements :: SchemaState -> Map TypeName [TypeName]
directiveDefinitions :: SchemaState -> Map TypeFingerprint (DirectiveDefinition CONST)
typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST)
implements :: Map TypeName [TypeName]
directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)
..} = ((TypeFingerprint, GQLTypeNode ANY) -> SchemaState -> SchemaState)
-> SchemaState
-> [(TypeFingerprint, GQLTypeNode ANY)]
-> SchemaState
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeFingerprint, GQLTypeNode ANY) -> SchemaState -> SchemaState
execNode SchemaState
forall a. Monoid a => a
mempty [(TypeFingerprint, GQLTypeNode ANY)]
typeNodes
  [TypeDefinition ANY CONST]
types <- (TypeDefinition ANY CONST -> TypeDefinition ANY CONST)
-> [TypeDefinition ANY CONST] -> [TypeDefinition ANY CONST]
forall a b. (a -> b) -> [a] -> [b]
map (Map TypeName [TypeName]
-> TypeDefinition ANY CONST -> TypeDefinition ANY CONST
forall (c :: TypeCategory).
Map TypeName [TypeName]
-> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements Map TypeName [TypeName]
implements) ([TypeDefinition ANY CONST] -> [TypeDefinition ANY CONST])
-> Result GQLError [TypeDefinition ANY CONST]
-> Result GQLError [TypeDefinition ANY CONST]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TypeFingerprint, TypeDefinition ANY CONST)]
-> Result GQLError [TypeDefinition ANY CONST]
forall (k :: TypeCategory) (a :: Stage).
[(TypeFingerprint, TypeDefinition k a)]
-> GQLResult [TypeDefinition k a]
checkTypeCollisions (Map TypeFingerprint (TypeDefinition ANY CONST)
-> [(TypeFingerprint, TypeDefinition ANY CONST)]
forall a. Map TypeFingerprint a -> [(TypeFingerprint, a)]
forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)]
toAssoc Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions)
  Schema CONST
schema <- [TypeDefinition ANY CONST]
-> (Maybe (TypeDefinition OBJECT CONST),
    Maybe (TypeDefinition OBJECT CONST),
    Maybe (TypeDefinition OBJECT CONST))
-> GQLResult (Schema CONST)
forall (f :: * -> *) (cat :: TypeCategory) (s :: Stage).
(Monad f, MonadError GQLError f) =>
[TypeDefinition cat s]
-> (Maybe (TypeDefinition OBJECT s),
    Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> f (Schema s)
defineSchemaWith [TypeDefinition ANY CONST]
types (TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST)
forall a. a -> Maybe a
Just TypeDefinition OBJECT CONST
query, Maybe (TypeDefinition OBJECT CONST)
mutation, Maybe (TypeDefinition OBJECT CONST)
subscription)
  (Schema CONST
 -> DirectiveDefinition CONST -> GQLResult (Schema CONST))
-> Schema CONST
-> Map TypeFingerprint (DirectiveDefinition CONST)
-> GQLResult (Schema CONST)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Schema CONST
-> DirectiveDefinition CONST -> GQLResult (Schema CONST)
forall (m :: * -> *) (s :: Stage).
(Monad m, MonadError GQLError m) =>
Schema s -> DirectiveDefinition s -> m (Schema s)
defineDirective Schema CONST
schema Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions