morpheus-graphql-server 0.26.0 → 0.27.0

raw patch · 41 files changed

+1059/−800 lines, 41 filesdep ~morpheus-graphql-appdep ~morpheus-graphql-coredep ~morpheus-graphql-subscriptionsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: morpheus-graphql-app, morpheus-graphql-core, morpheus-graphql-subscriptions, morpheus-graphql-tests

API changes (from Hackage documentation)

Files

• morpheus-graphql-server.cabal +16/−7
• src/Data/Morpheus/Server/CodeGen/Internal.hs +0/−2
• src/Data/Morpheus/Server/Deriving/Channels.hs +7/−11
• src/Data/Morpheus/Server/Deriving/Decode.hs +8/−16
• src/Data/Morpheus/Server/Deriving/Encode.hs +12/−11
• src/Data/Morpheus/Server/Deriving/Named/EncodeType.hs +35/−15
• src/Data/Morpheus/Server/Deriving/Named/EncodeValue.hs +17/−17
• src/Data/Morpheus/Server/Deriving/Schema.hs +18/−199
• src/Data/Morpheus/Server/Deriving/Schema/DeriveKinded.hs +176/−0
• src/Data/Morpheus/Server/Deriving/Schema/Directive.hs +77/−77
• src/Data/Morpheus/Server/Deriving/Schema/Enum.hs +12/−13
• src/Data/Morpheus/Server/Deriving/Schema/Internal.hs +2/−2
• src/Data/Morpheus/Server/Deriving/Schema/Object.hs +29/−30
• src/Data/Morpheus/Server/Deriving/Schema/TypeContent.hs +45/−30
• src/Data/Morpheus/Server/Deriving/Schema/Union.hs +11/−13
• src/Data/Morpheus/Server/Deriving/Utils/Decode.hs +2/−2
• src/Data/Morpheus/Server/Deriving/Utils/DeriveGType.hs +23/−26
• src/Data/Morpheus/Server/Deriving/Utils/Kinded.hs +56/−21
• src/Data/Morpheus/Server/Deriving/Utils/Use.hs +60/−0
• src/Data/Morpheus/Server/NamedResolvers.hs +38/−40
• src/Data/Morpheus/Server/Types.hs +15/−8
• src/Data/Morpheus/Server/Types/DirectiveDefinitions.hs +34/−34
• src/Data/Morpheus/Server/Types/Directives.hs +112/−34
• src/Data/Morpheus/Server/Types/GQLType.hs +106/−141
• src/Data/Morpheus/Server/Types/Kind.hs +11/−11
• test/Feature/Directive/Definition.hs +2/−4
• test/Feature/NamedResolvers/DB.hs +7/−0
• test/Feature/NamedResolvers/Deities.hs +3/−1
• test/Feature/NamedResolvers/DeitiesApp.hs +3/−2
• test/Feature/NamedResolvers/Entities.hs +27/−0
• test/Feature/NamedResolvers/EntitiesApp.hs +5/−29
• test/Feature/NamedResolvers/Realms.hs +3/−1
• test/Feature/NamedResolvers/RealmsApp.hs +3/−3
• test/Feature/NamedResolvers/Scalars.hs +38/−0
• test/Feature/NamedResolvers/deities.gql +3/−0
• test/Feature/NamedResolvers/entities.gql +6/−0
• test/Feature/NamedResolvers/realms.gql +3/−0
• test/Feature/NamedResolvers/tests/deity-scalars/query.gql +5/−0
• test/Feature/NamedResolvers/tests/deity-scalars/response.json +12/−0
• test/Feature/NamedResolvers/tests/realm-scalars/query.gql +5/−0
• test/Feature/NamedResolvers/tests/realm-scalars/response.json +12/−0

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-server-version:        0.26.0+version:        0.27.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -137,17 +137,20 @@     test/Feature/Input/variables/valueNotProvided/nonNullVariableWithDefaultValue/query.gql     test/Feature/Input/variables/valueNotProvided/nullableVariable/query.gql     test/Feature/NamedResolvers/deities.gql+    test/Feature/NamedResolvers/entities.gql     test/Feature/NamedResolvers/realms.gql     test/Feature/NamedResolvers/tests/deities-ext/query.gql     test/Feature/NamedResolvers/tests/deities/query.gql     test/Feature/NamedResolvers/tests/deity-by-id/query.gql     test/Feature/NamedResolvers/tests/deity-ext-by-id/query.gql+    test/Feature/NamedResolvers/tests/deity-scalars/query.gql     test/Feature/NamedResolvers/tests/deity-simple/query.gql     test/Feature/NamedResolvers/tests/entities/query.gql     test/Feature/NamedResolvers/tests/entity-by-id/query.gql     test/Feature/NamedResolvers/tests/entity-ext-by-id/query.gql     test/Feature/NamedResolvers/tests/realm-by-id/query.gql     test/Feature/NamedResolvers/tests/realm-ext-by-id/query.gql+    test/Feature/NamedResolvers/tests/realm-scalars/query.gql     test/Feature/NamedResolvers/tests/realm-simple/query.gql     test/Feature/NamedResolvers/tests/realms/query.gql     test/Feature/Collision/category-collision-fail/response.json@@ -286,12 +289,14 @@     test/Feature/NamedResolvers/tests/deities/response.json     test/Feature/NamedResolvers/tests/deity-by-id/response.json     test/Feature/NamedResolvers/tests/deity-ext-by-id/response.json+    test/Feature/NamedResolvers/tests/deity-scalars/response.json     test/Feature/NamedResolvers/tests/deity-simple/response.json     test/Feature/NamedResolvers/tests/entities/response.json     test/Feature/NamedResolvers/tests/entity-by-id/response.json     test/Feature/NamedResolvers/tests/entity-ext-by-id/response.json     test/Feature/NamedResolvers/tests/realm-by-id/response.json     test/Feature/NamedResolvers/tests/realm-ext-by-id/response.json+    test/Feature/NamedResolvers/tests/realm-scalars/response.json     test/Feature/NamedResolvers/tests/realm-simple/response.json     test/Feature/NamedResolvers/tests/realms/response.json @@ -314,6 +319,7 @@       Data.Morpheus.Server.Deriving.Named.EncodeType       Data.Morpheus.Server.Deriving.Named.EncodeValue       Data.Morpheus.Server.Deriving.Schema+      Data.Morpheus.Server.Deriving.Schema.DeriveKinded       Data.Morpheus.Server.Deriving.Schema.Directive       Data.Morpheus.Server.Deriving.Schema.Enum       Data.Morpheus.Server.Deriving.Schema.Internal@@ -327,6 +333,7 @@       Data.Morpheus.Server.Deriving.Utils.Kinded       Data.Morpheus.Server.Deriving.Utils.Proxy       Data.Morpheus.Server.Deriving.Utils.Types+      Data.Morpheus.Server.Deriving.Utils.Use       Data.Morpheus.Server.NamedResolvers       Data.Morpheus.Server.Playground       Data.Morpheus.Server.Types.DirectiveDefinitions@@ -347,8 +354,8 @@     , base >=4.7.0 && <5.0.0     , bytestring >=0.10.4 && <0.12.0     , containers >=0.4.2.1 && <0.7.0-    , morpheus-graphql-app >=0.26.0 && <0.27.0-    , morpheus-graphql-core >=0.26.0 && <0.27.0+    , morpheus-graphql-app >=0.27.0 && <0.28.0+    , morpheus-graphql-core >=0.27.0 && <0.28.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0@@ -386,9 +393,11 @@       Feature.NamedResolvers.DB       Feature.NamedResolvers.Deities       Feature.NamedResolvers.DeitiesApp+      Feature.NamedResolvers.Entities       Feature.NamedResolvers.EntitiesApp       Feature.NamedResolvers.Realms       Feature.NamedResolvers.RealmsApp+      Feature.NamedResolvers.Scalars       Paths_morpheus_graphql_server   hs-source-dirs:       test@@ -399,11 +408,11 @@     , bytestring >=0.10.4 && <0.12.0     , containers >=0.4.2.1 && <0.7.0     , file-embed >=0.0.10 && <1.0.0-    , morpheus-graphql-app >=0.26.0 && <0.27.0-    , morpheus-graphql-core >=0.26.0 && <0.27.0+    , morpheus-graphql-app >=0.27.0 && <0.28.0+    , morpheus-graphql-core >=0.27.0 && <0.28.0     , morpheus-graphql-server-    , morpheus-graphql-subscriptions >=0.26.0 && <0.27.0-    , morpheus-graphql-tests >=0.26.0 && <0.27.0+    , morpheus-graphql-subscriptions >=0.27.0 && <0.28.0+    , morpheus-graphql-tests >=0.27.0 && <0.28.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , tasty >=0.1.0 && <1.5.0

@@ -6,7 +6,5 @@ where  import Data.Data (Typeable)--- add type class instances-import Data.Morpheus.Server.Deriving.App () import Data.Text (Text) import GHC.Generics (Generic)

@@ -42,8 +42,8 @@     DeriveWith,     deriveValue,   )-import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (..), kinded)-import Data.Morpheus.Server.Types.GQLType (GQLType, deriveTypename, __typeData)+import Data.Morpheus.Server.Deriving.Utils.Kinded (CatType (..), outputType)+import Data.Morpheus.Server.Types.GQLType (GQLType, deriveTypename, withDir, __typeData) import Data.Morpheus.Server.Types.Types (Undefined) import Data.Morpheus.Types.Internal.AST   ( FieldName,@@ -132,23 +132,19 @@ class ExploreChannels (t :: Bool) e a where   exploreChannels :: f t -> a -> HashMap FieldName (ChannelRes e) -class (GQLType a, GetChannel e a) => ChannelConstraint e a--instance (GetChannel e a, GQLType a) => ChannelConstraint e a--instance (GQLType a, Generic a, DeriveWith (ChannelConstraint e) (ChannelRes e) (Rep a)) => ExploreChannels 'False e a where+instance (GQLType a, Generic a, DeriveWith GQLType (GetChannel e) (ChannelRes e) (Rep a)) => ExploreChannels 'False e a where   exploreChannels _ =     HM.fromList-      . map (toFieldRes (Proxy @a))+      . map (toFieldRes withDir (Proxy @a))       . consFields       . tyCons       . deriveValue         ( DeriveValueOptions             { __valueApply = getChannel,-              __valueTypeName = deriveTypename (KindedProxy :: KindedProxy OUT a),-              __valueGetType = __typeData . kinded (Proxy @OUT)+              __valueTypeName = deriveTypename (OutputType :: CatType OUT a),+              __valueGetType = __typeData . outputType             } ::-            DeriveValueOptions OUT (ChannelConstraint e) (ChannelRes e)+            DeriveValueOptions OUT GQLType (GetChannel e) (ChannelRes e)         )  instance ExploreChannels 'True e (Undefined m) where

@@ -45,13 +45,12 @@     withScalar,   ) import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( KindedProxy (..),+  ( CatType (..),   ) import Data.Morpheus.Server.Types.GQLType-  ( GQLType-      ( KIND-      ),+  ( GQLType (..),     deriveTypename,+    withDir,   ) import Data.Morpheus.Server.Types.Kind   ( CUSTOM,@@ -72,7 +71,6 @@   ( Argument (..),     Arguments,     IN,-    LEAF,     Object,     ObjectEntry (..),     TypeName,@@ -104,24 +102,18 @@  -- SCALAR instance (DecodeScalar a, GQLType a) => DecodeKind SCALAR a where-  decodeKind _ = withScalar (deriveTypename (KindedProxy :: KindedProxy LEAF a)) decodeScalar+  decodeKind _ = withScalar (deriveTypename (InputType :: CatType IN a)) decodeScalar  -- INPUT_OBJECT and  INPUT_UNION-instance-  ( Generic a,-    GQLType a,-    DecodeRep (Rep a)-  ) =>-  DecodeKind TYPE a-  where+instance (Generic a, GQLType a, DecodeRep (Rep a)) => DecodeKind TYPE a where   decodeKind _ = fmap to . (`runReaderT` context) . decodeRep     where       context =         Context           { isVariantRef = False,-            typeName = deriveTypename (KindedProxy :: KindedProxy IN a),-            enumVisitor = visitEnumName proxy,-            fieldVisitor = visitFieldName proxy+            typeName = deriveTypename (InputType :: CatType IN a),+            enumVisitor = visitEnumName withDir proxy,+            fieldVisitor = visitFieldName withDir proxy           }         where           proxy = Proxy @a

@@ -57,7 +57,10 @@     DeriveWith,     deriveValue,   )-import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (KindedProxy), kinded)+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatType (..),+    inputType,+  ) import Data.Morpheus.Server.Resolvers   ( RootResolver (..),   )@@ -65,6 +68,7 @@   ( GQLType,     KIND,     deriveTypename,+    withDir,     __isEmptyType,     __typeData,   )@@ -184,20 +188,17 @@       encodeTypeFields ::         [FieldRep (m (ResolverValue m))] ->         ResolverValue m-      encodeTypeFields [] = mkEnum (visitEnumName proxy consName)+      encodeTypeFields [] = mkEnum (visitEnumName withDir proxy consName)       encodeTypeFields fields-        | not tyIsUnion = mkObject dataTypeName (toFieldRes proxy <$> fields)+        | not tyIsUnion = mkObject dataTypeName (toFieldRes withDir proxy <$> fields)       -- Type References --------------------------------------------------------------       encodeTypeFields [FieldRep {fieldTypeRef, fieldValue}]         | isUnionRef dataTypeName cons = ResLazy (ResObject (Just (typeConName fieldTypeRef)) <$> (fieldValue >>= requireObject))       -- Inline Union Types -----------------------------------------------------------------------------      encodeTypeFields fields = mkUnion consName (toFieldRes proxy <$> fields)+      encodeTypeFields fields = mkUnion consName (toFieldRes withDir proxy <$> fields)  -- Types & Constrains --------------------------------------------------------class (Encode m a, GQLType a) => ExplorerConstraint m a -instance (Encode m a, GQLType a) => ExplorerConstraint m a- exploreResolvers ::   forall m a.   ( EncodeConstraint m a,@@ -210,10 +211,10 @@     . deriveValue       ( DeriveValueOptions           { __valueApply = encode,-            __valueTypeName = deriveTypename (KindedProxy :: KindedProxy IN a),-            __valueGetType = __typeData . kinded (Proxy @IN)+            __valueTypeName = deriveTypename (InputType :: CatType IN a),+            __valueGetType = __typeData . inputType           } ::-          DeriveValueOptions IN (ExplorerConstraint m) (m (ResolverValue m))+          DeriveValueOptions IN GQLType (Encode m) (m (ResolverValue m))       )  ----- HELPERS ----------------------------@@ -228,7 +229,7 @@ type EncodeConstraint (m :: Type -> Type) a =   ( GQLType a,     Generic a,-    DeriveWith (ExplorerConstraint m) (m (ResolverValue m)) (Rep a)+    DeriveWith GQLType (Encode m) (m (ResolverValue m)) (Rep a)   )  type EncodeObjectConstraint (o :: OperationType) e (m :: Type -> Type) a =

@@ -21,6 +21,7 @@ import Data.Morpheus.App.Internal.Resolving   ( LiftOperation,     NamedResolver (..),+    NamedResolverResult (..),     Resolver,     liftResolverState,   )@@ -48,6 +49,7 @@     TYPE,     WRAPPER,   )+import Data.Morpheus.Types.GQLScalar (EncodeScalar (..)) import Data.Morpheus.Types.Internal.AST   ( ValidValue,   )@@ -71,33 +73,51 @@ class DeriveNamedResolver (m :: Type -> Type) (k :: DerivingKind) a where   deriveNamedResolver :: f k a -> [NamedResolver m] -instance DeriveNamedResolver m SCALAR a where-  deriveNamedResolver _ = []+instance+  ( GQLType a,+    DecodeValuesConstraint o e m a,+    EncodeScalar a+  ) =>+  DeriveNamedResolver (Resolver o e m) SCALAR a+  where+  deriveNamedResolver _ =+    [ NamedResolver+        { resolverName = getTypeName proxy,+          resolverFun = decodeValues proxy >=> pure . map (maybe NamedNullResolver (NamedScalarResolver . encodeScalar))+        }+    ]+    where+      proxy = Proxy @a +type DecodeValuesConstraint o e m a =+  ( LiftOperation o,+    ResolveNamed (Resolver o e m) a,+    Monad m,+    Decode (Dependency a)+  )++decodeValues :: forall o e m a. DecodeValuesConstraint o e m a => Proxy a -> [ValidValue] -> Resolver o e m [Maybe a]+decodeValues _ xs = traverse decodeArg xs >>= resolveBatched+  where+    decodeArg :: ValidValue -> Resolver o e m (Dependency a)+    decodeArg = liftResolverState . decode+ instance-  ( Monad m,-    LiftOperation o,-    Generic a,-    GQLType a,+  ( GQLType a,+    DecodeValuesConstraint o e m a,     EncodeFieldKind (KIND a) (Resolver o e m) a,-    Decode (Dependency a),-    ResolveNamed (Resolver o e m) a,     FieldConstraint (Resolver o e m) a   ) =>   DeriveNamedResolver (Resolver o e m) TYPE (a :: Type)   where   deriveNamedResolver _ =     [ NamedResolver-        { resolverName = getTypeName (Proxy @a),-          resolverFun = resolve >=> encodeResolverValue+        { resolverName = getTypeName proxy,+          resolverFun = decodeValues proxy >=> encodeResolverValue         }     ]     where-      resolve :: [ValidValue] -> Resolver o e m [Maybe a]-      resolve xs = traverse decodeArg xs >>= resolveBatched--      decodeArg :: ValidValue -> Resolver o e m (Dependency a)-      decodeArg = liftResolverState . decode+      proxy = Proxy @a  instance DeriveNamedResolver m (KIND a) a => DeriveNamedResolver m CUSTOM (NamedResolverT m a) where   deriveNamedResolver _ = deriveNamedResolver (KindedProxy :: KindedProxy (KIND a) a)

@@ -57,13 +57,14 @@   ) import Data.Morpheus.Server.Deriving.Utils.Kinded import Data.Morpheus.Server.NamedResolvers-  ( Dependency,+  ( NamedRef,     NamedResolverT (..),   ) import Data.Morpheus.Server.Types.GQLType   ( GQLType (__type),     KIND,     deriveTypename,+    withDir,     __typeData,   ) import Data.Morpheus.Server.Types.Internal@@ -84,6 +85,8 @@     OUT,     TypeCategory (OUT),     TypeName,+    ValidValue,+    Value (List),     internal,     replaceValue,   )@@ -102,7 +105,7 @@ type FieldConstraint m a =   ( GQLType a,     Generic a,-    DeriveWith (GValueMapConstraint m) (m (ResolverValue m)) (Rep a)+    DeriveWith GQLType (Encode m) (m (ResolverValue m)) (Rep a)   )  class Encode (m :: Type -> Type) res where@@ -131,7 +134,7 @@   ( Monad m,     GQLType a,     EncodeFieldKind (KIND a) m a,-    ToJSON (Dependency a)+    ToJSON (NamedRef a)   ) =>   EncodeFieldKind CUSTOM m (NamedResolverT m a)   where@@ -140,16 +143,17 @@       name :: TypeName       name = getTypeName (Proxy @a)       encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m)-      encodeRef (Ref x) = pure $ ResRef $ packRef name <$> x-      encodeRef (Value value) = value >>= encodeField-      encodeRef (Refs refs) = mkList . map (ResRef . pure . packRef name) <$> refs+      encodeRef (NamedResolverT ref) = do+        value <- replaceValue . toJSON <$> ref+        case value of+          (List ls) -> pure $ mkList $ map (packRef name) ls+          _ -> pure $ packRef name value -packRef :: ToJSON a => TypeName -> a -> NamedResolverRef-packRef name v = NamedResolverRef name [replaceValue $ toJSON v]+packRef :: Applicative m => TypeName -> ValidValue -> ResolverValue m+packRef name v = ResRef $ pure $ NamedResolverRef name [v]  instance   ( Decode a,-    Generic a,     Monad m,     Encode (Resolver o e m) b,     LiftOperation o@@ -161,19 +165,15 @@       >>= liftResolverState . decodeArguments       >>= encodeField . f -class (Encode m a, GQLType a) => GValueMapConstraint m a--instance (Encode m a, GQLType a) => GValueMapConstraint m a- getFieldValues :: forall m a. FieldConstraint m a => a -> DataType (m (ResolverValue m)) getFieldValues =   deriveValue     ( DeriveValueOptions         { __valueApply = encodeField,-          __valueTypeName = deriveTypename (KindedProxy :: KindedProxy OUT a),-          __valueGetType = __typeData . kinded (Proxy @OUT)+          __valueTypeName = deriveTypename (OutputType :: CatType OUT a),+          __valueGetType = __typeData . outputType         } ::-        DeriveValueOptions OUT (GValueMapConstraint m) (m (ResolverValue m))+        DeriveValueOptions OUT GQLType (Encode m) (m (ResolverValue m))     )  convertNamedNode ::@@ -193,7 +193,7 @@         pure $           NamedObjectResolver             ObjectTypeResolver-              { objectFields = HM.fromList (toFieldRes proxy <$> consFields)+              { objectFields = HM.fromList (toFieldRes withDir proxy <$> consFields)               }  deriveUnion :: (MonadError GQLError m) => [FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)

@@ -4,8 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -13,7 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wno-orphans #-}  module Data.Morpheus.Server.Deriving.Schema   ( compileTimeSchemaValidation,@@ -24,103 +21,55 @@   ) where -import Control.Monad.Except (throwError) import Data.Morpheus.App.Internal.Resolving   ( Resolver,   ) import Data.Morpheus.Core (defaultConfig, validateSchema) import Data.Morpheus.Internal.Ext-import Data.Morpheus.Internal.Utils (singleton)+import Data.Morpheus.Server.Deriving.Schema.DeriveKinded+  ( DERIVE_TYPE,+    toFieldContent,+  ) import Data.Morpheus.Server.Deriving.Schema.Internal-  ( KindedType (..),-    TyContentM,-    fromSchema,+  ( fromSchema,   ) import Data.Morpheus.Server.Deriving.Schema.Object   ( asObjectType,-    withObject,   ) import Data.Morpheus.Server.Deriving.Schema.TypeContent-import Data.Morpheus.Server.Deriving.Utils-  ( DeriveTypeOptions (..),-    DeriveWith,-    symbolName,-  ) import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CategoryValue (..),-    KindedProxy (..),-    inputType,-    kinded,+  ( CatContext (OutputContext),     outputType,-    setKind,   ) import Data.Morpheus.Server.Types.GQLType-  ( DeriveArguments (..),+  ( DeriveType,     GQLType (..),-    deriveTypename,+    withDeriveType,+    withDir,+    withGQL,     __isEmptyType,-    __typeData,   )-import Data.Morpheus.Server.Types.Internal (TypeData (..))-import Data.Morpheus.Server.Types.Kind-  ( CUSTOM,-    DerivingKind,-    SCALAR,-    TYPE,-    WRAPPER,-  ) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,-    extendImplements,     toSchema,-    withInput,   )-import Data.Morpheus.Server.Types.Types-  ( Arg (..),-    TypeGuard,-  )-import Data.Morpheus.Types.GQLScalar-  ( DecodeScalar (..),-    scalarValidator,-  ) import Data.Morpheus.Types.Internal.AST   ( CONST,-    FieldContent (..),-    FieldsDefinition,-    IN,-    LEAF,     MUTATION,     OBJECT,     OUT,     QUERY,     SUBSCRIPTION,-    ScalarDefinition (..),     Schema (..),-    TRUE,-    TypeCategory,-    TypeContent (..),     TypeDefinition (..),-    TypeName,-    TypeRef (..),-    UnionMember (memberName),-    Value,-    fieldsToArguments,-    mkField,   )-import GHC.Generics-import GHC.TypeLits import Language.Haskell.TH (Exp, Q) import Relude  type SchemaConstraints event (m :: Type -> Type) query mutation subscription =-  ( DeriveTypeConstraintOpt OUT (query (Resolver QUERY event m)),-    DeriveTypeConstraintOpt OUT (mutation (Resolver MUTATION event m)),-    DeriveTypeConstraintOpt OUT (subscription (Resolver SUBSCRIPTION event m))-  )--type DeriveTypeConstraintOpt kind a =-  ( GQLType a,-    DeriveWith (DeriveWithConstraint kind) (TyContentM kind) (Rep a)+  ( DERIVE_TYPE GQLType DeriveType OUT (query (Resolver QUERY event m)),+    DERIVE_TYPE GQLType DeriveType OUT (mutation (Resolver MUTATION event m)),+    DERIVE_TYPE GQLType DeriveType OUT (subscription (Resolver SUBSCRIPTION event m))   )  -- | normal morpheus server validates schema at runtime (after the schema derivation).@@ -160,142 +109,12 @@         <*> deriveMaybeRoot (Proxy @(mut (Resolver MUTATION e m)))         <*> deriveMaybeRoot (Proxy @(subs (Resolver SUBSCRIPTION e m))) --- |  Generates internal GraphQL Schema for query validation and introspection rendering-class DeriveType (kind :: TypeCategory) (a :: Type) where-  deriveType :: f a -> SchemaT kind ()-  deriveContent :: f a -> TyContentM kind--instance (GQLType a, DeriveKindedType cat (KIND a) a) => DeriveType cat a where-  deriveType _ = deriveKindedType (KindedProxy :: KindedProxy (KIND a) a)-  deriveContent _ = deriveKindedContent (KindedProxy :: KindedProxy (KIND a) a)---- | DeriveType With specific Kind: 'kind': object, scalar, enum ...-class DeriveKindedType (cat :: TypeCategory) (kind :: DerivingKind) a where-  deriveKindedType :: kinded kind a -> SchemaT cat ()-  deriveKindedContent :: kinded kind a -> TyContentM cat-  deriveKindedContent _ = pure Nothing--type DeriveTypeConstraint kind a =-  ( DeriveTypeConstraintOpt kind a,-    CategoryValue kind-  )--instance (GQLType a, DeriveType cat a) => DeriveKindedType cat WRAPPER (f a) where-  deriveKindedType _ = deriveType (KindedProxy :: KindedProxy cat a)--instance (GQLType a, DecodeScalar a) => DeriveKindedType cat SCALAR a where-  deriveKindedType = insertTypeContent deriveScalarContent . setKind (Proxy @LEAF)--instance DeriveTypeConstraint OUT a => DeriveKindedType OUT TYPE a where-  deriveKindedType = deriveOutputType--instance DeriveTypeConstraint IN a => DeriveKindedType IN TYPE a where-  deriveKindedType = deriveInputType--instance DeriveType cat a => DeriveKindedType cat CUSTOM (Resolver o e m a) where-  deriveKindedType _ = deriveType (Proxy @a)--instance DeriveKindedType cat CUSTOM (Value CONST) where-  deriveKindedType = insertTypeContent (const $ pure $ DataScalar $ ScalarDefinition pure) . setKind (Proxy @LEAF)--instance DeriveType cat [(k, v)] => DeriveKindedType cat CUSTOM (Map k v) where-  deriveKindedType _ = deriveType (Proxy @[(k, v)])--instance-  ( DeriveTypeConstraint OUT interface,-    DeriveTypeConstraint OUT union-  ) =>-  DeriveKindedType OUT CUSTOM (TypeGuard interface union)-  where-  deriveKindedType _ = do-    insertTypeContent deriveInterfaceContent interfaceProxy-    content <- deriveTypeContent (OutputType :: KindedType OUT union)-    unionNames <- getUnionNames content-    extendImplements interfaceName unionNames-    where-      interfaceName :: TypeName-      interfaceName = deriveTypename interfaceProxy-      interfaceProxy :: KindedProxy OUT interface-      interfaceProxy = KindedProxy-      unionProxy :: KindedProxy OUT union-      unionProxy = KindedProxy-      getUnionNames :: TypeContent TRUE OUT CONST -> SchemaT OUT [TypeName]-      getUnionNames DataUnion {unionMembers} = pure $ toList $ memberName <$> unionMembers-      getUnionNames DataObject {} = pure [deriveTypename unionProxy]-      getUnionNames _ = throwError "guarded type must be an union or object"--instance-  ( GQLType b,-    DeriveKindedType OUT (KIND b) b,-    DeriveArguments (KIND a) a-  ) =>-  DeriveKindedType OUT CUSTOM (a -> b)-  where-  deriveKindedContent _ = do-    a <- deriveArgumentsDefinition (KindedProxy :: KindedProxy (KIND a) a)-    b <- deriveKindedContent (KindedProxy :: KindedProxy (KIND b) b)-    case b of-      Just (FieldArgs x) -> Just . FieldArgs <$> (a <:> x)-      Nothing -> pure $ Just (FieldArgs a)-  deriveKindedType _ = deriveType (outputType $ Proxy @b)--deriveScalarContent :: (DecodeScalar a) => f k a -> SchemaT cat (TypeContent TRUE LEAF CONST)-deriveScalarContent = pure . DataScalar . scalarValidator--deriveInterfaceContent :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT (TypeContent TRUE OUT CONST)-deriveInterfaceContent = fmap DataInterface . deriveFields . outputType--instance DeriveTypeConstraint IN a => DeriveArguments TYPE a where-  deriveArgumentsDefinition = withInput . fmap fieldsToArguments . deriveFields . inputType--instance (KnownSymbol name, DeriveType IN a, GQLType a) => DeriveArguments CUSTOM (Arg name a) where-  deriveArgumentsDefinition _ = do-    withInput (deriveType proxy)-    pure $ fieldsToArguments $ singleton argName $ mkField Nothing argName argTypeRef-    where-      proxy :: KindedProxy IN a-      proxy = KindedProxy-      argName = symbolName (Proxy @name)-      argTypeRef = TypeRef {typeConName = gqlTypeName, typeWrappers = gqlWrappers}-      TypeData {gqlTypeName, gqlWrappers} = __typeData proxy--deriveFields :: DeriveTypeConstraint kind a => KindedType kind a -> SchemaT kind (FieldsDefinition kind CONST)-deriveFields kindedType = deriveTypeContent kindedType >>= withObject kindedType--deriveInputType :: DeriveTypeConstraint IN a => f a -> SchemaT IN ()-deriveInputType = insertTypeContent deriveTypeContent . inputType--deriveOutputType :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT ()-deriveOutputType = insertTypeContent deriveTypeContent . outputType--deriveRoot :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT (TypeDefinition OBJECT CONST)-deriveRoot = asObjectType (deriveFields . outputType)+-- -deriveMaybeRoot :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT (Maybe (TypeDefinition OBJECT CONST))+deriveMaybeRoot :: DERIVE_TYPE GQLType DeriveType OUT a => f a -> SchemaT OUT (Maybe (TypeDefinition OBJECT CONST)) deriveMaybeRoot proxy   | __isEmptyType proxy = pure Nothing-  | otherwise = Just <$> asObjectType (deriveFields . outputType) proxy--deriveFieldContent :: forall f kind a. (DeriveType kind a) => f a -> TyContentM kind-deriveFieldContent _ = deriveType kindedProxy *> deriveContent kindedProxy-  where-    kindedProxy :: KindedProxy kind a-    kindedProxy = KindedProxy--class (GQLType a, DeriveType k a) => DeriveWithConstraint k a--instance (GQLType a, DeriveType k a) => DeriveWithConstraint k a+  | otherwise = Just <$> asObjectType withGQL (deriveFieldsWith withDir (toFieldContent OutputContext withDir withDeriveType) . outputType) proxy -deriveTypeContent ::-  forall kind a.-  DeriveTypeConstraint kind a =>-  KindedType kind a ->-  SchemaT kind (TypeContent TRUE kind CONST)-deriveTypeContent =-  deriveTypeContentWith-    ( DeriveTypeDefinitionOptions-        { __typeGetType = __typeData . kinded (Proxy @kind),-          __typeApply = deriveFieldContent-        } ::-        DeriveTypeOptions kind (DeriveWithConstraint kind) (TyContentM kind)-    )+deriveRoot :: DERIVE_TYPE GQLType DeriveType OUT a => f a -> SchemaT OUT (TypeDefinition OBJECT CONST)+deriveRoot = asObjectType withGQL (deriveFieldsWith withDir (toFieldContent OutputContext withDir withDeriveType) . outputType)

@@ -0,0 +1,176 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Schema.DeriveKinded+  ( DeriveKindedType (..),+    DeriveArgs (..),+    toFieldContent,+    DERIVE_TYPE,+  )+where++import Control.Monad.Except (throwError)+import Data.Morpheus.App.Internal.Resolving+  ( Resolver,+  )+import Data.Morpheus.Internal.Ext+import Data.Morpheus.Internal.Utils (singleton)+import Data.Morpheus.Server.Deriving.Schema.Internal+  ( CatType,+    TyContentM,+  )+import Data.Morpheus.Server.Deriving.Schema.TypeContent+import Data.Morpheus.Server.Deriving.Utils+  ( DeriveTypeOptions (..),+    DeriveWith,+    symbolName,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CatContext (..),+    CatType (..),+    addContext,+    catMap,+    getCat,+    getCatContext,+    inputType,+    mkScalar,+    outputType,+    unliftKind,+  )+import Data.Morpheus.Server.Deriving.Utils.Use+import Data.Morpheus.Server.Types.Internal (TypeData (..))+import Data.Morpheus.Server.Types.Kind+  ( CUSTOM,+    DerivingKind,+    SCALAR,+    TYPE,+    WRAPPER,+  )+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+    extendImplements,+  )+import Data.Morpheus.Server.Types.Types+  ( Arg (..),+    TypeGuard,+  )+import Data.Morpheus.Types.GQLScalar+  ( DecodeScalar (..),+    scalarValidator,+  )+import Data.Morpheus.Types.Internal.AST+  ( ArgumentsDefinition,+    CONST,+    FieldContent (..),+    IN,+    OUT,+    ScalarDefinition (..),+    TRUE,+    TypeCategory (IN),+    TypeContent (..),+    TypeName,+    TypeRef (..),+    UnionMember (memberName),+    Value,+    fieldsToArguments,+    mkField,+  )+import GHC.Generics+import GHC.TypeLits+import Relude++type DERIVE_TYPE gql derive k a = (gql a, DeriveWith gql (derive k) (TyContentM k) (Rep a))++toFieldContent :: CatContext kind -> UseDirective gql dir -> UseDeriveType derive -> DeriveTypeOptions kind gql (derive kind) (TyContentM kind)+toFieldContent catCtx UseDirective {..} ops =+  DeriveTypeOptions+    { __typeGetType = \x -> __useTypeData dirGQL x (getCat catCtx),+      __typeApply = \proxy -> useDeriveType ops (addContext catCtx proxy) *> useDeriveContent ops (addContext catCtx proxy)+    }++-- | DeriveType With specific Kind: 'kind': object, scalar, enum ...+class DeriveKindedType gql derive dir (cat :: TypeCategory) (kind :: DerivingKind) a where+  deriveKindedType :: UseDirective gql dir -> UseDeriveType derive -> CatType cat (f kind a) -> SchemaT cat ()+  deriveKindedContent :: UseDirective gql dir -> UseDeriveType derive -> CatType cat (f kind a) -> TyContentM cat+  deriveKindedContent _ _ _ = pure Nothing++instance (derive cat a) => DeriveKindedType gql derive dir cat WRAPPER (f a) where+  deriveKindedType _ UseDeriveType {..} = useDeriveType . catMap (Proxy @a)++instance (DecodeScalar a, gql a) => DeriveKindedType gql derive dir cat SCALAR a where+  deriveKindedType dirs _ proxy = insertTypeContent dirs (pure . mkScalar proxy . scalarValidator) (unliftKind proxy)++instance DERIVE_TYPE gql derive cat a => DeriveKindedType gql derive dir cat TYPE a where+  deriveKindedType dirs ops proxy = insertTypeContent dirs (deriveTypeContentWith dirs (toFieldContent (getCatContext proxy) dirs ops)) (unliftKind proxy)++instance (derive cat a) => DeriveKindedType gql derive dir cat CUSTOM (Resolver o e m a) where+  deriveKindedType _ UseDeriveType {..} = useDeriveType . catMap (Proxy @a)++instance (gql (Value CONST)) => DeriveKindedType gql derive dir cat CUSTOM (Value CONST) where+  deriveKindedType dirs _ proxy = insertTypeContent dirs (const $ pure $ mkScalar proxy $ ScalarDefinition pure) (unliftKind proxy)++instance (derive cat [(k, v)]) => DeriveKindedType gql derive dir cat CUSTOM (Map k v) where+  deriveKindedType _ UseDeriveType {..} = useDeriveType . catMap (Proxy @[(k, v)])++instance+  ( DERIVE_TYPE gql derive OUT interface,+    DERIVE_TYPE gql derive OUT union+  ) =>+  DeriveKindedType gql derive dir OUT CUSTOM (TypeGuard interface union)+  where+  deriveKindedType dir ops OutputType = do+    insertTypeContent dir (fmap DataInterface . deriveFieldsWith dir (toFieldContent OutputContext dir ops) . outputType) interfaceProxy+    content <- deriveTypeContentWith dir (toFieldContent OutputContext dir ops) (OutputType :: CatType OUT union)+    unionNames <- getUnionNames content+    extendImplements interfaceName unionNames+    where+      interfaceName :: TypeName+      interfaceName = useTypename (dirGQL dir) interfaceProxy+      interfaceProxy :: CatType OUT interface+      interfaceProxy = OutputType+      unionProxy :: CatType OUT union+      unionProxy = OutputType+      getUnionNames :: TypeContent TRUE OUT CONST -> SchemaT OUT [TypeName]+      getUnionNames DataUnion {unionMembers} = pure $ toList $ memberName <$> unionMembers+      getUnionNames DataObject {} = pure [useTypename (dirGQL dir) unionProxy]+      getUnionNames _ = throwError "guarded type must be an union or object"++instance (derive OUT b, dir a) => DeriveKindedType gql derive dir OUT CUSTOM (a -> b) where+  deriveKindedContent dir UseDeriveType {..} OutputType = do+    a <- useDeriveArguments (dirArgs dir) (Proxy @a)+    b <- useDeriveContent (OutputType :: CatType OUT b)+    case b of+      Just (FieldArgs x) -> Just . FieldArgs <$> (a <:> x)+      Nothing -> pure $ Just (FieldArgs a)+  deriveKindedType _ UseDeriveType {..} OutputType = useDeriveType (outputType $ Proxy @b)++class DeriveArgs gql derive (k :: DerivingKind) a where+  deriveArgs :: UseDirective gql dir -> UseDeriveType derive -> f k a -> SchemaT IN (ArgumentsDefinition CONST)++instance (DERIVE_TYPE gql derive IN a) => DeriveArgs gql derive TYPE a where+  deriveArgs dir ops = fmap fieldsToArguments . deriveFieldsWith dir (toFieldContent InputContext dir ops) . inputType++instance (KnownSymbol name, derive IN a, gql a) => DeriveArgs gql derive CUSTOM (Arg name a) where+  deriveArgs dir ops _ = do+    useDeriveType ops proxy+    pure $ fieldsToArguments $ singleton argName $ mkField Nothing argName argTypeRef+    where+      proxy :: CatType IN a+      proxy = InputType+      argName = symbolName (Proxy @name)+      argTypeRef = TypeRef {typeConName = gqlTypeName, typeWrappers = gqlWrappers}+      TypeData {gqlTypeName, gqlWrappers} = __useTypeData (dirGQL dir) proxy IN

@@ -26,6 +26,7 @@     visitEnumName,     visitFieldName,     toFieldRes,+    UseDirective (..),   ) where @@ -33,20 +34,19 @@ import Data.Morpheus.Internal.Ext (unsafeFromList) import Data.Morpheus.Internal.Utils (Empty (..), fromElems) import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( KindedProxy (..),-    KindedType (..),+  ( CatType (..),+    KindedProxy (..),   ) import Data.Morpheus.Server.Deriving.Utils.Types (FieldRep (..))-import Data.Morpheus.Server.Types.Directives-  ( GQLDirective (..),-    ToLocations,-    getLocations,+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseArguments (..),+    UseDirective (..),+    UseGQLType (..),   )-import Data.Morpheus.Server.Types.GQLType-  ( DeriveArguments (..),-    DirectiveUsage (..),-    DirectiveUsages (..),-    GQLType (..),+import Data.Morpheus.Server.Types.Directives+  ( GDirectiveUsage (..),+    GDirectiveUsages (..),+    GQLDirective (..),     applyEnumDescription,     applyEnumName,     applyFieldDefaultValue,@@ -55,9 +55,7 @@     applyTypeDescription,     applyTypeEnumNames,     applyTypeFieldNames,-    deriveFingerprint,-    deriveTypename,-    encodeArguments,+    getLocations,   ) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,@@ -76,6 +74,7 @@     IN,     Position (Position),     TRUE,+    TypeCategory (..),     TypeName,     Value,   )@@ -83,25 +82,19 @@ import GHC.TypeLits () import Relude hiding (empty) -type DirectiveDefinitionConstraint a =-  ( GQLDirective a,-    GQLType a,-    DeriveArguments (KIND a) a,-    ToLocations (DIRECTIVE_LOCATIONS a)-  )- deriveDirectiveDefinition ::-  forall a b kind.-  (DirectiveDefinitionConstraint a) =>+  forall a b kind gql args.+  (gql a, GQLDirective a, args a) =>+  UseDirective gql args ->   a ->   b ->   SchemaT kind (DirectiveDefinition CONST)-deriveDirectiveDefinition _ _ = do-  directiveDefinitionArgs <- outToAny (deriveArgumentsDefinition (KindedProxy :: KindedProxy (KIND a) a))+deriveDirectiveDefinition options _ _ = do+  directiveDefinitionArgs <- outToAny (useDeriveArguments (dirArgs options) (Proxy @a))   pure     ( DirectiveDefinition-        { directiveDefinitionName = deriveDirectiveName proxy,-          directiveDefinitionDescription = visitTypeDescription proxy Nothing,+        { directiveDefinitionName = deriveDirectiveName (dirGQL options) proxy,+          directiveDefinitionDescription = visitTypeDescription options proxy Nothing,           directiveDefinitionArgs,           directiveDefinitionLocations = getLocations proxy         }@@ -109,17 +102,17 @@   where     proxy = Proxy @a -deriveDirectiveUsages :: [DirectiveUsage] -> SchemaT c (Directives CONST)-deriveDirectiveUsages = fmap unsafeFromList . traverse toDirectiveTuple--deriveDirectiveName :: forall f a. GQLType a => f a -> FieldName-deriveDirectiveName _ = coerce $ deriveTypename (KindedProxy :: KindedProxy IN a)+deriveDirectiveUsages :: UseDirective gql args -> [GDirectiveUsage gql args] -> SchemaT kind (Directives CONST)+deriveDirectiveUsages options = fmap unsafeFromList . traverse (toDirectiveTuple options) -toDirectiveTuple :: DirectiveUsage -> SchemaT c (FieldName, Directive CONST)-toDirectiveTuple (DirectiveUsage x) = do-  insertDirective (deriveDirectiveDefinition x) x-  let directiveName = deriveDirectiveName (Identity x)-  args <- toList <$> encodeArguments x+toDirectiveTuple ::+  UseDirective gql args ->+  GDirectiveUsage gql args ->+  SchemaT kind (FieldName, Directive CONST)+toDirectiveTuple options (GDirectiveUsage x) = do+  insertDirective options (deriveDirectiveDefinition options x) x+  let directiveName = deriveDirectiveName (dirGQL options) (Identity x)+  args <- toList <$> useEncodeArguments (dirArgs options) x   directiveArgs <- fromElems (map editArg args)   pure     ( directiveName,@@ -130,75 +123,82 @@         }     )   where-    editArg Argument {..} = Argument {argumentName = applyGQLFieldOptions (Identity x) argumentName, ..}+    editArg Argument {..} = Argument {argumentName = applyGQLFieldOptions options (Identity x) argumentName, ..}  insertDirective ::-  forall a c.-  (GQLType a) =>-  (KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST)) ->+  forall gql args a k.+  gql a =>+  UseDirective gql args ->+  (KindedProxy IN a -> SchemaT k (DirectiveDefinition CONST)) ->   a ->-  SchemaT c ()-insertDirective f _ = insertDirectiveDefinition (deriveFingerprint proxy) f proxy+  SchemaT k ()+insertDirective ops f _ = insertDirectiveDefinition (__useFingerprint (dirGQL ops) IN (Proxy :: Proxy a)) f proxy   where     proxy = KindedProxy :: KindedProxy IN a  getDirHM :: (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a getDirHM name xs = fromMaybe empty $ name `HM.lookup` xs -isIncluded :: DirectiveUsage -> Bool-isIncluded (DirectiveUsage x) = not $ excludeFromSchema (Identity x)+isIncluded :: GDirectiveUsage gql args -> Bool+isIncluded (GDirectiveUsage x) = not $ excludeFromSchema (Identity x) -getEnumDirectiveUsages :: GQLType a => f a -> TypeName -> [DirectiveUsage]-getEnumDirectiveUsages proxy name = getDirHM name $ enumValueDirectives $ directives proxy+getEnumDirectiveUsages :: gql a => UseDirective gql args -> f a -> TypeName -> [GDirectiveUsage gql args]+getEnumDirectiveUsages UseDirective {..} proxy name = getDirHM name $ enumValueDirectives $ __directives proxy -getFieldDirectiveUsages :: GQLType a => FieldName -> f a -> [DirectiveUsage]-getFieldDirectiveUsages name proxy = getDirHM name $ fieldDirectives $ directives proxy+getFieldDirectiveUsages :: gql a => UseDirective gql args -> FieldName -> f a -> [GDirectiveUsage gql args]+getFieldDirectiveUsages UseDirective {..} name proxy = getDirHM name $ fieldDirectives $ __directives proxy  -- derive directives-deriveEnumDirectives :: GQLType a => f a -> TypeName -> SchemaT c (Directives CONST)-deriveEnumDirectives proxy name = deriveDirectiveUsages $ filter isIncluded $ getEnumDirectiveUsages proxy name+deriveEnumDirectives :: gql a => UseDirective gql args -> f a -> TypeName -> SchemaT k (Directives CONST)+deriveEnumDirectives options proxy name = deriveDirectiveUsages options $ filter isIncluded $ getEnumDirectiveUsages options proxy name -deriveFieldDirectives :: GQLType a => f a -> FieldName -> SchemaT c (Directives CONST)-deriveFieldDirectives proxy name = deriveDirectiveUsages $ filter isIncluded $ getFieldDirectiveUsages name proxy+deriveFieldDirectives :: gql a => UseDirective gql args -> f a -> FieldName -> SchemaT kind (Directives CONST)+deriveFieldDirectives options proxy name = deriveDirectiveUsages options $ filter isIncluded $ getFieldDirectiveUsages options name proxy -deriveTypeDirectives :: forall c f a. GQLType a => f a -> SchemaT c (Directives CONST)-deriveTypeDirectives proxy = deriveDirectiveUsages $ filter isIncluded $ typeDirectives $ directives proxy+deriveTypeDirectives :: gql a => UseDirective gql args -> f a -> SchemaT kind (Directives CONST)+deriveTypeDirectives options proxy = deriveDirectiveUsages options $ filter isIncluded $ typeDirectives $ __directives options proxy  -- visit -visitEnumValueDescription :: GQLType a => f a -> TypeName -> Maybe Description -> Maybe Description-visitEnumValueDescription proxy name desc = foldr applyEnumDescription desc (getEnumDirectiveUsages proxy name)+visitEnumValueDescription :: gql a => UseDirective gql args -> f a -> TypeName -> Maybe Description -> Maybe Description+visitEnumValueDescription options proxy name desc = foldr applyEnumDescription desc (getEnumDirectiveUsages options proxy name) -visitEnumName :: GQLType a => f a -> TypeName -> TypeName-visitEnumName proxy name = foldr applyEnumName (withTypeDirectives name) (getEnumDirectiveUsages proxy name)+visitEnumName :: gql a => UseDirective gql args -> f a -> TypeName -> TypeName+visitEnumName options proxy name = foldr applyEnumName (withTypeDirectives name) (getEnumDirectiveUsages options proxy name)   where-    withTypeDirectives dirName = foldr applyTypeEnumNames dirName (typeDirectives $ directives proxy)+    withTypeDirectives dirName = foldr applyTypeEnumNames dirName (typeDirectives $ __directives options proxy) -visitFieldDescription :: GQLType a => f a -> FieldName -> Maybe Description -> Maybe Description-visitFieldDescription proxy name desc = foldr applyFieldDescription desc (getFieldDirectiveUsages name proxy)+visitFieldDescription :: gql a => UseDirective gql args -> f a -> FieldName -> Maybe Description -> Maybe Description+visitFieldDescription options proxy name desc = foldr applyFieldDescription desc (getFieldDirectiveUsages options name proxy) -visitFieldDefaultValue :: GQLType a => f a -> FieldName -> Maybe (Value CONST) -> Maybe (Value CONST)-visitFieldDefaultValue proxy name desc = foldr applyFieldDefaultValue desc (getFieldDirectiveUsages name proxy)+visitFieldDefaultValue :: gql a => UseDirective gql args -> f a -> FieldName -> Maybe (Value CONST) -> Maybe (Value CONST)+visitFieldDefaultValue options proxy name desc = foldr applyFieldDefaultValue desc (getFieldDirectiveUsages options name proxy)  visitFieldContent ::-  GQLType a =>-  KindedType kind a ->+  gql a =>+  UseDirective gql args ->+  CatType kind a ->   FieldName ->   Maybe (FieldContent TRUE kind CONST) ->   Maybe (FieldContent TRUE kind CONST)-visitFieldContent proxy@InputType name x = DefaultInputValue <$> visitFieldDefaultValue proxy name (defaultInputValue <$> x)-visitFieldContent OutputType _ x = x+visitFieldContent options proxy@InputType name x =+  DefaultInputValue+    <$> visitFieldDefaultValue options proxy name (defaultInputValue <$> x)+visitFieldContent _ OutputType _ x = x -applyGQLFieldOptions :: (GQLType a) => f a -> FieldName -> FieldName-applyGQLFieldOptions proxy = withTypeDirectives+applyGQLFieldOptions :: gql a => UseDirective gql args -> f a -> FieldName -> FieldName+applyGQLFieldOptions options proxy = withTypeDirectives   where-    withTypeDirectives name = foldr applyTypeFieldNames name (typeDirectives $ directives proxy)+    withTypeDirectives name = foldr applyTypeFieldNames name (typeDirectives $ __directives options proxy) -visitFieldName :: GQLType a => f a -> FieldName -> FieldName-visitFieldName proxy name = foldr applyFieldName (applyGQLFieldOptions proxy name) (getFieldDirectiveUsages name proxy)+visitFieldName :: gql a => UseDirective gql args -> f a -> FieldName -> FieldName+visitFieldName options proxy name = foldr applyFieldName (applyGQLFieldOptions options proxy name) (getFieldDirectiveUsages options name proxy) -visitTypeDescription :: GQLType a => f a -> Maybe Description -> Maybe Description-visitTypeDescription proxy desc = foldr applyTypeDescription desc (typeDirectives $ directives proxy)+visitTypeDescription :: gql a => UseDirective gql args -> f a -> Maybe Description -> Maybe Description+visitTypeDescription options proxy desc = foldr applyTypeDescription desc (typeDirectives $ __directives options proxy) -toFieldRes :: GQLType a => f a -> FieldRep v -> (FieldName, v)-toFieldRes proxy FieldRep {..} = (visitFieldName proxy fieldSelector, fieldValue)+toFieldRes :: gql a => UseDirective gql args -> f a -> FieldRep v -> (FieldName, v)+toFieldRes options proxy FieldRep {..} = (visitFieldName options proxy fieldSelector, fieldValue)++deriveDirectiveName :: gql a => UseGQLType gql -> f a -> FieldName+deriveDirectiveName options proxy = coerce $ __useTypename options IN proxy

@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} @@ -8,15 +9,13 @@ where  import Data.Morpheus.Server.Deriving.Schema.Directive-  ( deriveEnumDirectives,+  ( UseDirective,+    deriveEnumDirectives,     visitEnumName,     visitEnumValueDescription,   ) import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( KindedType (..),-  )-import Data.Morpheus.Server.Types.GQLType-  ( GQLType,+  ( CatType (..),   ) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,@@ -35,17 +34,17 @@     unitTypeName,   ) -buildEnumTypeContent :: GQLType a => KindedType kind a -> [TypeName] -> SchemaT c (TypeContent TRUE kind CONST)-buildEnumTypeContent p@InputType enumCons = DataEnum <$> traverse (mkEnumValue p) enumCons-buildEnumTypeContent p@OutputType enumCons = DataEnum <$> traverse (mkEnumValue p) enumCons+buildEnumTypeContent :: gql a => UseDirective gql args -> CatType kind a -> [TypeName] -> SchemaT k (TypeContent TRUE kind CONST)+buildEnumTypeContent options p@InputType enumCons = DataEnum <$> traverse (mkEnumValue options p) enumCons+buildEnumTypeContent options p@OutputType enumCons = DataEnum <$> traverse (mkEnumValue options p) enumCons -mkEnumValue :: GQLType a => f a -> TypeName -> SchemaT c (DataEnumValue CONST)-mkEnumValue proxy enumName = do-  enumDirectives <- deriveEnumDirectives proxy enumName+mkEnumValue :: gql a => UseDirective gql args -> f a -> TypeName -> SchemaT k (DataEnumValue CONST)+mkEnumValue options proxy enumName = do+  enumDirectives <- deriveEnumDirectives options proxy enumName   pure     DataEnumValue-      { enumName = visitEnumName proxy enumName,-        enumDescription = visitEnumValueDescription proxy enumName Nothing,+      { enumName = visitEnumName options proxy enumName,+        enumDescription = visitEnumValueDescription options proxy enumName Nothing,         ..       } 

@@ -19,7 +19,7 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Deriving.Schema.Internal-  ( KindedType (..),+  ( CatType (..),     TyContentM,     TyContent,     fromSchema,@@ -33,7 +33,7 @@     Result (Failure, Success, errors),   ) import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( KindedType (..),+  ( CatType (..),   ) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,

@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}@@ -20,7 +21,8 @@     singleton,   ) import Data.Morpheus.Server.Deriving.Schema.Directive-  ( deriveFieldDirectives,+  ( UseDirective,+    deriveFieldDirectives,     visitFieldContent,     visitFieldDescription,     visitFieldName,@@ -31,14 +33,10 @@     FieldRep (..),   ) import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CategoryValue (..),-    KindedType (..),+  ( CatType (..),     outputType,   )-import Data.Morpheus.Server.Types.GQLType-  ( GQLType,-    deriveTypename,-  )+import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType, useTypename) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,     insertType,@@ -51,7 +49,6 @@     OBJECT,     OUT,     TRUE,-    TypeCategory,     TypeContent (..),     TypeDefinition,     mkField,@@ -65,7 +62,7 @@ import Relude hiding (empty)  defineObjectType ::-  KindedType kind a ->+  CatType kind a ->   ConsRep (Maybe (FieldContent TRUE kind CONST)) ->   SchemaT cat () defineObjectType proxy ConsRep {consName, consFields} = insertType . mkType consName . mkObjectTypeContent proxy =<< fields@@ -78,12 +75,13 @@ mkFieldUnit = mkField Nothing unitFieldName (mkTypeRef unitTypeName)  buildObjectTypeContent ::-  GQLType a =>-  KindedType cat a ->+  gql a =>+  UseDirective gql args ->+  CatType cat a ->   [FieldRep (Maybe (FieldContent TRUE cat CONST))] ->-  SchemaT c (TypeContent TRUE cat CONST)-buildObjectTypeContent scope consFields = do-  xs <- traverse (setGQLTypeProps scope . repToFieldDefinition) consFields+  SchemaT k (TypeContent TRUE cat CONST)+buildObjectTypeContent options scope consFields = do+  xs <- traverse (setGQLTypeProps options scope . repToFieldDefinition) consFields   pure $ mkObjectTypeContent scope $ unsafeFromFields xs  repToFieldDefinition ::@@ -103,36 +101,37 @@       }  asObjectType ::-  (GQLType a) =>+  (gql a) =>+  UseGQLType gql ->   (f a -> SchemaT kind (FieldsDefinition OUT CONST)) ->   f a ->   SchemaT kind (TypeDefinition OBJECT CONST)-asObjectType f proxy =+asObjectType gql f proxy =   mkType-    (deriveTypename (outputType proxy))+    (useTypename gql (outputType proxy))     . DataObject []     <$> f proxy -withObject :: (GQLType a, CategoryValue c) => KindedType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)-withObject InputType DataInputObject {inputObjectFields} = pure inputObjectFields-withObject OutputType DataObject {objectFields} = pure objectFields-withObject x _ = failureOnlyObject x+withObject :: (gql a) => UseGQLType gql -> CatType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)+withObject _ InputType DataInputObject {inputObjectFields} = pure inputObjectFields+withObject _ OutputType DataObject {objectFields} = pure objectFields+withObject gql x _ = failureOnlyObject gql x -failureOnlyObject :: forall (c :: TypeCategory) a b. (GQLType a, CategoryValue c) => KindedType c a -> SchemaT c b-failureOnlyObject proxy = throwError $ msg (deriveTypename proxy) <> " should have only one nonempty constructor"+failureOnlyObject :: (gql a) => UseGQLType gql -> CatType c a -> SchemaT c b+failureOnlyObject gql proxy = throwError $ msg (useTypename gql proxy) <> " should have only one nonempty constructor" -mkObjectTypeContent :: KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST+mkObjectTypeContent :: CatType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent InputType = DataInputObject mkObjectTypeContent OutputType = DataObject [] -setGQLTypeProps :: GQLType a => KindedType kind a -> FieldDefinition kind CONST -> SchemaT c (FieldDefinition kind CONST)-setGQLTypeProps proxy FieldDefinition {..} = do-  dirs <- deriveFieldDirectives proxy fieldName+setGQLTypeProps :: gql a => UseDirective gql args -> CatType kind a -> FieldDefinition kind CONST -> SchemaT k (FieldDefinition kind CONST)+setGQLTypeProps options proxy FieldDefinition {..} = do+  dirs <- deriveFieldDirectives options proxy fieldName   pure     FieldDefinition-      { fieldName = visitFieldName proxy fieldName,-        fieldDescription = visitFieldDescription proxy fieldName Nothing,-        fieldContent = visitFieldContent proxy fieldName fieldContent,+      { fieldName = visitFieldName options proxy fieldName,+        fieldDescription = visitFieldDescription options proxy fieldName Nothing,+        fieldContent = visitFieldContent options proxy fieldName fieldContent,         fieldDirectives = dirs,         ..       }

@@ -1,24 +1,29 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Data.Morpheus.Server.Deriving.Schema.TypeContent   ( buildTypeContent,     insertTypeContent,     deriveTypeContentWith,+    deriveFieldsWith,   ) where -import Data.Morpheus.Server.Deriving.Schema.Directive (deriveTypeDirectives, visitTypeDescription)+import Data.Morpheus.Server.Deriving.Schema.Directive (UseDirective (..), deriveTypeDirectives, visitTypeDescription) import Data.Morpheus.Server.Deriving.Schema.Enum   ( buildEnumTypeContent,   ) import Data.Morpheus.Server.Deriving.Schema.Internal-  ( KindedType (..),+  ( CatType,     TyContent,   ) import Data.Morpheus.Server.Deriving.Schema.Object   ( buildObjectTypeContent,+    withObject,   ) import Data.Morpheus.Server.Deriving.Schema.Union (buildUnionTypeContent) import Data.Morpheus.Server.Deriving.Utils@@ -29,13 +34,9 @@     isEmptyConstraint,     unpackMonad,   )-import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CategoryValue (..),-  )-import Data.Morpheus.Server.Types.GQLType-  ( GQLType (..),-    deriveFingerprint,-    deriveTypename,+import Data.Morpheus.Server.Deriving.Utils.Kinded (typeCat)+import Data.Morpheus.Server.Deriving.Utils.Use+  ( UseGQLType (..),   ) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,@@ -45,45 +46,59 @@ import GHC.Generics (Rep)  buildTypeContent ::-  (GQLType a, CategoryValue kind) =>-  KindedType kind a ->+  (gql a) =>+  UseDirective gql args ->+  CatType kind a ->   [ConsRep (TyContent kind)] ->   SchemaT kind (TypeContent TRUE kind CONST)-buildTypeContent scope cons | all isEmptyConstraint cons = buildEnumTypeContent scope (consName <$> cons)-buildTypeContent scope [ConsRep {consFields}] = buildObjectTypeContent scope consFields-buildTypeContent scope cons = buildUnionTypeContent scope cons+buildTypeContent options scope cons | all isEmptyConstraint cons = buildEnumTypeContent options scope (consName <$> cons)+buildTypeContent options scope [ConsRep {consFields}] = buildObjectTypeContent options scope consFields+buildTypeContent options scope cons = buildUnionTypeContent (dirGQL options) scope cons  insertTypeContent ::-  (GQLType a, CategoryValue kind) =>-  (f kind a -> SchemaT c (TypeContent TRUE kind CONST)) ->-  f kind a ->-  SchemaT c ()-insertTypeContent f proxy =+  forall k gql args a.+  (gql a) =>+  UseDirective gql args ->+  (CatType k a -> SchemaT k (TypeContent TRUE k CONST)) ->+  CatType k a ->+  SchemaT k ()+insertTypeContent options@UseDirective {dirGQL = UseGQLType {..}} f proxy =   updateSchema-    (deriveFingerprint proxy)+    (__useFingerprint category proxy)     deriveD     proxy   where+    category = typeCat proxy     deriveD x = do       content <- f x-      dirs <- deriveTypeDirectives proxy+      dirs <- deriveTypeDirectives options proxy       pure $         TypeDefinition-          (visitTypeDescription proxy Nothing)-          (deriveTypename proxy)+          (visitTypeDescription options proxy Nothing)+          (__useTypename category proxy)           dirs           content  deriveTypeContentWith ::-  ( CategoryValue kind,-    DeriveWith c (SchemaT kind (TyContent kind)) (Rep a),-    GQLType a+  ( DeriveWith gql derive (SchemaT kind (TyContent kind)) (Rep a),+    gql a   ) =>-  DeriveTypeOptions kind c (SchemaT kind (TyContent kind)) ->-  KindedType kind a ->+  UseDirective gql args ->+  DeriveTypeOptions kind gql derive (SchemaT kind (TyContent kind)) ->+  CatType kind a ->   SchemaT kind (TypeContent TRUE kind CONST)-deriveTypeContentWith x kindedProxy =+deriveTypeContentWith options x kindedProxy =   unpackMonad     ( deriveTypeWith x kindedProxy     )-    >>= buildTypeContent kindedProxy+    >>= buildTypeContent options kindedProxy++deriveFieldsWith ::+  ( gql a,+    DeriveWith gql derive (SchemaT cat (TyContent cat)) (Rep a)+  ) =>+  UseDirective gql args ->+  DeriveTypeOptions cat gql derive (SchemaT cat (TyContent cat)) ->+  CatType cat a ->+  SchemaT cat (FieldsDefinition cat CONST)+deriveFieldsWith dirs cont kindedType = deriveTypeContentWith dirs cont kindedType >>= withObject (dirGQL dirs) kindedType

@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-}  module Data.Morpheus.Server.Deriving.Schema.Union@@ -20,10 +21,9 @@     isUnionRef,   ) import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CategoryValue,-    KindedType (..),+  ( CatType (..),   )-import Data.Morpheus.Server.Types.GQLType (GQLType, deriveTypename)+import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..), useTypename) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,   )@@ -41,20 +41,18 @@ import Relude  buildUnionTypeContent ::-  ( GQLType a,-    CategoryValue kind-  ) =>-  KindedType kind a ->+  (gql a) =>+  UseGQLType gql ->+  CatType kind a ->   [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->-  SchemaT c (TypeContent TRUE kind CONST)-buildUnionTypeContent scope cons = mkUnionType scope unionRef unionCons+  SchemaT k (TypeContent TRUE kind CONST)+buildUnionTypeContent gql scope cons = mkUnionType scope unionRef unionCons   where     unionRef = fieldTypeName <$> concatMap consFields unionRefRep-    (unionRefRep, unionCons) = partition (isUnionRef (deriveTypename scope)) cons+    (unionRefRep, unionCons) = partition (isUnionRef (useTypename gql scope)) cons  mkUnionType ::-  GQLType a =>-  KindedType kind a ->+  CatType kind a ->   [TypeName] ->   [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->   SchemaT c (TypeContent TRUE kind CONST)@@ -76,7 +74,7 @@   DataUnion <$> (buildUnions p unionCons >>= fromElems . map mkUnionMember . (unionRef <>))  buildUnions ::-  KindedType kind a ->+  CatType kind a ->   [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->   SchemaT c [TypeName] buildUnions proxy cons =

@@ -32,7 +32,7 @@   ( selectOr,   ) import Data.Morpheus.Server.Deriving.Utils (conNameProxy)-import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (..))+import Data.Morpheus.Server.Deriving.Utils.Kinded (CatType (..)) import Data.Morpheus.Server.Types.GQLType   ( GQLType,     deriveTypename,@@ -183,7 +183,7 @@   countFields _ = countFields (Proxy @f) + countFields (Proxy @g)  instance (Selector s, GQLType a) => DescribeFields (M1 S s (K1 i a)) where-  refType _ = Just $ deriveTypename (KindedProxy :: KindedProxy IN a)+  refType _ = Just $ deriveTypename (InputType :: CatType IN a)   countFields _ = 1  instance DescribeFields U1 where

@@ -22,9 +22,6 @@   ) where -import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CategoryValue (..),-  ) import Data.Morpheus.Server.Deriving.Utils.Proxy   ( conNameProxy,     isRecordProxy,@@ -56,48 +53,48 @@   ) import Relude hiding (undefined) -data DeriveValueOptions kind c v = DeriveValueOptions+data DeriveValueOptions kind gql c v = DeriveValueOptions   { __valueTypeName :: TypeName,     __valueApply :: forall a. c a => a -> v,-    __valueGetType :: forall f a. c a => f a -> TypeData+    __valueGetType :: forall f a. gql a => f a -> TypeData   } -data DeriveTypeOptions kind c v = DeriveTypeDefinitionOptions-  { __typeApply :: forall f a. c a => f a -> v,-    __typeGetType :: forall f a. c a => f a -> TypeData+data DeriveTypeOptions kind gql derive v = DeriveTypeOptions+  { __typeApply :: forall f a. derive a => f a -> v,+    __typeGetType :: forall f a. gql a => f a -> TypeData   }  deriveValue ::-  (CategoryValue kind, Generic a, DeriveWith constraint value (Rep a)) =>-  DeriveValueOptions kind constraint value ->+  (Generic a, DeriveWith gql constraint value (Rep a)) =>+  DeriveValueOptions kind gql constraint value ->   a ->   DataType value deriveValue options = deriveTypeValue options . from  deriveTypeWith ::-  forall kind c v kinded a.-  (CategoryValue kind, DeriveWith c v (Rep a)) =>-  DeriveTypeOptions kind c v ->+  forall kind gql c v kinded a.+  (DeriveWith gql c v (Rep a)) =>+  DeriveTypeOptions kind gql c v ->   kinded kind a ->   [ConsRep v] deriveTypeWith options _ = deriveTypeDefinition options (Proxy @(Rep a))  --  GENERIC UNION-class DeriveWith (c :: Type -> Constraint) (v :: Type) f where-  deriveTypeValue :: CategoryValue kind => DeriveValueOptions kind c v -> f a -> DataType v-  deriveTypeDefinition :: CategoryValue kind => DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]+class DeriveWith (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where+  deriveTypeValue :: DeriveValueOptions kind gql c v -> f a -> DataType v+  deriveTypeDefinition :: DeriveTypeOptions kind gql c v -> proxy f -> [ConsRep v] -instance (Datatype d, DeriveWith c v f) => DeriveWith c v (M1 D d f) where+instance (Datatype d, DeriveWith gql c v f) => DeriveWith gql c v (M1 D d f) where   deriveTypeValue options (M1 src) = (deriveTypeValue options src) {dataTypeName = __valueTypeName options}   deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @f)  -- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'-instance (DeriveWith c v a, DeriveWith c v b) => DeriveWith c v (a :+: b) where+instance (DeriveWith gql c v a, DeriveWith gql c v b) => DeriveWith gql c v (a :+: b) where   deriveTypeValue f (L1 x) = (deriveTypeValue f x) {tyIsUnion = True}   deriveTypeValue f (R1 x) = (deriveTypeValue f x) {tyIsUnion = True}   deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @a) <> deriveTypeDefinition options (Proxy @b) -instance (DeriveFieldRep con v f, Constructor c) => DeriveWith con v (M1 C c f) where+instance (DeriveFieldRep gql con v f, Constructor c) => DeriveWith gql con v (M1 C c f) where   deriveTypeValue options (M1 src) =     DataType       { dataTypeName = "",@@ -118,15 +115,15 @@       | isRecordProxy proxy = fields       | otherwise = enumerate fields -class DeriveFieldRep (c :: Type -> Constraint) (v :: Type) f where-  toFieldRep :: CategoryValue kind => DeriveValueOptions kind c v -> f a -> [FieldRep v]-  conRep :: CategoryValue kind => DeriveTypeOptions kind c v -> proxy f -> [FieldRep v]+class DeriveFieldRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where+  toFieldRep :: DeriveValueOptions kind gql c v -> f a -> [FieldRep v]+  conRep :: DeriveTypeOptions kind gql c v -> proxy f -> [FieldRep v] -instance (DeriveFieldRep c v a, DeriveFieldRep c v b) => DeriveFieldRep c v (a :*: b) where+instance (DeriveFieldRep gql c v a, DeriveFieldRep gql c v b) => DeriveFieldRep gql c v (a :*: b) where   toFieldRep options (a :*: b) = toFieldRep options a <> toFieldRep options b   conRep options _ = conRep options (Proxy @a) <> conRep options (Proxy @b) -instance (Selector s, c a) => DeriveFieldRep c v (M1 S s (Rec0 a)) where+instance (Selector s, gql a, c a) => DeriveFieldRep gql c v (M1 S s (Rec0 a)) where   toFieldRep DeriveValueOptions {..} (M1 (K1 src)) =     [ FieldRep         { fieldSelector = selNameProxy (Proxy @s),@@ -136,7 +133,7 @@     ]     where       TypeData {gqlTypeName, gqlWrappers} = __valueGetType (Proxy @a)-  conRep DeriveTypeDefinitionOptions {..} _ =+  conRep DeriveTypeOptions {..} _ =     [ FieldRep         { fieldSelector = selNameProxy (Proxy @s),           fieldTypeRef = TypeRef gqlTypeName gqlWrappers,@@ -146,6 +143,6 @@     where       TypeData {gqlTypeName, gqlWrappers} = __typeGetType (Proxy @a) -instance DeriveFieldRep c v U1 where+instance DeriveFieldRep gql c v U1 where   toFieldRep _ _ = []   conRep _ _ = []

@@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -10,33 +12,30 @@     setType,     setKind,     kinded,-    KindedType (..),+    CatType (..),     inputType,     outputType,-    CategoryValue (..),+    CatContext (..),+    getCat,+    typeCat,+    unliftKind,+    catMap,+    addContext,+    getCatContext,+    mkScalar,   ) where  import Data.Morpheus.Types.Internal.AST   ( IN,-    LEAF,     OUT,+    ScalarDefinition,+    TRUE,     TypeCategory (..),+    TypeContent (..),   ) import Prelude (Show) -class CategoryValue (c :: TypeCategory) where-  categoryValue :: f c -> TypeCategory--instance CategoryValue OUT where-  categoryValue _ = OUT--instance CategoryValue IN where-  categoryValue _ = IN--instance CategoryValue LEAF where-  categoryValue _ = LEAF- -- | context , like Proxy with multiple parameters -- * 'kind': object, scalar, enum ... -- * 'a': actual gql type@@ -52,18 +51,54 @@ kinded :: f k -> f' a -> KindedProxy k a kinded _ _ = KindedProxy -data KindedType (cat :: TypeCategory) a where-  InputType :: KindedType IN a-  OutputType :: KindedType OUT a+data CatContext (cat :: TypeCategory) where+  InputContext :: CatContext IN+  OutputContext :: CatContext OUT -deriving instance Show (KindedType cat a)+data CatType (cat :: TypeCategory) a where+  InputType :: CatType IN a+  OutputType :: CatType OUT a +-- liftKind :: CatType cat a -> CatType cat (f k a)+-- liftKind InputType = InputType+-- liftKind OutputType = OutputType++deriving instance Show (CatType cat a)+ -- converts: --   f a -> KindedType IN a -- or --  f k a -> KindedType IN a-inputType :: f a -> KindedType IN a+inputType :: f a -> CatType IN a inputType _ = InputType -outputType :: f a -> KindedType OUT a+outputType :: f a -> CatType OUT a outputType _ = OutputType++unliftKind :: CatType cat (f k a) -> CatType cat a+unliftKind InputType = InputType+unliftKind OutputType = OutputType++catMap :: f a -> CatType cat b -> CatType cat a+catMap _ InputType = InputType+catMap _ OutputType = OutputType++getCat :: CatContext c -> TypeCategory+getCat InputContext = IN+getCat OutputContext = OUT++typeCat :: CatType c a -> TypeCategory+typeCat InputType = IN+typeCat OutputType = OUT++addContext :: CatContext c -> f a -> CatType c a+addContext InputContext _ = InputType+addContext OutputContext _ = OutputType++getCatContext :: CatType c a -> CatContext c+getCatContext InputType = InputContext+getCatContext OutputType = OutputContext++mkScalar :: CatType c a -> ScalarDefinition -> TypeContent TRUE c s+mkScalar InputType f = DataScalar f+mkScalar OutputType f = DataScalar f

@@ -0,0 +1,60 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}++module Data.Morpheus.Server.Deriving.Utils.Use+  ( UseDirective (..),+    UseDeriveType (..),+    UseArguments (..),+    UseGQLType (..),+    useTypename,+  )+where++import Data.Morpheus.Server.Deriving.Schema.Internal+import Data.Morpheus.Server.Types.Directives+  ( GDirectiveUsages (..),+  )+import Data.Morpheus.Server.Types.Internal+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+  )+import Data.Morpheus.Server.Types.TypeName+  ( TypeFingerprint,+  )+import Data.Morpheus.Types.Internal.AST+  ( Arguments,+    ArgumentsDefinition,+    CONST,+    OUT,+    TypeCategory (..),+    TypeName,+  )++useTypename :: (gqlType a) => UseGQLType gqlType -> CatType c a -> TypeName+useTypename gql proxy@InputType = __useTypename gql IN proxy+useTypename gql proxy@OutputType = __useTypename gql OUT proxy++data UseGQLType gql = UseGQLType+  { __useFingerprint :: forall f a. gql a => TypeCategory -> f a -> TypeFingerprint,+    __useTypename :: forall f a. gql a => TypeCategory -> f a -> TypeName,+    __useTypeData :: forall f a. gql a => f a -> TypeCategory -> TypeData+  }++data UseArguments args = UseArguments+  { useDeriveArguments :: forall f a. args a => f a -> SchemaT OUT (ArgumentsDefinition CONST),+    useEncodeArguments :: forall k a. args a => a -> SchemaT k (Arguments CONST)+  }++data UseDirective gql args = UseDirective+  { __directives :: forall f a. gql a => f a -> GDirectiveUsages gql args,+    dirArgs :: UseArguments args,+    dirGQL :: UseGQLType gql+  }++data UseDeriveType derive = UseDeriveType+  { useDeriveType :: forall c a. derive c a => CatType c a -> SchemaT c (),+    useDeriveContent :: forall c a. derive c a => CatType c a -> TyContentM c+  }

@@ -16,6 +16,7 @@     useBatched,     Dependency,     ignoreBatching,+    NamedRef,   ) where @@ -24,7 +25,6 @@ import Data.Morpheus.Types.ID (ID) import Data.Morpheus.Types.Internal.AST (GQLError, internal) import Data.Vector (Vector)-import GHC.TypeLits (Symbol) import Relude  type family Target a :: Type where@@ -37,13 +37,6 @@   Target a = a  type family Dependency a :: Type where-  -- scalars-  Dependency Int = Int-  Dependency Double = Double-  Dependency Float = Float-  Dependency Text = Text-  Dependency Bool = Bool-  Dependency ID = ID   -- wrappers   Dependency (Maybe a) = Dependency a   Dependency [a] = Dependency a@@ -57,6 +50,9 @@ ignoreBatching :: (Monad m) => (a -> m b) -> [a] -> m [Maybe b] ignoreBatching f = traverse (fmap Just . f) +forward :: (Monad m, Dependency a ~ a) => [Dependency a] -> m [Maybe a]+forward = pure . map Just+ {-# DEPRECATED useBatched " this function is obsolete" #-} useBatched :: (ResolveNamed m a, MonadError GQLError m) => Dependency a -> m a useBatched x = resolveBatched [x] >>= res@@ -66,6 +62,30 @@  {-# DEPRECATED resolveNamed "use: resolveBatched" #-} +instance ResolveNamed m Int where+  type Dep Int = Int+  resolveBatched = forward++instance ResolveNamed m Float where+  type Dep Float = Float+  resolveBatched = forward++instance ResolveNamed m Double where+  type Dep Double = Double+  resolveBatched = forward++instance ResolveNamed m Text where+  type Dep Text = Text+  resolveBatched = forward++instance ResolveNamed m Bool where+  type Dep Bool = Bool+  resolveBatched = forward++instance ResolveNamed m ID where+  type Dep ID = ID+  resolveBatched = forward+ class ToJSON (Dependency a) => ResolveNamed (m :: Type -> Type) (a :: Type) where   type Dep a :: Type   resolveBatched :: MonadError GQLError m => [Dependency a] -> m [Maybe a]@@ -74,37 +94,15 @@   resolveNamed = useBatched  data NamedResolverT (m :: Type -> Type) a where-  Ref :: ResolveNamed m (Target a) => m (Dependency a) -> NamedResolverT m a-  Refs :: ResolveNamed m (Target a) => m [Dependency a] -> NamedResolverT m [a]-  Value :: m a -> NamedResolverT m a--data TargetType = LIST | SINGLE | ERROR Symbol--type family NamedResolverTarget b :: TargetType where-  NamedResolverTarget [a] = 'LIST-  NamedResolverTarget (Set a) = 'LIST-  NamedResolverTarget (NonEmpty a) = 'LIST-  NamedResolverTarget (Seq a) = 'LIST-  NamedResolverTarget (Vector a) = 'LIST-  NamedResolverTarget Int = 'ERROR "use lift, type Int can't have ResolveNamed instance"-  NamedResolverTarget Double = 'ERROR "use lift, type Double can't have ResolveNamed instance"-  NamedResolverTarget Float = 'ERROR "use lift, type Float can't have ResolveNamed instance"-  NamedResolverTarget Text = 'ERROR "use lift, type Text can't have ResolveNamed instance"-  NamedResolverTarget Bool = 'ERROR "use lift, type Bool can't have ResolveNamed instance"-  NamedResolverTarget ID = 'ERROR "use lift, type ID can't have ResolveNamed instance"-  NamedResolverTarget b = 'SINGLE--instance MonadTrans NamedResolverT where-  lift = Value--resolve :: forall m a b. (ResolveRef (NamedResolverTarget b) m a b) => Monad m => m a -> NamedResolverT m b-resolve = resolveRef (Proxy :: Proxy (NamedResolverTarget b))--class ResolveRef (k :: TargetType) m a b where-  resolveRef :: Monad m => f k -> m a -> NamedResolverT m b+  NamedResolverT :: ResolveNamed m (Target a) => m (NamedRef a) -> NamedResolverT m a -instance (ResolveNamed m (Target b), a ~ Dependency b) => ResolveRef 'LIST m [a] [b] where-  resolveRef _ = Refs+type family NamedRef a :: Type where+  NamedRef [a] = [Dependency a]+  NamedRef (Set a) = [Dependency a]+  NamedRef (NonEmpty a) = [Dependency a]+  NamedRef (Seq a) = [Dependency a]+  NamedRef (Vector a) = [Dependency a]+  NamedRef a = Dependency a -instance (ResolveNamed m (Target b), Dependency b ~ a) => ResolveRef 'SINGLE m a b where-  resolveRef _ = Ref+resolve :: ResolveNamed m (Target a) => m (NamedRef a) -> NamedResolverT m a+resolve = NamedResolverT

@@ -11,7 +11,10 @@  -- | GQL Types module Data.Morpheus.Server.Types-  ( GQLType (KIND, directives),+  ( GQLType+      ( KIND,+        directives+      ),     EncodeScalar (..),     EncodeWrapper (..),     DecodeScalar (..),@@ -53,7 +56,7 @@     Deprecated (..),     Describe (..),     SCALAR,-    DerivingKind (..),+    DerivingKind,     TYPE,     CUSTOM,     WRAPPER,@@ -64,6 +67,7 @@     DropNamespace (..),     DefaultValue (..),     Value (..),+    DirectiveLocation (..),   ) where @@ -94,19 +98,21 @@     Prefixes (..),     Rename (..),   )-import Data.Morpheus.Server.Types.Directives (GQLDirective (..))-import Data.Morpheus.Server.Types.GQLType-  ( GQLType (..),-    InputTypeNamespace (..),+import Data.Morpheus.Server.Types.Directives+  ( GQLDirective (..),     enumDirective,     enumDirective',     fieldDirective,     fieldDirective',     typeDirective,   )+import Data.Morpheus.Server.Types.GQLType+  ( GQLType (..),+    InputTypeNamespace (..),+  ) import Data.Morpheus.Server.Types.Kind   ( CUSTOM,-    DerivingKind (..),+    DerivingKind,     SCALAR,     TYPE,     WRAPPER,@@ -135,7 +141,8 @@     GQLResponse (..),   ) import Data.Morpheus.Types.Internal.AST-  ( GQLError,+  ( DirectiveLocation (..),+    GQLError,     MUTATION,     QUERY,     SUBSCRIPTION,

@@ -44,12 +44,12 @@ instance GQLDirective Prefixes where   type     DIRECTIVE_LOCATIONS Prefixes =-      '[ 'OBJECT,-         'ENUM,-         'INPUT_OBJECT,-         'UNION,-         'SCALAR,-         'INTERFACE+      '[ 'LOCATION_OBJECT,+         'LOCATION_ENUM,+         'LOCATION_INPUT_OBJECT,+         'LOCATION_UNION,+         'LOCATION_SCALAR,+         'LOCATION_INTERFACE        ]  instance VisitType Prefixes where@@ -73,8 +73,8 @@ instance GQLDirective Deprecated where   type     DIRECTIVE_LOCATIONS Deprecated =-      '[ 'FIELD_DEFINITION,-         'ENUM_VALUE+      '[ 'LOCATION_FIELD_DEFINITION,+         'LOCATION_ENUM_VALUE        ]  newtype Describe = Describe {text :: Text}@@ -86,16 +86,16 @@ instance GQLDirective Describe where   type     DIRECTIVE_LOCATIONS Describe =-      '[ 'ENUM_VALUE,-         'FIELD_DEFINITION,-         'INPUT_FIELD_DEFINITION,-         'OBJECT,-         'ENUM,-         'INPUT_OBJECT,-         'UNION,-         'SCALAR,-         'INTERFACE,-         'ARGUMENT_DEFINITION+      '[ 'LOCATION_ENUM_VALUE,+         'LOCATION_FIELD_DEFINITION,+         'LOCATION_INPUT_FIELD_DEFINITION,+         'LOCATION_OBJECT,+         'LOCATION_ENUM,+         'LOCATION_INPUT_OBJECT,+         'LOCATION_UNION,+         'LOCATION_SCALAR,+         'LOCATION_INTERFACE,+         'LOCATION_ARGUMENT_DEFINITION        ]  instance VisitEnum Describe where@@ -119,15 +119,15 @@   excludeFromSchema _ = True   type     DIRECTIVE_LOCATIONS Rename =-      '[ 'OBJECT,-         'ENUM,-         'INPUT_OBJECT,-         'UNION,-         'SCALAR,-         'INTERFACE,-         'ENUM_VALUE,-         'FIELD_DEFINITION,-         'INPUT_FIELD_DEFINITION+      '[ 'LOCATION_OBJECT,+         'LOCATION_ENUM,+         'LOCATION_INPUT_OBJECT,+         'LOCATION_UNION,+         'LOCATION_SCALAR,+         'LOCATION_INTERFACE,+         'LOCATION_ENUM_VALUE,+         'LOCATION_FIELD_DEFINITION,+         'LOCATION_INPUT_FIELD_DEFINITION        ]  instance VisitType Rename where@@ -152,12 +152,12 @@ instance GQLDirective DropNamespace where   type     DIRECTIVE_LOCATIONS DropNamespace =-      '[ 'OBJECT,-         'ENUM,-         'INPUT_OBJECT,-         'UNION,-         'SCALAR,-         'INTERFACE+      '[ 'LOCATION_OBJECT,+         'LOCATION_ENUM,+         'LOCATION_INPUT_OBJECT,+         'LOCATION_UNION,+         'LOCATION_SCALAR,+         'LOCATION_INTERFACE        ]   excludeFromSchema _ = True @@ -174,7 +174,7 @@     )  instance GQLDirective DefaultValue where-  type DIRECTIVE_LOCATIONS DefaultValue = '[ 'INPUT_FIELD_DEFINITION]+  type DIRECTIVE_LOCATIONS DefaultValue = '[ 'LOCATION_INPUT_FIELD_DEFINITION]   excludeFromSchema _ = True  instance VisitField DefaultValue where

@@ -16,19 +16,26 @@   ( GQLDirective (..),     ToLocations (..),     getLocations,-    -- visitors-    visitEnumDescription',-    visitEnumName',-    visitEnumNames',-    visitFieldDefaultValue',-    visitFieldDescription',-    visitFieldName',-    visitFieldNames',-    visitTypeDescription',-    visitTypeName',+    GDirectiveUsage (..),+    GDirectiveUsages (..),+    applyTypeName,+    applyTypeDescription,+    applyEnumName,+    applyEnumDescription,+    applyFieldName,+    applyFieldDescription,+    applyFieldDefaultValue,+    applyTypeFieldNames,+    applyTypeEnumNames,+    typeDirective,+    fieldDirective,+    fieldDirective',+    enumDirective,+    enumDirective',   ) where +import qualified Data.HashMap.Strict as M import Data.Morpheus.Server.Types.TypeName (getTypename) import qualified Data.Morpheus.Server.Types.Visitors as Visitors import Data.Morpheus.Types.Internal.AST@@ -43,6 +50,7 @@     packName,     unpackName,   )+import qualified Language.Haskell.TH as TH import Relude  type family OR (a :: Bool) (b :: Bool) where@@ -64,36 +72,36 @@   toLocation :: f l -> DirectiveLocation  -- types-instance ToLocation 'OBJECT where-  toLocation = const OBJECT+instance ToLocation 'LOCATION_OBJECT where+  toLocation = const LOCATION_OBJECT -instance ToLocation 'ENUM where-  toLocation = const ENUM+instance ToLocation 'LOCATION_ENUM where+  toLocation = const LOCATION_ENUM -instance ToLocation 'INPUT_OBJECT where-  toLocation = const INPUT_OBJECT+instance ToLocation 'LOCATION_INPUT_OBJECT where+  toLocation = const LOCATION_INPUT_OBJECT -instance ToLocation 'UNION where-  toLocation = const UNION+instance ToLocation 'LOCATION_UNION where+  toLocation = const LOCATION_UNION -instance ToLocation 'SCALAR where-  toLocation = const SCALAR+instance ToLocation 'LOCATION_SCALAR where+  toLocation = const LOCATION_SCALAR -instance ToLocation 'INTERFACE where-  toLocation = const INTERFACE+instance ToLocation 'LOCATION_INTERFACE where+  toLocation = const LOCATION_INTERFACE  -- fields, values-instance ToLocation 'INPUT_FIELD_DEFINITION where-  toLocation = const INPUT_FIELD_DEFINITION+instance ToLocation 'LOCATION_INPUT_FIELD_DEFINITION where+  toLocation = const LOCATION_INPUT_FIELD_DEFINITION -instance ToLocation 'ARGUMENT_DEFINITION where-  toLocation = const ARGUMENT_DEFINITION+instance ToLocation 'LOCATION_ARGUMENT_DEFINITION where+  toLocation = const LOCATION_ARGUMENT_DEFINITION -instance ToLocation 'FIELD_DEFINITION where-  toLocation = const FIELD_DEFINITION+instance ToLocation 'LOCATION_FIELD_DEFINITION where+  toLocation = const LOCATION_FIELD_DEFINITION -instance ToLocation 'ENUM_VALUE where-  toLocation = const ENUM_VALUE+instance ToLocation 'LOCATION_ENUM_VALUE where+  toLocation = const LOCATION_ENUM_VALUE  class ToLocations (k :: [DirectiveLocation]) where   toLocations :: f k -> [DirectiveLocation]@@ -113,17 +121,18 @@  -- types -type TYPE_VISITOR_KIND = '[ 'OBJECT, 'ENUM, 'INPUT_OBJECT, 'UNION, 'SCALAR, 'INTERFACE]+type TYPE_VISITOR_KIND = '[ 'LOCATION_OBJECT, 'LOCATION_ENUM, 'LOCATION_INPUT_OBJECT, 'LOCATION_UNION, 'LOCATION_SCALAR, 'LOCATION_INTERFACE] -type FIELD_VISITOR_KIND = '[ 'INPUT_FIELD_DEFINITION, 'FIELD_DEFINITION]+type FIELD_VISITOR_KIND = '[ 'LOCATION_INPUT_FIELD_DEFINITION, 'LOCATION_FIELD_DEFINITION] -type ENUM_VISITOR_KIND = '[ 'ENUM_VALUE]+type ENUM_VISITOR_KIND = '[ 'LOCATION_ENUM_VALUE]  __directiveName :: GQLDirective a => f a -> FieldName __directiveName = coerce . getTypename  class-  ( Typeable a,+  ( ToLocations (DIRECTIVE_LOCATIONS a),+    Typeable a,     WITH_VISITOR a VISIT_TYPE TYPE_VISITOR_KIND,     WITH_VISITOR a VISIT_FIELD FIELD_VISITOR_KIND,     WITH_VISITOR a VISIT_ENUM ENUM_VISITOR_KIND@@ -211,3 +220,72 @@ instance Visitors.VisitEnum a => VISIT_ENUM a TRUE where   __visitEnumName _ x name = packName $ Visitors.visitEnumName x (unpackName name)   __visitEnumDescription _ = Visitors.visitEnumDescription++data GDirectiveUsage (gql :: Type -> Constraint) (args :: Type -> Constraint) where+  GDirectiveUsage :: (GQLDirective a, gql a, args a) => a -> GDirectiveUsage gql args++-- apply++applyTypeName :: GDirectiveUsage gql args -> Bool -> TypeName -> TypeName+applyTypeName (GDirectiveUsage x) = visitTypeName' x++applyTypeFieldNames :: GDirectiveUsage gql args -> FieldName -> FieldName+applyTypeFieldNames (GDirectiveUsage x) = visitFieldNames' x++applyTypeEnumNames :: GDirectiveUsage gql args -> TypeName -> TypeName+applyTypeEnumNames (GDirectiveUsage x) = visitEnumNames' x++applyEnumDescription :: GDirectiveUsage gql args -> Maybe Description -> Maybe Description+applyEnumDescription (GDirectiveUsage x) = visitEnumDescription' x++applyEnumName :: GDirectiveUsage gql args -> TypeName -> TypeName+applyEnumName (GDirectiveUsage x) = visitEnumName' x++applyFieldName :: GDirectiveUsage gql args -> FieldName -> FieldName+applyFieldName (GDirectiveUsage x) = visitFieldName' x++applyFieldDescription :: GDirectiveUsage gql args -> Maybe Description -> Maybe Description+applyFieldDescription (GDirectiveUsage x) = visitFieldDescription' x++applyFieldDefaultValue :: GDirectiveUsage gql args -> Maybe (Value CONST) -> Maybe (Value CONST)+applyFieldDefaultValue (GDirectiveUsage x) = visitFieldDefaultValue' x++applyTypeDescription :: GDirectiveUsage gql args -> Maybe Description -> Maybe Description+applyTypeDescription (GDirectiveUsage x) = visitTypeDescription' x++data GDirectiveUsages gql args = GDirectiveUsages+  { typeDirectives :: [GDirectiveUsage gql args],+    fieldDirectives :: M.HashMap FieldName [GDirectiveUsage gql args],+    enumValueDirectives :: M.HashMap TypeName [GDirectiveUsage gql args]+  }++instance Monoid (GDirectiveUsages gql args) where+  mempty = GDirectiveUsages mempty mempty mempty++instance Semigroup (GDirectiveUsages gql args) where+  GDirectiveUsages td1 fd1 ed1 <> GDirectiveUsages td2 fd2 ed2 =+    GDirectiveUsages (td1 <> td2) (mergeDirs fd1 fd2) (mergeDirs ed1 ed2)++mergeDirs :: (Eq k, Hashable k, Semigroup v) => HashMap k v -> HashMap k v -> HashMap k v+mergeDirs a b = update a (M.toList b)+  where+    update m [] = m+    update m (x : xs) = update (upsert x m) xs++upsert :: (Eq k, Hashable k, Semigroup v) => (k, v) -> HashMap k v -> HashMap k v+upsert (k, v) = M.alter (Just . maybe v (v <>)) k++typeDirective :: (GQLDirective a, gql a, args a) => a -> GDirectiveUsages gql args+typeDirective x = GDirectiveUsages [GDirectiveUsage x] mempty mempty++fieldDirective :: (GQLDirective a, gql a, args a) => FieldName -> a -> GDirectiveUsages gql args+fieldDirective name x = GDirectiveUsages mempty (M.singleton name [GDirectiveUsage x]) mempty++fieldDirective' :: (GQLDirective a, gql a, args a) => TH.Name -> a -> GDirectiveUsages gql args+fieldDirective' name = fieldDirective (packName name)++enumDirective :: (GQLDirective a, gql a, args a) => TypeName -> a -> GDirectiveUsages gql args+enumDirective name x = GDirectiveUsages mempty mempty (M.singleton name [GDirectiveUsage x])++enumDirective' :: (GQLDirective a, gql a, args a) => TH.Name -> a -> GDirectiveUsages gql args+enumDirective' name = enumDirective (packName name)

@@ -19,60 +19,44 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Types.GQLType-  ( GQLType (KIND, directives, __type),-    __typeData,-    deriveTypename,+  ( DeriveDirective,+    GQLType (KIND, directives, __type),+    InputTypeNamespace (..),     deriveFingerprint,+    deriveTypename,     encodeArguments,-    DirectiveUsage (..),-    DeriveArguments (..),-    DirectiveUsages (..),-    typeDirective,-    fieldDirective,-    fieldDirective',-    enumDirective,-    enumDirective',-    applyTypeName,-    applyTypeDescription,-    applyEnumName,-    applyEnumDescription,-    applyFieldName,-    applyFieldDescription,-    applyFieldDefaultValue,-    applyTypeFieldNames,-    applyTypeEnumNames,     __isEmptyType,-    InputTypeNamespace (..),+    __typeData,+    withGQL,+    withDir,+    withDeriveType,+    DeriveType,   ) where  -- MORPHEUS  import Control.Monad.Except (MonadError (throwError))-import qualified Data.HashMap.Strict as M import Data.Morpheus.App.Internal.Resolving   ( Resolver,     SubscriptionField,   ) import Data.Morpheus.Internal.Ext import Data.Morpheus.Internal.Utils+import Data.Morpheus.Server.Deriving.Schema.DeriveKinded+import Data.Morpheus.Server.Deriving.Schema.Directive (UseDirective (..))+import Data.Morpheus.Server.Deriving.Schema.Internal import Data.Morpheus.Server.Deriving.Utils (ConsRep (..), DataType (..), DeriveWith, FieldRep (..)) import Data.Morpheus.Server.Deriving.Utils.DeriveGType (DeriveValueOptions (..), deriveValue)-import Data.Morpheus.Server.Deriving.Utils.Kinded (CategoryValue (..), KindedProxy (KindedProxy), kinded)+import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (KindedProxy), inputType) import Data.Morpheus.Server.Deriving.Utils.Proxy (ContextValue (..))+import Data.Morpheus.Server.Deriving.Utils.Use (UseArguments (..), UseDeriveType (..), UseGQLType (..)) import Data.Morpheus.Server.NamedResolvers (NamedResolverT (..)) import Data.Morpheus.Server.Types.Directives-  ( GQLDirective (..),-    ToLocations (..),-    visitEnumDescription',-    visitEnumName',-    visitEnumNames',-    visitFieldDefaultValue',-    visitFieldDescription',-    visitFieldName',-    visitFieldNames',-    visitTypeDescription',-    visitTypeName',+  ( GDirectiveUsages (..),+    GQLDirective (..),+    applyTypeName,+    typeDirective,   ) import Data.Morpheus.Server.Types.Internal   ( TypeData (..),@@ -85,7 +69,7 @@     TYPE,     WRAPPER,   )-import Data.Morpheus.Server.Types.SchemaT (SchemaT)+import Data.Morpheus.Server.Types.SchemaT (SchemaT, withInput) import Data.Morpheus.Server.Types.TypeName (TypeFingerprint (..), getFingerprint, getTypename) import Data.Morpheus.Server.Types.Types   ( Arg,@@ -103,9 +87,7 @@     Arguments,     ArgumentsDefinition,     CONST,-    Description,     DirectiveLocation (..),-    FieldName,     GQLError,     IN,     OUT,@@ -117,30 +99,26 @@     Value (..),     internal,     mkBaseType,-    packName,     toNullable,     unitTypeName,   ) import Data.Sequence (Seq) import Data.Vector (Vector) import GHC.Generics-import qualified Language.Haskell.TH.Syntax as TH+import GHC.TypeLits (KnownSymbol) import Relude hiding (Seq, Undefined, fromList, intercalate)  __isEmptyType :: forall f a. GQLType a => f a -> Bool-__isEmptyType _ = deriveFingerprint (KindedProxy :: KindedProxy OUT a) == InternalFingerprint __typenameUndefined+__isEmptyType _ = deriveFingerprint (OutputType :: CatType OUT a) == InternalFingerprint __typenameUndefined -__typeData ::-  forall kinded (kind :: TypeCategory) (a :: Type).-  (GQLType a, CategoryValue kind) =>-  kinded kind a ->-  TypeData-__typeData proxy = __type proxy (categoryValue (Proxy @kind))+__typeData :: (GQLType a) => CatType cat a -> TypeData+__typeData proxy@InputType = __type proxy IN+__typeData proxy@OutputType = __type proxy OUT -deriveTypename :: (GQLType a, CategoryValue kind) => kinded kind a -> TypeName+deriveTypename :: (GQLType a) => CatType cat a -> TypeName deriveTypename proxy = gqlTypeName $ __typeData proxy -deriveFingerprint :: (GQLType a, CategoryValue kind) => kinded kind a -> TypeFingerprint+deriveFingerprint :: (GQLType a) => CatType cat a -> TypeFingerprint deriveFingerprint proxy = gqlFingerprint $ __typeData proxy  deriveTypeData ::@@ -149,9 +127,9 @@   DirectiveUsages ->   TypeCategory ->   TypeData-deriveTypeData proxy DirectiveUsages {typeDirectives} cat =+deriveTypeData proxy GDirectiveUsages {typeDirectives} cat =   TypeData-    { gqlTypeName = typeNameWithDirectives (cat == IN) (getTypename proxy) typeDirectives,+    { gqlTypeName = foldr (`applyTypeName` (cat == IN)) (getTypename proxy) typeDirectives,       gqlWrappers = mkBaseType,       gqlFingerprint = getFingerprint cat proxy     }@@ -251,7 +229,7 @@   type KIND (SubscriptionField a) = WRAPPER   __type _ = __type $ Proxy @a -instance (Typeable a, Typeable b, GQLType a, GQLType b, DeriveArguments TYPE InputTypeNamespace) => GQLType (Pair a b) where+instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where   directives _ = typeDirective InputTypeNamespace {inputTypeNamespace = "Input"}  -- Manual@@ -260,7 +238,7 @@   type KIND (a -> b) = CUSTOM   __type _ = __type $ Proxy @b -instance (GQLType k, GQLType v, Typeable k, Typeable v, DeriveArguments TYPE InputTypeNamespace) => GQLType (Map k v) where+instance (GQLType k, GQLType v, Typeable k, Typeable v) => GQLType (Map k v) where   type KIND (Map k v) = CUSTOM   __type _ = __type $ Proxy @[Pair k v] @@ -268,7 +246,7 @@   type KIND (Resolver o e m a) = CUSTOM   __type _ = __type $ Proxy @a -instance (Typeable a, Typeable b, GQLType a, GQLType b, DeriveArguments TYPE InputTypeNamespace) => GQLType (a, b) where+instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where   __type _ = __type $ Proxy @(Pair a b)   directives _ = typeDirective InputTypeNamespace {inputTypeNamespace = "Input"} @@ -288,23 +266,23 @@   type KIND (NamedResolverT m a) = CUSTOM   __type _ = __type (Proxy :: Proxy a) -type Decode a = EncodeKind (KIND a) a+type EncodeValue a = EncodeKind (KIND a) a -encodeArguments :: forall m a. (MonadError GQLError m, Decode a) => a -> m (Arguments CONST)+encodeArguments :: forall m a. (MonadError GQLError m, EncodeValue a) => a -> m (Arguments CONST) encodeArguments x = resultOr (const $ throwError err) pure (encode x) >>= unpackValue   where-    err = internal "could not encode arguments!"+    err = internal "could not encode arguments. Arguments should be an object like type!"     unpackValue (Object v) = pure $ fmap toArgument v     unpackValue _ = throwError err     toArgument ObjectEntry {..} = Argument (Position 0 0) entryName entryValue -encode :: forall a. Decode a => a -> GQLResult (Value CONST)+encode :: forall a. EncodeValue a => a -> GQLResult (Value CONST) encode x = encodeKind (ContextValue x :: ContextValue (KIND a) a)  class EncodeKind (kind :: DerivingKind) (a :: Type) where   encodeKind :: ContextValue kind a -> GQLResult (Value CONST) -instance (EncodeWrapperValue f, Decode a) => EncodeKind WRAPPER (f a) where+instance (EncodeWrapperValue f, EncodeValue a) => EncodeKind WRAPPER (f a) where   encodeKind = encodeWrapperValue encode . unContextValue  instance (EncodeScalar a) => EncodeKind SCALAR a where@@ -316,6 +294,10 @@ instance EncodeKind CUSTOM (Value CONST) where   encodeKind = pure . unContextValue +-- TODO: remove me+instance (KnownSymbol name) => EncodeKind CUSTOM (Arg name a) where+  encodeKind _ = throwError "directives cant be tagged arguments"+ convertNode ::   DataType (GQLResult (Value CONST)) ->   GQLResult (Value CONST)@@ -337,9 +319,9 @@       encodeTypeFields _ = throwError (internal "input unions are not supported")  -- Types & Constrains --------------------------------------------------------class (EncodeKind (KIND a) a, GQLType a) => ExplorerConstraint a+class (EncodeKind (KIND a) a) => ExplorerConstraint a -instance (EncodeKind (KIND a) a, GQLType a) => ExplorerConstraint a+instance (EncodeKind (KIND a) a) => ExplorerConstraint a  exploreResolvers :: forall a. EncodeConstraint a => a -> GQLResult (Value CONST) exploreResolvers =@@ -347,94 +329,29 @@     . deriveValue       ( DeriveValueOptions           { __valueApply = encode,-            __valueTypeName = deriveTypename (KindedProxy :: KindedProxy IN a),-            __valueGetType = __typeData . kinded (Proxy @IN)+            __valueTypeName = deriveTypename (InputType :: CatType IN a),+            __valueGetType = __typeData . inputType           } ::-          DeriveValueOptions IN ExplorerConstraint (GQLResult (Value CONST))+          DeriveValueOptions IN GQLType ExplorerConstraint (GQLResult (Value CONST))       )  type EncodeConstraint a =   ( Generic a,     GQLType a,-    DeriveWith ExplorerConstraint (GQLResult (Value CONST)) (Rep a)+    DeriveWith GQLType ExplorerConstraint (GQLResult (Value CONST)) (Rep a)   ) -class DeriveArguments (k :: DerivingKind) a where-  deriveArgumentsDefinition :: f k a -> SchemaT OUT (ArgumentsDefinition CONST)- -- DIRECTIVES--data DirectiveUsages = DirectiveUsages-  { typeDirectives :: [DirectiveUsage],-    fieldDirectives :: M.HashMap FieldName [DirectiveUsage],-    enumValueDirectives :: M.HashMap TypeName [DirectiveUsage]-  }--instance Monoid DirectiveUsages where-  mempty = DirectiveUsages mempty mempty mempty--mergeDirs :: (Eq k, Hashable k, Semigroup v) => HashMap k v -> HashMap k v -> HashMap k v-mergeDirs a b = update a (M.toList b)-  where-    update m [] = m-    update m (x : xs) = update (upsert x m) xs--upsert :: (Eq k, Hashable k, Semigroup v) => (k, v) -> HashMap k v -> HashMap k v-upsert (k, v) = M.alter (Just . maybe v (v <>)) k--instance Semigroup DirectiveUsages where-  DirectiveUsages td1 fd1 ed1 <> DirectiveUsages td2 fd2 ed2 =-    DirectiveUsages (td1 <> td2) (mergeDirs fd1 fd2) (mergeDirs ed1 ed2)--type TypeDirectiveConstraint a = (GQLDirective a, GQLType a, Decode a, DeriveArguments (KIND a) a, ToLocations (DIRECTIVE_LOCATIONS a))--typeDirective :: TypeDirectiveConstraint a => a -> DirectiveUsages-typeDirective x = DirectiveUsages [DirectiveUsage x] mempty mempty--fieldDirective :: TypeDirectiveConstraint a => FieldName -> a -> DirectiveUsages-fieldDirective name x = DirectiveUsages mempty (M.singleton name [DirectiveUsage x]) mempty--fieldDirective' :: TypeDirectiveConstraint a => TH.Name -> a -> DirectiveUsages-fieldDirective' name = fieldDirective (packName name)--enumDirective :: TypeDirectiveConstraint a => TypeName -> a -> DirectiveUsages-enumDirective name x = DirectiveUsages mempty mempty (M.singleton name [DirectiveUsage x])--enumDirective' :: TypeDirectiveConstraint a => TH.Name -> a -> DirectiveUsages-enumDirective' name = enumDirective (packName name)--data DirectiveUsage where-  DirectiveUsage :: (GQLDirective a, GQLType a, Decode a, DeriveArguments (KIND a) a, ToLocations (DIRECTIVE_LOCATIONS a)) => a -> DirectiveUsage--applyTypeName :: DirectiveUsage -> Bool -> TypeName -> TypeName-applyTypeName (DirectiveUsage x) = visitTypeName' x--typeNameWithDirectives :: Bool -> TypeName -> [DirectiveUsage] -> TypeName-typeNameWithDirectives x = foldr (`applyTypeName` x)--applyTypeFieldNames :: DirectiveUsage -> FieldName -> FieldName-applyTypeFieldNames (DirectiveUsage x) = visitFieldNames' x--applyTypeEnumNames :: DirectiveUsage -> TypeName -> TypeName-applyTypeEnumNames (DirectiveUsage x) = visitEnumNames' x--applyEnumDescription :: DirectiveUsage -> Maybe Description -> Maybe Description-applyEnumDescription (DirectiveUsage x) = visitEnumDescription' x--applyEnumName :: DirectiveUsage -> TypeName -> TypeName-applyEnumName (DirectiveUsage x) = visitEnumName' x+type DeriveArguments a = DeriveArgs GQLType DeriveType (KIND a) a -applyFieldName :: DirectiveUsage -> FieldName -> FieldName-applyFieldName (DirectiveUsage x) = visitFieldName' x+type DirectiveUsages = GDirectiveUsages GQLType DeriveDirective -applyFieldDescription :: DirectiveUsage -> Maybe Description -> Maybe Description-applyFieldDescription (DirectiveUsage x) = visitFieldDescription' x+deriveArguments :: DeriveArgs GQLType DeriveType k a => f k a -> SchemaT OUT (ArgumentsDefinition CONST)+deriveArguments = withInput . deriveArgs withDir withDeriveType -applyFieldDefaultValue :: DirectiveUsage -> Maybe (Value CONST) -> Maybe (Value CONST)-applyFieldDefaultValue (DirectiveUsage x) = visitFieldDefaultValue' x+class (EncodeValue a, DeriveArguments a) => DeriveDirective a -applyTypeDescription :: DirectiveUsage -> Maybe Description -> Maybe Description-applyTypeDescription (DirectiveUsage x) = visitTypeDescription' x+instance (EncodeValue a, DeriveArguments a) => DeriveDirective a  newtype InputTypeNamespace = InputTypeNamespace {inputTypeNamespace :: Text}   deriving (Generic)@@ -445,15 +362,63 @@   excludeFromSchema _ = True   type     DIRECTIVE_LOCATIONS InputTypeNamespace =-      '[ 'OBJECT,-         'ENUM,-         'INPUT_OBJECT,-         'UNION,-         'SCALAR,-         'INTERFACE+      '[ '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++withArgs :: UseArguments DeriveDirective+withArgs =+  UseArguments+    { useDeriveArguments = deriveArguments . withKind,+      useEncodeArguments = encodeArguments+    }++withGQL :: UseGQLType GQLType+withGQL =+  UseGQLType+    { __useFingerprint = \c v -> gqlFingerprint (__type v c),+      __useTypename = \c v -> gqlTypeName (__type v c),+      __useTypeData = __type+    }++withDir :: UseDirective GQLType DeriveDirective+withDir =+  UseDirective+    { __directives = directives,+      dirGQL = withGQL,+      dirArgs = withArgs+    }++withKind :: f a -> KindedProxy (KIND a) a+withKind _ = KindedProxy++withDeriveType :: UseDeriveType DeriveType+withDeriveType =+  UseDeriveType+    { useDeriveType = deriveType,+      useDeriveContent = deriveContent+    }++-- DERIVE TYPE++-- |  Generates internal GraphQL Schema for query validation and introspection rendering+class DeriveType (c :: TypeCategory) (a :: Type) where+  deriveType :: CatType c a -> SchemaT c ()+  deriveContent :: CatType c a -> TyContentM c++instance (GQLType a, DeriveKindedType GQLType DeriveType DeriveDirective cat (KIND a) a) => DeriveType cat a where+  deriveType = deriveKindedType withDir withDeriveType . liftKind+  deriveContent = deriveKindedContent withDir withDeriveType . liftKind++liftKind :: CatType cat a -> CatType cat (f (KIND a) a)+liftKind InputType = InputType+liftKind OutputType = OutputType

@@ -6,7 +6,7 @@ -- | associating types to GraphQL Kinds module Data.Morpheus.Server.Types.Kind   ( SCALAR,-    DerivingKind (..),+    DerivingKind,     TYPE,     CUSTOM,     WRAPPER,@@ -16,19 +16,19 @@ import Relude  data DerivingKind-  = SCALAR-  | TYPE-  | WRAPPER-  | CUSTOM+  = DERIVING_SCALAR+  | DERIVING_TYPE+  | DERIVING_WRAPPER+  | DERIVING_CUSTOM   deriving (Show) --- | GraphQL input, type, union , enum-type TYPE = 'TYPE- -- | GraphQL Scalar: Int, Float, String, Boolean or any user defined custom Scalar type-type SCALAR = 'SCALAR+type SCALAR = 'DERIVING_SCALAR +-- | GraphQL input, type, union , enum+type TYPE = 'DERIVING_TYPE+ -- | GraphQL Arrays , Resolvers and NonNull fields-type WRAPPER = 'WRAPPER+type WRAPPER = 'DERIVING_WRAPPER -type CUSTOM = 'CUSTOM+type CUSTOM = 'DERIVING_CUSTOM

@@ -15,6 +15,7 @@ import Data.Morpheus.Server (interpreter) import Data.Morpheus.Server.Types   ( Deprecated (..),+    DirectiveLocation (..),     GQLDirective (..),     GQLRequest,     GQLResponse,@@ -28,9 +29,6 @@     fieldDirective',     typeDirective,   )-import Data.Morpheus.Types.Internal.AST-  ( DirectiveLocation (..),-  ) import Data.Text (Text) import GHC.Generics (Generic) @@ -48,7 +46,7 @@   deriving (GQLType, Generic)  instance GQLDirective Power where-  type DIRECTIVE_LOCATIONS Power = '[ 'OBJECT]+  type DIRECTIVE_LOCATIONS Power = '[ 'LOCATION_OBJECT]  instance VisitType Power where   visitTypeName _ _ = id

@@ -39,3 +39,10 @@ getPlace "zeus" = pure "olympus" getPlace "morpheus" = pure "dreams" getPlace x = pure x++getDocsById :: Monad m => ID -> m (Maybe Text)+getDocsById "morpheus" = pure $ Just "the god of dreams"+getDocsById "zeus" = pure $ Just "the king of the gods"+getDocsById "olympus" = pure $ Just "Mountain"+getDocsById "dreams" = pure $ Just "Dreams"+getDocsById _ = pure Nothing

@@ -7,6 +7,7 @@  import Data.Morpheus.Server.CodeGen.Internal import Data.Morpheus.Server.Types+import Feature.NamedResolvers.Scalars (Markdown)  data Power   = Shapeshifting@@ -18,7 +19,8 @@  data Deity m = Deity   { name :: m Text,-    power :: m [Power]+    power :: m [Power],+    description :: m Markdown   }   deriving (Generic) 

@@ -42,8 +42,9 @@       pure $         Just           Deity-            { name = lift (getDeityName uid),-              power = resolve (getPowers uid)+            { name = resolve (getDeityName uid),+              power = resolve (getPowers uid),+              description = resolve (pure uid)             } getDeity _ = pure Nothing 

@@ -0,0 +1,27 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeFamilies #-}++module Feature.NamedResolvers.Entities where++import Data.Morpheus.Server.CodeGen.Internal+import Data.Morpheus.Server.Types+import Feature.NamedResolvers.Realms (Deity, Realm)++data Entity m+  = EntityDeity (m (Deity m))+  | EntityRealm (m (Realm m))+  deriving (Generic)++instance (Typeable m) => GQLType (Entity m) where+  type KIND (Entity m) = TYPE++data Query m = Query+  { entities :: m [Entity m],+    entity :: Arg "id" ID -> m (Maybe (Entity m))+  }+  deriving (Generic)++instance (Typeable m) => GQLType (Query m) where+  type KIND (Query m) = TYPE

@@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -25,7 +24,6 @@   ( App,     Arg (..),     GQLError,-    GQLType (..),     ID,     Undefined,   )@@ -33,17 +31,9 @@   ( allDeities,     allEntities,   )-import Feature.NamedResolvers.RealmsApp (Deity, Realm)-import GHC.Generics (Generic)---- Entity-data Entity m-  = EntityDeity (m (Deity m))-  | EntityRealm (m (Realm m))-  deriving-    ( Generic,-      GQLType-    )+import Feature.NamedResolvers.DeitiesApp ()+import Feature.NamedResolvers.Entities (Entity (..), Query (..))+import Feature.NamedResolvers.RealmsApp ()  getEntity :: (MonadError GQLError m) => ID -> m (Entity (NamedResolverT m)) getEntity name | name `elem` allDeities = pure $ EntityDeity $ resolve $ pure name@@ -53,16 +43,6 @@   type Dep (Entity (NamedResolverT m)) = ID   resolveBatched = ignoreBatching getEntity --- QUERY-data Query m = Query-  { entities :: m [Entity m],-    entity :: Arg "id" ID -> m (Maybe (Entity m))-  }-  deriving-    ( Generic,-      GQLType-    )- instance ResolveNamed m (Query (NamedResolverT m)) where   type Dep (Query (NamedResolverT m)) = ()   resolveBatched =@@ -75,8 +55,4 @@             }  entitiesApp :: App () IO-entitiesApp =-  deriveApp-    ( NamedResolvers ::-        NamedResolvers IO () Query Undefined Undefined-    )+entitiesApp = deriveApp (NamedResolvers :: NamedResolvers IO () Query Undefined Undefined)

@@ -7,10 +7,12 @@  import Data.Morpheus.Server.CodeGen.Internal import Data.Morpheus.Server.Types+import Feature.NamedResolvers.Scalars (Markdown)  data Realm m = Realm   { name :: m Text,-    owner :: m (Deity m)+    owner :: m (Deity m),+    description :: m Markdown   }   deriving (Generic) 

@@ -13,7 +13,6 @@   ) where -import Control.Monad.Except import Data.Morpheus.Server   ( deriveApp,   )@@ -45,8 +44,9 @@       pure $         Just           Realm-            { name = lift (getRealmName uid),-              owner = resolve (getOwner uid)+            { name = resolve (getRealmName uid),+              owner = resolve (getOwner uid),+              description = resolve (pure uid)             } getRealm _ = pure Nothing 

@@ -0,0 +1,38 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Feature.NamedResolvers.Scalars+  ( Markdown,+  )+where++import Data.Morpheus.Server.Resolvers+  ( ResolveNamed (..),+  )+import Data.Morpheus.Server.Types+  ( DecodeScalar (..),+    EncodeScalar (..),+    GQLType (..),+    ID,+    SCALAR,+  )+import Data.Text (Text)+import Feature.NamedResolvers.DB+  ( getDocsById,+  )++newtype Markdown = Markdown Text+  deriving newtype+    ( DecodeScalar,+      EncodeScalar+    )++instance GQLType Markdown where+  type KIND Markdown = SCALAR++instance ResolveNamed m Markdown where+  type Dep Markdown = ID+  resolveBatched = traverse (fmap (fmap Markdown) . getDocsById)

@@ -1,3 +1,5 @@+scalar Markdown+ enum Power {   Shapeshifting   Thunderbolt@@ -6,6 +8,7 @@ type Deity {   name: String!   power: [Power!]!+  description: Markdown! }  type Query {

@@ -0,0 +1,6 @@+union Entity = Deity | Realm++type Query {+  entities: [Entity!]!+  entity(id: ID!): Entity+}

@@ -1,6 +1,9 @@+scalar Markdown+ type Realm {   name: String!   owner: Deity!+  description: Markdown! }  type Deity {

@@ -0,0 +1,5 @@+query {+  deities {+    description+  }+}

@@ -0,0 +1,12 @@+{+  "data": {+    "deities": [+      {+        "description": "the king of the gods"+      },+      {+        "description": "the god of dreams"+      }+    ]+  }+}

@@ -0,0 +1,5 @@+query {+  realms {+    description+  }+}

@@ -0,0 +1,12 @@+{+  "data": {+    "realms": [+      {+        "description": "Mountain"+      },+      {+        "description": "Dreams"+      }+    ]+  }+}