morpheus-graphql 0.20.1 → 0.21.0

raw patch · 47 files changed

+2350/−790 lines, 47 filesdep +file-embeddep ~morpheus-graphql-appdep ~morpheus-graphql-code-gendep ~morpheus-graphql-corePVP ok

version bump matches the API change (PVP)

Dependencies added: file-embed

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

API changes (from Hackage documentation)

Files

• morpheus-graphql.cabal +28/−10
• src/Data/Morpheus/Server/Deriving/Channels.hs +23/−10
• src/Data/Morpheus/Server/Deriving/Decode.hs +50/−99
• src/Data/Morpheus/Server/Deriving/Encode.hs +25/−11
• src/Data/Morpheus/Server/Deriving/Named/Encode.hs +6/−6
• src/Data/Morpheus/Server/Deriving/Named/EncodeType.hs +5/−11
• src/Data/Morpheus/Server/Deriving/Named/EncodeValue.hs +35/−18
• src/Data/Morpheus/Server/Deriving/Schema.hs +36/−41
• src/Data/Morpheus/Server/Deriving/Schema/Directive.hs +138/−0
• src/Data/Morpheus/Server/Deriving/Schema/Enum.hs +13/−10
• src/Data/Morpheus/Server/Deriving/Schema/Internal.hs +5/−37
• src/Data/Morpheus/Server/Deriving/Schema/Object.hs +21/−19
• src/Data/Morpheus/Server/Deriving/Schema/TypeContent.hs +52/−2
• src/Data/Morpheus/Server/Deriving/Schema/Union.hs +2/−6
• src/Data/Morpheus/Server/Deriving/Utils.hs +7/−258
• src/Data/Morpheus/Server/Deriving/Utils/Decode.hs +39/−1
• src/Data/Morpheus/Server/Deriving/Utils/DeriveGType.hs +158/−0
• src/Data/Morpheus/Server/Deriving/Utils/GTraversable.hs +4/−1
• src/Data/Morpheus/Server/Deriving/Utils/Proxy.hs +75/−0
• src/Data/Morpheus/Server/Deriving/Utils/Types.hs +76/−0
• src/Data/Morpheus/Server/Playground.hs +2/−2
• src/Data/Morpheus/Server/TH/Compile.hs +1/−1
• src/Data/Morpheus/Server/TH/Declare.hs +8/−1
• src/Data/Morpheus/Server/TH/Declare/GQLDirective.hs +84/−0
• src/Data/Morpheus/Server/TH/Declare/GQLType.hs +67/−33
• src/Data/Morpheus/Server/TH/Declare/Type.hs +11/−8
• src/Data/Morpheus/Server/Types/DirectiveDefinitions.hs +68/−0
• src/Data/Morpheus/Server/Types/Directives.hs +188/−0
• src/Data/Morpheus/Server/Types/GQLType.hs +178/−101
• src/Data/Morpheus/Server/Types/Internal.hs +98/−0
• src/Data/Morpheus/Server/Types/SchemaT.hs +62/−28
• src/Data/Morpheus/Server/Types/TypeName.hs +86/−0
• src/Data/Morpheus/Server/Types/Visitors.hs +40/−0
• src/Data/Morpheus/Types.hs +41/−8
• test/Feature/Directive/Definition.hs +99/−0
• test/Feature/Directive/definition/introspect-directive/query.gql +53/−0
• test/Feature/Directive/definition/introspect-directive/response.json +121/−0
• test/Feature/Directive/definition/introspect-enum/query.gql +76/−0
• test/Feature/Directive/definition/introspect-enum/response.json +39/−0
• test/Feature/Directive/definition/introspect-type/query.gql +79/−0
• test/Feature/Directive/definition/introspect-type/response.json +56/−0
• test/Feature/Holistic/API.hs +9/−3
• test/Feature/Holistic/holistic/introspection/directives/default/response.json +24/−24
• test/Rendering/Schema.hs +12/−4
• test/Rendering/schema.gql +9/−7
• test/Spec.hs +5/−0
• test/Subscription/Utils.hs +36/−30

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           morpheus-graphql-version:        0.20.1+version:        0.21.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -24,6 +24,9 @@     test/Feature/Collision/category-collision-fail/query.gql     test/Feature/Collision/category-collision-success/query.gql     test/Feature/Collision/name-collision/query.gql+    test/Feature/Directive/definition/introspect-directive/query.gql+    test/Feature/Directive/definition/introspect-enum/query.gql+    test/Feature/Directive/definition/introspect-type/query.gql     test/Feature/Holistic/holistic/arguments/nameConflict/query.gql     test/Feature/Holistic/holistic/arguments/undefinedArgument/query.gql     test/Feature/Holistic/holistic/arguments/unknownArguments/query.gql@@ -236,6 +239,9 @@     test/Feature/Collision/category-collision-fail/response.json     test/Feature/Collision/category-collision-success/response.json     test/Feature/Collision/name-collision/response.json+    test/Feature/Directive/definition/introspect-directive/response.json+    test/Feature/Directive/definition/introspect-enum/response.json+    test/Feature/Directive/definition/introspect-type/response.json     test/Feature/Holistic/holistic/arguments/nameConflict/response.json     test/Feature/Holistic/holistic/arguments/undefinedArgument/response.json     test/Feature/Holistic/holistic/arguments/unknownArguments/response.json@@ -479,6 +485,7 @@       Data.Morpheus.Server.Deriving.Named.EncodeType       Data.Morpheus.Server.Deriving.Named.EncodeValue       Data.Morpheus.Server.Deriving.Schema+      Data.Morpheus.Server.Deriving.Schema.Directive       Data.Morpheus.Server.Deriving.Schema.Enum       Data.Morpheus.Server.Deriving.Schema.Internal       Data.Morpheus.Server.Deriving.Schema.Object@@ -486,17 +493,26 @@       Data.Morpheus.Server.Deriving.Schema.Union       Data.Morpheus.Server.Deriving.Utils       Data.Morpheus.Server.Deriving.Utils.Decode+      Data.Morpheus.Server.Deriving.Utils.DeriveGType       Data.Morpheus.Server.Deriving.Utils.GTraversable       Data.Morpheus.Server.Deriving.Utils.Kinded+      Data.Morpheus.Server.Deriving.Utils.Proxy+      Data.Morpheus.Server.Deriving.Utils.Types       Data.Morpheus.Server.Playground       Data.Morpheus.Server.TH.Compile       Data.Morpheus.Server.TH.Declare+      Data.Morpheus.Server.TH.Declare.GQLDirective       Data.Morpheus.Server.TH.Declare.GQLType       Data.Morpheus.Server.TH.Declare.Type       Data.Morpheus.Server.TH.Utils+      Data.Morpheus.Server.Types.DirectiveDefinitions+      Data.Morpheus.Server.Types.Directives       Data.Morpheus.Server.Types.GQLType+      Data.Morpheus.Server.Types.Internal       Data.Morpheus.Server.Types.SchemaT+      Data.Morpheus.Server.Types.TypeName       Data.Morpheus.Server.Types.Types+      Data.Morpheus.Server.Types.Visitors       Paths_morpheus_graphql   hs-source-dirs:       src@@ -506,9 +522,9 @@     , 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.20.0 && <0.21.0-    , morpheus-graphql-code-gen >=0.20.0 && <0.21.0-    , morpheus-graphql-core >=0.20.0 && <0.21.0+    , morpheus-graphql-app >=0.21.0 && <0.22.0+    , morpheus-graphql-code-gen >=0.21.0 && <0.22.0+    , morpheus-graphql-core >=0.21.0 && <0.22.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , template-haskell >=2.0.0 && <3.0.0@@ -526,6 +542,7 @@       Feature.Collision.CategoryCollisionSuccess       Feature.Collision.NameCollision       Feature.Collision.NameCollisionHelper+      Feature.Directive.Definition       Feature.Holistic.API       Feature.Inference.ObjectAndEnum       Feature.Inference.TaggedArguments@@ -560,12 +577,13 @@     , base >=4.7.0 && <5.0.0     , 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-    , morpheus-graphql-app >=0.20.0 && <0.21.0-    , morpheus-graphql-code-gen >=0.20.0 && <0.21.0-    , morpheus-graphql-core >=0.20.0 && <0.21.0-    , morpheus-graphql-subscriptions >=0.20.0 && <0.21.0-    , morpheus-graphql-tests >=0.20.0 && <0.21.0+    , morpheus-graphql-app >=0.21.0 && <0.22.0+    , morpheus-graphql-code-gen >=0.21.0 && <0.22.0+    , morpheus-graphql-core >=0.21.0 && <0.22.0+    , morpheus-graphql-subscriptions >=0.21.0 && <0.22.0+    , morpheus-graphql-tests >=0.21.0 && <0.22.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , tasty >=0.1.0 && <1.5.0

@@ -29,18 +29,22 @@   ( selectBy,   ) import Data.Morpheus.Server.Deriving.Decode-  ( DecodeConstraint,+  ( Decode,     decodeArguments,   ) import Data.Morpheus.Server.Deriving.Utils   ( ConsRep (..),     DataType (..),     FieldRep (..),-    TypeConstraint (..),-    TypeRep (..),-    toValue,   )-import Data.Morpheus.Server.Types.GQLType (GQLType)+import Data.Morpheus.Server.Deriving.Utils.DeriveGType+  ( DeriveValueOptions (..),+    DeriveWith,+    deriveValue,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (..), kinded)+import Data.Morpheus.Server.Types.GQLType (GQLType (typeOptions), deriveTypename, __typeData)+import Data.Morpheus.Server.Types.Internal (defaultTypeOptions) import Data.Morpheus.Server.Types.Types (Undefined) import Data.Morpheus.Types.Internal.AST   ( FieldName,@@ -112,7 +116,7 @@   getChannel x = const $ pure $ DerivedChannel $ channel x  instance-  DecodeConstraint arg =>+  Decode arg =>   GetChannel e (arg -> SubscriptionField (Resolver SUBSCRIPTION e m a))   where   getChannel f sel@Selection {selectionArguments} =@@ -129,14 +133,23 @@ class ExploreChannels (t :: Bool) e a where   exploreChannels :: f t -> a -> HashMap FieldName (ChannelRes e) -instance (GQLType a, Generic a, TypeRep (GetChannel e) (ChannelRes e) (Rep a)) => ExploreChannels 'False e a where+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   exploreChannels _ =     HM.fromList       . convertNode-      . toValue-        ( TypeConstraint (getChannel . runIdentity) :: TypeConstraint (GetChannel e) (ChannelRes e) Identity+      . deriveValue+        ( DeriveValueOptions+            { __valueApply = getChannel,+              __valueTypeName = deriveTypename (KindedProxy :: KindedProxy OUT a),+              __valueGQLOptions = typeOptions (Proxy @a) defaultTypeOptions,+              __valueGetType = __typeData . kinded (Proxy @OUT)+            } ::+            DeriveValueOptions OUT (ChannelConstraint e) (ChannelRes e)         )-        (Proxy @OUT)  instance ExploreChannels 'True e (Undefined m) where   exploreChannels _ = pure HM.empty

@@ -15,8 +15,8 @@  module Data.Morpheus.Server.Deriving.Decode   ( decodeArguments,-    Decode (..),-    DecodeConstraint,+    Decode,+    decode,   ) where @@ -38,10 +38,16 @@     symbolName,   ) import Data.Morpheus.Server.Deriving.Utils.Decode-  ( decodeFieldWith,+  ( Context (..),+    DecoderT,+    Info (..),+    Tag (..),+    decodeFieldWith,+    getFieldName,     handleEither,     withInputObject,     withInputUnion,+    withKind,     withScalar,   ) import Data.Morpheus.Server.Deriving.Utils.Kinded@@ -52,11 +58,11 @@       ( KIND,         typeOptions       ),-    GQLTypeOptions (..),-    TypeData (..),-    __typeData,-    defaultTypeOptions,+    deriveTypename,   )+import Data.Morpheus.Server.Types.Internal+  ( defaultTypeOptions,+  ) import Data.Morpheus.Server.Types.Types (Arg (Arg)) import Data.Morpheus.Types.GQLScalar   ( DecodeScalar (..),@@ -68,8 +74,6 @@ import Data.Morpheus.Types.Internal.AST   ( Argument (..),     Arguments,-    FieldName,-    GQLError,     IN,     LEAF,     Object,@@ -86,20 +90,16 @@ import GHC.TypeLits (KnownSymbol) import Relude -type DecodeConstraint a = (DecodeKind (KIND a) a)- -- GENERIC-decodeArguments :: forall a. DecodeConstraint a => Arguments VALID -> ResolverState a-decodeArguments = decodeKind (Proxy @(KIND a)) . Object . fmap toEntry+decodeArguments :: forall a. Decode a => Arguments VALID -> ResolverState a+decodeArguments = decode . Object . fmap toEntry   where     toEntry Argument {..} = ObjectEntry argumentName argumentValue --- | Decode GraphQL query arguments and input values-class Decode a where-  decode :: ValidValue -> ResolverState a+type Decode a = (DecodeKind (KIND a) a) -instance DecodeKind (KIND a) a => Decode a where-  decode = decodeKind (Proxy @(KIND a))+decode :: forall a. Decode a => ValidValue -> ResolverState a+decode = decodeKind (Proxy @(KIND a))  -- | Decode GraphQL type with Specific Kind class DecodeKind (kind :: DerivingKind) a where@@ -107,7 +107,7 @@  -- SCALAR instance (DecodeScalar a, GQLType a) => DecodeKind SCALAR a where-  decodeKind _ = withScalar (gqlTypeName $ __typeData (KindedProxy :: KindedProxy LEAF a)) decodeScalar+  decodeKind _ = withScalar (deriveTypename (KindedProxy :: KindedProxy LEAF a)) decodeScalar  -- INPUT_OBJECT and  INPUT_UNION instance@@ -123,7 +123,7 @@         Context           { options = typeOptions (Proxy @a) defaultTypeOptions,             contKind = D_CONS,-            typeName = gqlTypeName $ __typeData (KindedProxy :: KindedProxy IN a)+            typeName = deriveTypename (KindedProxy :: KindedProxy IN a)           }  instance (Decode a, DecodeWrapperConstraint f a, DecodeWrapper f) => DecodeKind WRAPPER (f a) where@@ -141,33 +141,21 @@ instance (Ord k, Decode (k, v)) => DecodeKind CUSTOM (Map k v) where   decodeKind _ v = M.fromList <$> (decode v :: ResolverState [(k, v)]) --- data Input  =---    InputHuman Human  -- direct link: { __typename: Human, Human: {field: ""} }---   | InputRecord { name :: Text, age :: Int } -- { __typename: InputRecord, InputRecord: {field: ""} }---   | IndexedType Int Text  -- { __typename: InputRecord, _0:2 , _1:""  }---   | Zeus                 -- { __typename: Zeus }---     deriving (Generic, GQLType)- decideUnion ::-  ( Functor m,-    MonadError GQLError m-  ) =>-  ([TypeName], value -> m (f1 a)) ->-  ([TypeName], value -> m (f2 a)) ->+  (DecodeRep f1, DecodeRep f2) =>+  ([TypeName], [TypeName]) ->   TypeName ->-  value ->-  m ((:+:) f1 f2 a)-decideUnion (left, f1) (right, f2) name value-  | name `elem` left =-    L1 <$> f1 value-  | name `elem` right =-    R1 <$> f2 value+  ValidValue ->+  DecoderT ((:+:) f1 f2 a)+decideUnion (left, right) name value+  | name `elem` left = L1 <$> decodeRep value+  | name `elem` right = R1 <$> decodeRep value   | otherwise =-    throwError-      $ internal-      $ "Constructor \""-        <> msg name-        <> "\" could not find in Union"+      throwError $+        internal $+          "Constructor \""+            <> msg name+            <> "\" could not find in Union"  traverseUnion ::   (DecodeRep f, DecodeRep g) =>@@ -176,35 +164,10 @@   Object VALID ->   ValidObject ->   DecoderT ((f :+: g) a)-traverseUnion (l1, r1) name unions object-  | [name] == l1 =-    L1 <$> decodeRep (Object object)-  | [name] == r1 =-    R1 <$> decodeRep (Object object)-  | otherwise = decideUnion (l1, decodeRep) (r1, decodeRep) name (Object unions)--data Tag = D_CONS | D_UNION deriving (Eq, Ord)--data Context = Context-  { contKind :: Tag,-    typeName :: TypeName,-    options :: GQLTypeOptions-  }--data Info = Info-  { kind :: Tag,-    tagName :: [TypeName]-  }--instance Semigroup Info where-  Info D_UNION t1 <> Info _ t2 = Info D_UNION (t1 <> t2)-  Info _ t1 <> Info D_UNION t2 = Info D_UNION (t1 <> t2)-  Info D_CONS t1 <> Info D_CONS t2 = Info D_CONS (t1 <> t2)--type DecoderT = ReaderT Context ResolverState--withKind :: Tag -> DecoderT a -> DecoderT a-withKind contKind = local (\ctx -> ctx {contKind})+traverseUnion (l, r) name unions object+  | [name] == l = L1 <$> decodeRep (Object object)+  | [name] == r = R1 <$> decodeRep (Object object)+  | otherwise = decideUnion (l, r) name (Object unions)  getUnionInfos ::   forall f a b.@@ -219,9 +182,6 @@   )     <$> ask ------ GENERICS--- class DecodeRep (f :: Type -> Type) where   tags :: Proxy f -> Context -> Info   decodeRep :: ValidValue -> DecoderT (f a)@@ -235,17 +195,10 @@   decodeRep (Object obj) =     do       (left, right) <- getUnionInfos (Proxy @(a :+: b))-      withKind (kind (left <> right)) $-        withInputUnion-          (traverseUnion (tagName left, tagName right))-          obj+      withKind (kind (left <> right)) $ withInputUnion (traverseUnion (tagName left, tagName right)) obj   decodeRep (Enum name) = do     (left, right) <- getUnionInfos (Proxy @(a :+: b))-    decideUnion-      (tagName left, decodeRep)-      (tagName right, decodeRep)-      name-      (Enum name)+    decideUnion (tagName left, tagName right) name (Enum name)   decodeRep _ = throwError (internal "lists and scalars are not allowed in Union")  instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where@@ -270,24 +223,22 @@   refType _ = Nothing   countFields _ = countFields (Proxy @f) + countFields (Proxy @g)   decodeFields index gql =-    (:*:) <$> decodeFields index gql+    (:*:)+      <$> decodeFields index gql       <*> decodeFields (index + countFields (Proxy @g)) gql  instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where   countFields _ = 1-  refType _ = Just $ gqlTypeName $ __typeData (KindedProxy :: KindedProxy IN a)-  decodeFields index value = M1 . K1 <$> do-    Context {options, contKind} <- ask-    case contKind of-      D_UNION -> lift (decode value)-      D_CONS ->-        let fieldName = getFieldName (selNameProxy options (Proxy @s)) index-            fieldDecoder = decodeFieldWith (lift . decode) fieldName-         in withInputObject fieldDecoder value--getFieldName :: FieldName -> Int -> FieldName-getFieldName "" index = "_" <> show index-getFieldName label _ = label+  refType _ = Just $ deriveTypename (KindedProxy :: KindedProxy IN a)+  decodeFields index value =+    M1 . K1 <$> do+      Context {options, contKind} <- ask+      case contKind of+        D_UNION -> lift (decode value)+        D_CONS ->+          let fieldName = getFieldName (selNameProxy options (Proxy @s)) index+              fieldDecoder = decodeFieldWith (lift . decode) fieldName+           in withInputObject fieldDecoder value  instance DecodeFields U1 where   countFields _ = 0

@@ -49,29 +49,35 @@     channelResolver,   ) import Data.Morpheus.Server.Deriving.Decode-  ( DecodeConstraint,+  ( Decode,     decodeArguments,   ) import Data.Morpheus.Server.Deriving.Utils   ( ConsRep (..),     DataType (..),     FieldRep (..),-    TypeConstraint (..),-    TypeRep (..),     isUnionRef,     toFieldRes,-    toValue,   )+import Data.Morpheus.Server.Deriving.Utils.DeriveGType+  ( DeriveValueOptions (..),+    DeriveWith,+    deriveValue,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (KindedProxy), kinded) import Data.Morpheus.Server.Types.GQLType-  ( GQLType,+  ( GQLType (typeOptions),     KIND,+    deriveTypename,     __isEmptyType,+    __typeData,   ) import Data.Morpheus.Server.Types.Types   ( TypeGuard (..),   ) import Data.Morpheus.Types   ( RootResolver (..),+    defaultTypeOptions,   ) import Data.Morpheus.Types.GQLScalar   ( EncodeScalar (..),@@ -141,7 +147,7 @@  --  GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY instance-  ( DecodeConstraint a,+  ( Decode a,     Generic a,     Monad m,     Encode (Resolver o e m) b,@@ -187,6 +193,10 @@       encodeTypeFields fields = mkUnion consName (toFieldRes <$> 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,@@ -196,11 +206,15 @@   ResolverValue m exploreResolvers =   convertNode-    . toValue-      ( TypeConstraint (encode . runIdentity) ::-          TypeConstraint (Encode m) (m (ResolverValue m)) Identity+    . deriveValue+      ( DeriveValueOptions+          { __valueApply = encode,+            __valueTypeName = deriveTypename (KindedProxy :: KindedProxy IN a),+            __valueGQLOptions = typeOptions (Proxy @a) defaultTypeOptions,+            __valueGetType = __typeData . kinded (Proxy @IN)+          } ::+          DeriveValueOptions IN (ExplorerConstraint m) (m (ResolverValue m))       )-      (Proxy @IN)  ----- HELPERS ---------------------------- objectResolvers ::@@ -214,7 +228,7 @@ type EncodeConstraint (m :: Type -> Type) a =   ( GQLType a,     Generic a,-    TypeRep (Encode m) (m (ResolverValue m)) (Rep a)+    DeriveWith (ExplorerConstraint m) (m (ResolverValue m)) (Rep a)   )  type EncodeObjectConstraint (o :: OperationType) e (m :: Type -> Type) a =

@@ -48,9 +48,9 @@   NamedResolvers m e query mut sub ->   RootResolverValue e m deriveNamedModel NamedResolvers =-  NamedResolversValue-    $ HM.fromList-    $ map (\x -> (resolverName x, x))-    $ join-    $ toList-    $ traverseTypes deriveResolver (Proxy @(query (NamedResolverT (Resolver QUERY e m))))+  NamedResolversValue $+    HM.fromList $+      map (\x -> (resolverName x, x)) $+        join $+          toList $+            traverseTypes deriveResolver (Proxy @(query (NamedResolverT (Resolver QUERY e m))))

@@ -23,7 +23,6 @@     NamedResolver (..),     Resolver,     ResolverState,-    ResolverValue,     liftResolverState,   ) import Data.Morpheus.Kind@@ -35,17 +34,15 @@   ) import Data.Morpheus.NamedResolvers (NamedResolverT (..), ResolveNamed (Dep, resolveNamed)) import Data.Morpheus.Server.Deriving.Decode-  ( Decode (decode),+  ( Decode,+    decode,   ) import Data.Morpheus.Server.Deriving.Named.EncodeValue-  ( Encode,-    EncodeFieldKind,+  ( EncodeFieldKind,+    FieldConstraint,     encodeResolverValue,     getTypeName,   )-import Data.Morpheus.Server.Deriving.Utils-  ( TypeRep (..),-  ) import Data.Morpheus.Server.Deriving.Utils.GTraversable import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (KindedProxy)) import Data.Morpheus.Server.Types.GQLType@@ -55,9 +52,6 @@ import Data.Morpheus.Types.Internal.AST   ( ValidValue,   )-import GHC.Generics-  ( Generic (..),-  ) import Relude  deriveResolver :: Mappable (DeriveNamedResolver m) [NamedResolver m] KindedProxy@@ -89,7 +83,7 @@     EncodeFieldKind (KIND a) (Resolver o e m) a,     Decode (Dep a),     ResolveNamed (Resolver o e m) a,-    TypeRep (Encode (Resolver o e m)) (Resolver o e m (ResolverValue (Resolver o e m))) (Rep a)+    FieldConstraint (Resolver o e m) a   ) =>   DeriveNamedResolver (Resolver o e m) TYPE (a :: Type)   where

@@ -19,6 +19,7 @@     Encode,     getTypeName,     encodeResolverValue,+    FieldConstraint,   ) where @@ -48,7 +49,7 @@     ResolveNamed (..),   ) import Data.Morpheus.Server.Deriving.Decode-  ( DecodeConstraint,+  ( Decode,     decodeArguments,   ) import Data.Morpheus.Server.Deriving.Encode@@ -58,16 +59,24 @@   ( ConsRep (..),     DataType (..),     FieldRep (..),-    TypeConstraint (..),-    TypeRep (..),     toFieldRes,-    toValue,   )+import Data.Morpheus.Server.Deriving.Utils.DeriveGType+  ( DeriveValueOptions (..),+    DeriveWith,+    deriveValue,+  )+import Data.Morpheus.Server.Deriving.Utils.Kinded import Data.Morpheus.Server.Types.GQLType-  ( GQLType (__type),+  ( GQLType (typeOptions, __type),     KIND,-    TypeData (gqlTypeName),+    deriveTypename,+    __typeData,   )+import Data.Morpheus.Server.Types.Internal+  ( TypeData (gqlTypeName),+  )+import Data.Morpheus.Types (defaultTypeOptions) import Data.Morpheus.Types.GQLScalar   ( EncodeScalar (..),   )@@ -91,7 +100,7 @@ type FieldConstraint m a =   ( GQLType a,     Generic a,-    TypeRep (Encode m) (m (ResolverValue m)) (Rep a)+    DeriveWith (GValueMapConstraint m) (m (ResolverValue m)) (Rep a)   )  class Encode (m :: Type -> Type) res where@@ -134,7 +143,7 @@       encodeRef (Refs refs) = mkList . map (ResRef . pure . NamedResolverRef name . replaceValue . toJSON) <$> refs  instance-  ( DecodeConstraint a,+  ( Decode a,     Generic a,     Monad m,     Encode (Resolver o e m) b,@@ -147,13 +156,21 @@       >>= liftResolverState . decodeArguments       >>= encodeField . f -getFieldValues :: FieldConstraint m a => a -> DataType (m (ResolverValue m))+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 =-  toValue-    ( TypeConstraint (encodeField . runIdentity) ::-        TypeConstraint (Encode m) (m (ResolverValue m)) Identity+  deriveValue+    ( DeriveValueOptions+        { __valueApply = encodeField,+          __valueTypeName = deriveTypename (KindedProxy :: KindedProxy OUT a),+          __valueGQLOptions = typeOptions (Proxy @a) defaultTypeOptions,+          __valueGetType = __typeData . kinded (Proxy @OUT)+        } ::+        DeriveValueOptions OUT (GValueMapConstraint m) (m (ResolverValue m))     )-    (Proxy @OUT)  convertNamedNode ::   MonadError GQLError m =>@@ -167,11 +184,11 @@     | null consFields = pure $ NamedEnumResolver consName     | tyIsUnion = deriveUnion consFields     | otherwise =-      pure $-        NamedObjectResolver-          ObjectTypeResolver-            { objectFields = HM.fromList (toFieldRes <$> consFields)-            }+        pure $+          NamedObjectResolver+            ObjectTypeResolver+              { objectFields = HM.fromList (toFieldRes <$> consFields)+              }  deriveUnion :: (MonadError GQLError m) => [FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m) deriveUnion [FieldRep {..}] =

@@ -13,6 +13,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-orphans #-}  module Data.Morpheus.Server.Deriving.Schema   ( compileTimeSchemaValidation,@@ -23,12 +24,11 @@   ) where --- MORPHEUS- import Control.Monad.Except (throwError) import Data.Morpheus.App.Internal.Resolving   ( Resolver,   )+import Data.Morpheus.CodeGen.Internal.AST import Data.Morpheus.Core (defaultConfig, validateSchema) import Data.Morpheus.Internal.Ext import Data.Morpheus.Internal.Utils (singleton)@@ -43,7 +43,6 @@   ( KindedType (..),     TyContentM,     fromSchema,-    updateByContent,   ) import Data.Morpheus.Server.Deriving.Schema.Object   ( asObjectType,@@ -51,26 +50,25 @@   ) import Data.Morpheus.Server.Deriving.Schema.TypeContent import Data.Morpheus.Server.Deriving.Utils-  ( TypeConstraint (..),-    TypeRep (..),-    deriveTypeRef,+  ( DeriveTypeOptions (..),+    DeriveWith,     symbolName,-    toRep,-    unpackMonad,-    withKind,   ) import Data.Morpheus.Server.Deriving.Utils.Kinded   ( CategoryValue (..),     KindedProxy (..),     inputType,+    kinded,     outputType,     setKind,   ) import Data.Morpheus.Server.Types.GQLType-  ( GQLType (..),-    TypeData (..),+  ( DeriveArguments (..),+    GQLType (..),+    deriveTypename,     __typeData,   )+import Data.Morpheus.Server.Types.Internal (TypeData (..), defaultTypeOptions) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,     extendImplements,@@ -86,9 +84,7 @@     scalarValidator,   ) import Data.Morpheus.Types.Internal.AST-  ( ArgumentsDefinition,-    CONST,-    FieldContent (..),+  ( FieldContent (..),     FieldsDefinition,     IN,     LEAF,@@ -102,12 +98,11 @@     TypeCategory,     TypeContent (..),     TypeDefinition (..),-    TypeName,     UnionMember (memberName),     fieldsToArguments,     mkField,   )-import GHC.Generics (Rep)+import GHC.Generics import GHC.TypeLits import Language.Haskell.TH (Exp, Q) import Relude@@ -119,10 +114,8 @@   )  type DeriveTypeConstraintOpt kind a =-  ( Generic a,-    GQLType a,-    TypeRep (DeriveType kind) (TyContentM kind) (Rep a),-    TypeRep (DeriveType kind) (SchemaT kind ()) (Rep a)+  ( GQLType a,+    DeriveWith (DeriveWithConstraint kind) (TyContentM kind) (Rep a)   )  -- | normal morpheus server validates schema at runtime (after the schema derivation).@@ -182,12 +175,11 @@     CategoryValue kind   ) --- SCALAR 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 = updateByContent deriveScalarContent . setKind (Proxy @LEAF)+  deriveKindedType = insertTypeContent deriveScalarContent . setKind (Proxy @LEAF)  instance DeriveTypeConstraint OUT a => DeriveKindedType OUT TYPE a where   deriveKindedType = deriveOutputType@@ -198,7 +190,6 @@ instance DeriveType cat a => DeriveKindedType cat CUSTOM (Resolver o e m a) where   deriveKindedType _ = deriveType (Proxy @a) --- Map instance DeriveType cat [(k, v)] => DeriveKindedType cat CUSTOM (Map k v) where   deriveKindedType _ = deriveType (Proxy @[(k, v)]) @@ -209,20 +200,20 @@   DeriveKindedType OUT CUSTOM (TypeGuard interface union)   where   deriveKindedType _ = do-    updateByContent deriveInterfaceContent interfaceProxy+    insertTypeContent deriveInterfaceContent interfaceProxy     content <- deriveTypeContent (OutputType :: KindedType OUT union)     unionNames <- getUnionNames content     extendImplements interfaceName unionNames     where       interfaceName :: TypeName-      interfaceName = gqlTypeName (__typeData interfaceProxy)+      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 [gqlTypeName (__typeData unionProxy)]+      getUnionNames DataObject {} = pure [deriveTypename unionProxy]       getUnionNames _ = throwError "guarded type must be an union or object"  instance@@ -233,7 +224,7 @@   DeriveKindedType OUT CUSTOM (a -> b)   where   deriveKindedContent _ = do-    a <- deriveArgumentsDefinition (withKind (Proxy @a))+    a <- deriveArgumentsDefinition (KindedProxy :: KindedProxy (KIND a) a)     b <- deriveKindedContent (KindedProxy :: KindedProxy (KIND b) b)     case b of       Just (FieldArgs x) -> Just . FieldArgs <$> (a <:> x)@@ -246,9 +237,6 @@ deriveInterfaceContent :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT (TypeContent TRUE OUT CONST) deriveInterfaceContent = fmap DataInterface . deriveFields . outputType -class DeriveArguments (k :: DerivingKind) a where-  deriveArgumentsDefinition :: f k a -> SchemaT OUT (ArgumentsDefinition CONST)- instance DeriveTypeConstraint IN a => DeriveArguments TYPE a where   deriveArgumentsDefinition = withInput . fmap fieldsToArguments . deriveFields . inputType @@ -260,16 +248,17 @@       proxy :: KindedProxy IN a       proxy = KindedProxy       argName = symbolName (Proxy @name)-      argTypeRef = deriveTypeRef proxy+      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 = updateByContent deriveTypeContent . inputType+deriveInputType = insertTypeContent deriveTypeContent . inputType  deriveOutputType :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT ()-deriveOutputType = updateByContent deriveTypeContent . outputType+deriveOutputType = insertTypeContent deriveTypeContent . outputType  deriveRoot :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT (TypeDefinition OBJECT CONST) deriveRoot = asObjectType (deriveFields . outputType)@@ -277,24 +266,30 @@ deriveMaybeRoot :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT (Maybe (TypeDefinition OBJECT CONST)) deriveMaybeRoot proxy   | __isEmptyType proxy =-    pure Nothing+      pure Nothing   | otherwise = Just <$> asObjectType (deriveFields . outputType) proxy -fieldContentConstraint :: f kind a -> TypeConstraint (DeriveType kind) (TyContentM kind) Proxy-fieldContentConstraint _ = TypeConstraint deriveFieldContent- 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+ deriveTypeContent ::   forall kind a.   DeriveTypeConstraint kind a =>   KindedType kind a ->   SchemaT kind (TypeContent TRUE kind CONST)-deriveTypeContent kindedProxy =-  unpackMonad-    (toRep (fieldContentConstraint kindedProxy) kindedProxy)-    >>= buildTypeContent kindedProxy+deriveTypeContent =+  deriveTypeContentWith+    ( DeriveTypeDefinitionOptions+        { __typeGQLOptions = typeOptions (Proxy @a) defaultTypeOptions,+          __typeGetType = __typeData . kinded (Proxy @kind),+          __typeApply = deriveFieldContent+        } ::+        DeriveTypeOptions kind (DeriveWithConstraint kind) (TyContentM kind)+    )

@@ -0,0 +1,138 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Schema.Directive+  ( deriveFieldDirectives,+    deriveTypeDirectives,+    deriveEnumDirectives,+  )+where++import Control.Monad.Except (throwError)+import qualified Data.HashMap.Lazy as HM+import qualified Data.Map as M+import Data.Morpheus.CodeGen.Internal.AST (CONST, TypeName)+import Data.Morpheus.Internal.Ext (resultOr, unsafeFromList)+import Data.Morpheus.Internal.Utils (Empty (..), (<:>))+import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( KindedProxy (..),+  )+import Data.Morpheus.Server.Types.Directives+  ( GQLDirective (..),+    ToLocations,+    getLocations,+  )+import Data.Morpheus.Server.Types.GQLType+  ( DeriveArguments (..),+    DirectiveUsage (..),+    DirectiveUsages (..),+    GQLType (..),+    deriveFingerprint,+    deriveTypename,+    encodeArguments,+  )+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+    insertDirectiveDefinition,+    outToAny,+  )+import Data.Morpheus.Types.Internal.AST+  ( Directive (..),+    DirectiveDefinition (..),+    Directives,+    FieldName,+    IN,+    Position (Position),+    unpackName,+  )+import GHC.Generics ()+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) =>+  a ->+  b ->+  SchemaT kind (DirectiveDefinition CONST)+deriveDirectiveDefinition _ _ = do+  directiveDefinitionArgs <- outToAny (deriveArgumentsDefinition (KindedProxy :: KindedProxy (KIND a) a))+  pure+    ( DirectiveDefinition+        { directiveDefinitionName = deriveDirectiveName proxy,+          directiveDefinitionDescription = description proxy,+          directiveDefinitionArgs,+          directiveDefinitionLocations = getLocations proxy+        }+    )+  where+    proxy = Proxy @a++deriveTypeDirectives :: forall c f a. GQLType a => f a -> SchemaT c (Directives CONST)+deriveTypeDirectives proxy = deriveDirectiveUsages (typeDirectives $ directives proxy)++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)++toDirectiveTuple :: DirectiveUsage -> SchemaT c (FieldName, Directive CONST)+toDirectiveTuple (DirectiveUsage x) = do+  insertDirective (deriveDirectiveDefinition x) x+  let directiveName = deriveDirectiveName (Identity x)+  directiveArgs <- resultOr (const $ throwError "TODO: fix me") pure (encodeArguments x)+  pure+    ( directiveName,+      Directive+        { directivePosition = Position 0 0,+          directiveName,+          directiveArgs+        }+    )++insertDirective ::+  forall a c.+  (GQLType a) =>+  (KindedProxy IN a -> SchemaT c (DirectiveDefinition CONST)) ->+  a ->+  SchemaT c ()+insertDirective f _ = insertDirectiveDefinition (deriveFingerprint proxy) f proxy+  where+    proxy = KindedProxy :: KindedProxy IN a++getDir :: (Ord k, Empty a) => k -> Map k a -> a+getDir name xs = fromMaybe empty $ name `M.lookup` xs++getDirHM :: (Ord k, Hashable k, Empty a) => k -> HashMap k a -> a+getDirHM name xs = fromMaybe empty $ name `HM.lookup` xs++deriveFieldDirectives :: GQLType a => f a -> FieldName -> SchemaT c (Directives CONST)+deriveFieldDirectives proxy name = do+  dirs <- deriveDirectiveUsages $ getDirHM name $ fieldDirectives $ directives proxy+  getDir (unpackName name) (getDirectives proxy) <:> dirs++deriveEnumDirectives :: GQLType a => f a -> TypeName -> SchemaT c (Directives CONST)+deriveEnumDirectives proxy name = do+  dirs <- deriveDirectiveUsages $ getDirHM name $ enumValueDirectives $ directives proxy+  getDir (unpackName name) (getDirectives proxy) <:> dirs

@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}  module Data.Morpheus.Server.Deriving.Schema.Enum   ( buildEnumTypeContent,@@ -7,9 +8,9 @@   ) where +import Data.Morpheus.Server.Deriving.Schema.Directive (deriveEnumDirectives) import Data.Morpheus.Server.Deriving.Schema.Internal   ( lookupDescription,-    lookupDirectives,   ) import Data.Morpheus.Server.Deriving.Utils.Kinded   ( KindedType (..),@@ -36,16 +37,18 @@   )  buildEnumTypeContent :: GQLType a => KindedType kind a -> [TypeName] -> SchemaT c (TypeContent TRUE kind CONST)-buildEnumTypeContent p@InputType enumCons = pure $ DataEnum $ map (mkEnumValue p) enumCons-buildEnumTypeContent p@OutputType enumCons = pure $ DataEnum $ map (mkEnumValue p) enumCons+buildEnumTypeContent p@InputType enumCons = DataEnum <$> traverse (mkEnumValue p) enumCons+buildEnumTypeContent p@OutputType enumCons = DataEnum <$> traverse (mkEnumValue p) enumCons -mkEnumValue :: GQLType a => f a -> TypeName -> DataEnumValue CONST-mkEnumValue proxy enumName =-  DataEnumValue-    { enumName,-      enumDescription = lookupDescription proxy (unpackName enumName),-      enumDirectives = lookupDirectives proxy (unpackName enumName)-    }+mkEnumValue :: GQLType a => f a -> TypeName -> SchemaT c (DataEnumValue CONST)+mkEnumValue proxy enumName = do+  enumDirectives <- deriveEnumDirectives proxy enumName+  pure+    DataEnumValue+      { enumName,+        enumDescription = lookupDescription proxy (unpackName enumName),+        ..+      }  defineEnumUnit :: SchemaT cat () defineEnumUnit =

@@ -23,42 +23,33 @@     TyContentM,     TyContent,     fromSchema,-    updateByContent,     lookupDescription,-    lookupDirectives,     lookupFieldContent,   ) where  -- MORPHEUS+ import qualified Data.Map as M-import Data.Morpheus.App.Internal.Resolving-  ( Result (..),+import Data.Morpheus.Internal.Ext+  ( GQLResult,+    Result (Failure, Success, errors),   )-import Data.Morpheus.Internal.Ext (GQLResult)-import Data.Morpheus.Internal.Utils (empty) import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CategoryValue (..),-    KindedType (..),+  ( KindedType (..),   ) import Data.Morpheus.Server.Types.GQLType   ( GQLType (..),-    TypeData (..),-    __typeData,   ) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,-    updateSchema,   ) import Data.Morpheus.Types.Internal.AST   ( CONST,     Description,-    Directives,     FieldContent (..),     Schema (..),     TRUE,-    TypeContent (..),-    TypeDefinition (..),     VALID,   ) import Language.Haskell.TH (Exp, Q)@@ -67,9 +58,6 @@ lookupDescription :: GQLType a => f a -> Text -> Maybe Description lookupDescription proxy name = name `M.lookup` getDescriptions proxy -lookupDirectives :: GQLType a => f a -> Text -> Directives CONST-lookupDirectives proxy name = fromMaybe empty $ name `M.lookup` getDirectives proxy- lookupFieldContent ::   GQLType a =>   KindedType kind a ->@@ -85,23 +73,3 @@ type TyContentM kind = SchemaT kind (TyContent kind)  type TyContent kind = Maybe (FieldContent TRUE kind CONST)--updateByContent ::-  (GQLType a, CategoryValue kind) =>-  (f kind a -> SchemaT c (TypeContent TRUE kind CONST)) ->-  f kind a ->-  SchemaT c ()-updateByContent f proxy =-  updateSchema-    (gqlFingerprint $ __typeData proxy)-    deriveD-    proxy-  where-    deriveD =-      fmap-        ( TypeDefinition-            (description proxy)-            (gqlTypeName (__typeData proxy))-            empty-        )-        . f

@@ -19,10 +19,10 @@   ( empty,     singleton,   )+import Data.Morpheus.Server.Deriving.Schema.Directive (deriveFieldDirectives) import Data.Morpheus.Server.Deriving.Schema.Enum (defineEnumUnit) import Data.Morpheus.Server.Deriving.Schema.Internal   ( lookupDescription,-    lookupDirectives,     lookupFieldContent,   ) import Data.Morpheus.Server.Deriving.Utils@@ -35,10 +35,12 @@     outputType,   ) import Data.Morpheus.Server.Types.GQLType-  ( GQLType (..),-    TypeData (..),+  ( GQLType,     __typeData,   )+import Data.Morpheus.Server.Types.Internal+  ( TypeData (..),+  ) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,     insertType,@@ -79,15 +81,13 @@ mkFieldUnit = mkField Nothing unitFieldName (mkTypeRef unitTypeName)  buildObjectTypeContent ::-  (Applicative f, GQLType a) =>+  GQLType a =>   KindedType cat a ->   [FieldRep (Maybe (FieldContent TRUE cat CONST))] ->-  f (TypeContent TRUE cat CONST)-buildObjectTypeContent scope consFields =-  pure-    $ mkObjectTypeContent scope-    $ unsafeFromFields-    $ map (setGQLTypeProps scope . repToFieldDefinition) consFields+  SchemaT c (TypeContent TRUE cat CONST)+buildObjectTypeContent scope consFields = do+  xs <- traverse (setGQLTypeProps scope . repToFieldDefinition) consFields+  pure $ mkObjectTypeContent scope $ unsafeFromFields xs  repToFieldDefinition ::   FieldRep (Maybe (FieldContent TRUE kind CONST)) ->@@ -130,14 +130,16 @@ mkObjectTypeContent InputType = DataInputObject mkObjectTypeContent OutputType = DataObject [] -setGQLTypeProps :: GQLType a => KindedType kind a -> FieldDefinition kind CONST -> FieldDefinition kind CONST-setGQLTypeProps proxy FieldDefinition {..} =-  FieldDefinition-    { fieldName,-      fieldDescription = lookupDescription proxy key,-      fieldDirectives = lookupDirectives proxy key,-      fieldContent = lookupFieldContent proxy key <|> fieldContent,-      ..-    }+setGQLTypeProps :: GQLType a => KindedType kind a -> FieldDefinition kind CONST -> SchemaT c (FieldDefinition kind CONST)+setGQLTypeProps proxy FieldDefinition {..} = do+  dirs <- deriveFieldDirectives proxy fieldName+  pure+    FieldDefinition+      { fieldName,+        fieldDescription = lookupDescription proxy key,+        fieldContent = lookupFieldContent proxy key <|> fieldContent,+        fieldDirectives = dirs,+        ..+      }   where     key = unpackName fieldName

@@ -4,9 +4,12 @@  module Data.Morpheus.Server.Deriving.Schema.TypeContent   ( buildTypeContent,+    insertTypeContent,+    deriveTypeContentWith,   ) where +import Data.Morpheus.Server.Deriving.Schema.Directive (deriveTypeDirectives) import Data.Morpheus.Server.Deriving.Schema.Enum   ( buildEnumTypeContent,   )@@ -20,14 +23,26 @@ import Data.Morpheus.Server.Deriving.Schema.Union (buildUnionTypeContent) import Data.Morpheus.Server.Deriving.Utils   ( ConsRep (..),+    DeriveTypeOptions,+    DeriveWith,+    deriveTypeWith,     isEmptyConstraint,+    unpackMonad,   ) import Data.Morpheus.Server.Deriving.Utils.Kinded   ( CategoryValue (..),   )-import Data.Morpheus.Server.Types.GQLType (GQLType)-import Data.Morpheus.Server.Types.SchemaT (SchemaT)+import Data.Morpheus.Server.Types.GQLType+  ( GQLType (..),+    deriveFingerprint,+    deriveTypename,+  )+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+    updateSchema,+  ) import Data.Morpheus.Types.Internal.AST+import GHC.Generics (Rep)  buildTypeContent ::   (GQLType a, CategoryValue kind) =>@@ -37,3 +52,38 @@ buildTypeContent scope cons | all isEmptyConstraint cons = buildEnumTypeContent scope (consName <$> cons) buildTypeContent scope [ConsRep {consFields}] = buildObjectTypeContent scope consFields buildTypeContent scope cons = buildUnionTypeContent scope cons++insertTypeContent ::+  (GQLType a, CategoryValue kind) =>+  (f kind a -> SchemaT c (TypeContent TRUE kind CONST)) ->+  f kind a ->+  SchemaT c ()+insertTypeContent f proxy =+  updateSchema+    (deriveFingerprint proxy)+    deriveD+    proxy+  where+    deriveD x = do+      content <- f x+      dirs <- deriveTypeDirectives proxy+      pure $+        TypeDefinition+          (description proxy)+          (deriveTypename proxy)+          dirs+          content++deriveTypeContentWith ::+  ( CategoryValue kind,+    DeriveWith c (SchemaT kind (TyContent kind)) (Rep a),+    GQLType a+  ) =>+  DeriveTypeOptions kind c (SchemaT kind (TyContent kind)) ->+  KindedType kind a ->+  SchemaT kind (TypeContent TRUE kind CONST)+deriveTypeContentWith x kindedProxy =+  unpackMonad+    ( deriveTypeWith x kindedProxy+    )+    >>= buildTypeContent kindedProxy

@@ -23,11 +23,7 @@   ( CategoryValue,     KindedType (..),   )-import Data.Morpheus.Server.Types.GQLType-  ( GQLType,-    TypeData (gqlTypeName),-    __typeData,-  )+import Data.Morpheus.Server.Types.GQLType (GQLType, deriveTypename) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,   )@@ -54,7 +50,7 @@ buildUnionTypeContent scope cons = mkUnionType scope unionRef unionCons   where     unionRef = fieldTypeName <$> concatMap consFields unionRefRep-    (unionRefRep, unionCons) = partition (isUnionRef (gqlTypeName (__typeData scope))) cons+    (unionRefRep, unionCons) = partition (isUnionRef (deriveTypename scope)) cons  mkUnionType ::   GQLType a =>

@@ -1,275 +1,24 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Deriving.Utils   ( conNameProxy,     isRecordProxy,     selNameProxy,-    TypeRep (..),     ConsRep (..),-    TypeConstraint (..),     FieldRep (..),     isEmptyConstraint,-    DataType (..),-    ConRep (..),-    toRep,-    toValue,     isUnionRef,     fieldTypeName,     unpackMonad,-    deriveTypeRef,     symbolName,-    withKind,     toFieldRes,+    DataType (..),+    DeriveWith (..),+    DeriveTypeOptions (..),+    deriveTypeWith,   ) where -import Data.Morpheus.Server.Deriving.Utils.Kinded-  ( CategoryValue (..),-    KindedProxy (KindedProxy),-    kinded,-  )-import Data.Morpheus.Server.Types.GQLType-  ( GQLType (..),-    GQLTypeOptions (..),-    TypeData (..),-    defaultTypeOptions,-    __typeData,-  )-import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    TypeCategory,-    TypeName,-    TypeRef (..),-    packName,-  )-import Data.Text-  ( pack,-  )-import qualified Data.Text as T-import GHC.Generics-  ( C,-    Constructor,-    D,-    Datatype,-    Generic (..),-    K1 (..),-    M1 (..),-    Meta,-    Rec0,-    S,-    Selector,-    U1 (..),-    conIsRecord,-    conName,-    selName,-    (:*:) (..),-    (:+:) (..),-  )-import GHC.TypeLits-import Relude hiding (undefined)-import Prelude (undefined)--conNameProxy :: forall f (c :: Meta). Constructor c => GQLTypeOptions -> f c -> TypeName-conNameProxy options _ =-  packName $ pack $ constructorTagModifier options $ conName (undefined :: M1 C c U1 a)--selNameProxy :: forall f (s :: Meta). Selector s => GQLTypeOptions -> f s -> FieldName-selNameProxy options _ =-  fromHaskellName $-    fieldLabelModifier options $-      selName (undefined :: M1 S s f a)--fromHaskellName :: String -> FieldName-fromHaskellName hsName-  | not (null hsName) && (T.last name == '\'') = packName (T.init name)-  | otherwise = packName name-  where-    name = T.pack hsName-{-# INLINE fromHaskellName #-}--isRecordProxy :: forall f (c :: Meta). Constructor c => f c -> Bool-isRecordProxy _ = conIsRecord (undefined :: (M1 C c f a))--newtype TypeConstraint (c :: Type -> Constraint) (v :: Type) (f :: Type -> Type) = TypeConstraint-  { typeConstraint :: forall a. c a => f a -> v-  }--toRep ::-  forall kinded constraint value (a :: Type) (kind :: TypeCategory).-  (GQLType a, CategoryValue kind, TypeRep constraint value (Rep a)) =>-  TypeConstraint constraint value Proxy ->-  kinded kind a ->-  [ConsRep value]-toRep f proxy = typeRep (typeOptions proxy defaultTypeOptions, Proxy @kind, f) (Proxy @(Rep a))--toValue ::-  forall proxy (kind :: TypeCategory) constraint value (a :: Type).-  (GQLType a, CategoryValue kind, Generic a, TypeRep constraint value (Rep a)) =>-  TypeConstraint constraint value Identity ->-  proxy kind ->-  a ->-  DataType value-toValue f proxy = toTypeRep (typeName, options, proxy, f) . from-  where-    typeName = gqlTypeName $ __typeData (KindedProxy :: KindedProxy kind a)-    options = typeOptions (Proxy @a) defaultTypeOptions----  GENERIC UNION-class TypeRep (c :: Type -> Constraint) (v :: Type) f where-  typeRep :: CategoryValue kind => (GQLTypeOptions, kinProxy (kind :: TypeCategory), TypeConstraint c v Proxy) -> proxy f -> [ConsRep v]-  toTypeRep :: CategoryValue kind => (TypeName, GQLTypeOptions, kinProxy (kind :: TypeCategory), TypeConstraint c v Identity) -> f a -> DataType v--instance (Datatype d, TypeRep c v f) => TypeRep c v (M1 D d f) where-  typeRep fun _ = typeRep fun (Proxy @f)-  toTypeRep fun@(dataTypeName, _, _, _) (M1 src) = (toTypeRep fun src) {dataTypeName}---- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'-instance (TypeRep c v a, TypeRep c v b) => TypeRep c v (a :+: b) where-  typeRep fun _ = typeRep fun (Proxy @a) <> typeRep fun (Proxy @b)-  toTypeRep f (L1 x) = (toTypeRep f x) {tyIsUnion = True}-  toTypeRep f (R1 x) = (toTypeRep f x) {tyIsUnion = True}--instance (ConRep con v f, Constructor c) => TypeRep con v (M1 C c f) where-  typeRep f@(opt, _, _) _ = [deriveConsRep opt (Proxy @c) (conRep f (Proxy @f))]-  toTypeRep (_, opt, x, y) (M1 src) =-    DataType-      { dataTypeName = "",-        tyIsUnion = False,-        tyCons = deriveConsRep opt (Proxy @c) (toFieldRep (opt, x, y) src)-      }--deriveConsRep ::-  Constructor (c :: Meta) =>-  GQLTypeOptions ->-  f c ->-  [FieldRep v] ->-  ConsRep v-deriveConsRep opt proxy fields =-  ConsRep-    { consName = conNameProxy opt proxy,-      consFields-    }-  where-    consFields-      | isRecordProxy proxy = fields-      | otherwise = enumerate fields--class ConRep (c :: Type -> Constraint) (v :: Type) f where-  conRep :: CategoryValue kind => (GQLTypeOptions, kinProxy (kind :: TypeCategory), TypeConstraint c v Proxy) -> proxy f -> [FieldRep v]-  toFieldRep :: CategoryValue kind => (GQLTypeOptions, kinProxy (kind :: TypeCategory), TypeConstraint c v Identity) -> f a -> [FieldRep v]---- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION'-instance (ConRep c v a, ConRep c v b) => ConRep c v (a :*: b) where-  conRep fun _ = conRep fun (Proxy @a) <> conRep fun (Proxy @b)-  toFieldRep fun (a :*: b) = toFieldRep fun a <> toFieldRep fun b--instance (Selector s, GQLType a, c a) => ConRep c v (M1 S s (Rec0 a)) where-  conRep (opt, kind, TypeConstraint f) _ = [deriveFieldRep opt (Proxy @s) (kinded kind (Proxy @a)) (f $ Proxy @a)]-  toFieldRep (opt, kind, TypeConstraint f) (M1 (K1 src)) = [deriveFieldRep opt (Proxy @s) (kinded kind (Proxy @a)) (f (Identity src))]--deriveFieldRep ::-  forall-    proxy-    (selector :: Meta)-    (kindedProxy :: TypeCategory -> Type -> Type)-    a-    v-    (kind :: TypeCategory).-  ( Selector selector,-    GQLType a,-    CategoryValue kind-  ) =>-  GQLTypeOptions ->-  proxy selector ->-  kindedProxy kind a ->-  v ->-  FieldRep v-deriveFieldRep opt pSel kindedProxy v =-  FieldRep-    { fieldSelector = selNameProxy opt pSel,-      fieldTypeRef = deriveTypeRef kindedProxy,-      fieldValue = v-    }--deriveTypeRef :: (GQLType a, CategoryValue kind) => kinded kind a -> TypeRef-deriveTypeRef kindedProxy =-  TypeRef-    { typeConName = gqlTypeName,-      typeWrappers = gqlWrappers-    }-  where-    TypeData {gqlTypeName, gqlWrappers} = __typeData kindedProxy--instance ConRep c v U1 where-  conRep _ _ = []-  toFieldRep _ _ = []--data DataType (v :: Type) = DataType-  { dataTypeName :: TypeName,-    tyIsUnion :: Bool,-    tyCons :: ConsRep v-  }--data ConsRep (v :: Type) = ConsRep-  { consName :: TypeName,-    consFields :: [FieldRep v]-  }--data FieldRep (a :: Type) = FieldRep-  { fieldSelector :: FieldName,-    fieldTypeRef :: TypeRef,-    fieldValue :: a-  }-  deriving (Functor)--toFieldRes :: FieldRep (m a) -> (FieldName, m a)-toFieldRes FieldRep {fieldSelector, fieldValue} = (fieldSelector, fieldValue)--unpackMonadFromField :: Monad m => FieldRep (m a) -> m (FieldRep a)-unpackMonadFromField FieldRep {..} = do-  cont <- fieldValue-  pure (FieldRep {fieldValue = cont, ..})--unpackMonadFromCons :: Monad m => ConsRep (m a) -> m (ConsRep a)-unpackMonadFromCons ConsRep {..} = ConsRep consName <$> traverse unpackMonadFromField consFields--unpackMonad :: Monad m => [ConsRep (m a)] -> m [ConsRep a]-unpackMonad = traverse unpackMonadFromCons--isEmptyConstraint :: ConsRep a -> Bool-isEmptyConstraint ConsRep {consFields = []} = True-isEmptyConstraint _ = False---- setFieldNames ::  Power Int Text -> Power { _1 :: Int, _2 :: Text }-enumerate :: [FieldRep a] -> [FieldRep a]-enumerate = zipWith setFieldName ([0 ..] :: [Int])-  where-    setFieldName i field = field {fieldSelector = packName $ "_" <> pack (show i)}--fieldTypeName :: FieldRep k -> TypeName-fieldTypeName = typeConName . fieldTypeRef--isUnionRef :: TypeName -> ConsRep k -> Bool-isUnionRef baseName ConsRep {consName, consFields = [fieldRep]} =-  consName == baseName <> fieldTypeName fieldRep-isUnionRef _ _ = False--symbolName :: KnownSymbol a => f a -> FieldName-symbolName = fromString . symbolVal--withKind :: Proxy a -> KindedProxy (KIND a) a-withKind _ = KindedProxy+import Data.Morpheus.Server.Deriving.Utils.DeriveGType+import Data.Morpheus.Server.Deriving.Utils.Proxy+import Data.Morpheus.Server.Deriving.Utils.Types

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -11,13 +12,21 @@     decodeFieldWith,     withScalar,     handleEither,+    getFieldName,+    DecoderT,+    withKind,+    Info (..),+    Context (..),+    Tag (..),   ) where  import Control.Monad.Except (MonadError (throwError))+import Data.Morpheus.App.Internal.Resolving (ResolverState) import Data.Morpheus.Internal.Utils   ( selectOr,   )+import Data.Morpheus.Server.Types.Internal import Data.Morpheus.Types.GQLScalar   ( toScalar,   )@@ -87,5 +96,34 @@ typeMismatch :: GQLError -> Value s -> GQLError typeMismatch text jsType =   internal $-    "Type mismatch! expected:" <> text <> ", got: "+    "Type mismatch! expected:"+      <> text+      <> ", got: "       <> msg jsType++getFieldName :: FieldName -> Int -> FieldName+getFieldName "" index = "_" <> show index+getFieldName label _ = label++data Tag = D_CONS | D_UNION deriving (Eq, Ord)++data Info = Info+  { kind :: Tag,+    tagName :: [TypeName]+  }++instance Semigroup Info where+  Info D_UNION t1 <> Info _ t2 = Info D_UNION (t1 <> t2)+  Info _ t1 <> Info D_UNION t2 = Info D_UNION (t1 <> t2)+  Info D_CONS t1 <> Info D_CONS t2 = Info D_CONS (t1 <> t2)++data Context = Context+  { contKind :: Tag,+    typeName :: TypeName,+    options :: GQLTypeOptions+  }++type DecoderT = ReaderT Context ResolverState++withKind :: Tag -> DecoderT a -> DecoderT a+withKind contKind = local (\ctx -> ctx {contKind})

@@ -0,0 +1,158 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Utils.DeriveGType+  ( DeriveWith (..),+    DeriveValueOptions (..),+    DeriveTypeOptions (..),+    deriveValue,+    deriveTypeWith,+  )+where++import Data.Morpheus.Server.Deriving.Utils.Kinded+  ( CategoryValue (..),+  )+import Data.Morpheus.Server.Deriving.Utils.Proxy+  ( conNameProxy,+    isRecordProxy,+    selNameProxy,+  )+import Data.Morpheus.Server.Deriving.Utils.Types+import Data.Morpheus.Server.Types.Internal+  ( GQLTypeOptions (..),+    TypeData (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( TypeName,+    TypeRef (..),+  )+import GHC.Generics+  ( C,+    Constructor,+    D,+    Datatype,+    Generic (..),+    K1 (..),+    M1 (..),+    Meta,+    Rec0,+    S,+    Selector,+    U1 (..),+    (:*:) (..),+    (:+:) (..),+  )+import Relude hiding (undefined)++data DeriveValueOptions kind c v = DeriveValueOptions+  { __valueTypeName :: TypeName,+    __valueGQLOptions :: GQLTypeOptions,+    __valueApply :: forall a. c a => a -> v,+    __valueGetType :: forall f a. c a => f a -> TypeData+  }++data DeriveTypeOptions kind c v = DeriveTypeDefinitionOptions+  { __typeGQLOptions :: GQLTypeOptions,+    __typeApply :: forall f a. c a => f a -> v,+    __typeGetType :: forall f a. c a => f a -> TypeData+  }++deriveValue ::+  (CategoryValue kind, Generic a, DeriveWith constraint value (Rep a)) =>+  DeriveValueOptions kind 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 ->+  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]++instance (Datatype d, DeriveWith c v f) => DeriveWith 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+  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+  deriveTypeValue options (M1 src) =+    DataType+      { dataTypeName = "",+        tyIsUnion = False,+        tyCons = deriveConsRep (__valueGQLOptions options) (Proxy @c) (toFieldRep options src)+      }+  deriveTypeDefinition options _ = [deriveConsRep (__typeGQLOptions options) (Proxy @c) (conRep options (Proxy @f))]++deriveConsRep ::+  Constructor (c :: Meta) =>+  GQLTypeOptions ->+  f c ->+  [FieldRep v] ->+  ConsRep v+deriveConsRep opt proxy fields =+  ConsRep+    { consName = conNameProxy opt proxy,+      consFields+    }+  where+    consFields+      | 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]++instance (DeriveFieldRep c v a, DeriveFieldRep c v b) => DeriveFieldRep 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+  toFieldRep DeriveValueOptions {..} (M1 (K1 src)) =+    [ FieldRep+        { fieldSelector = selNameProxy __valueGQLOptions (Proxy @s),+          fieldTypeRef = TypeRef gqlTypeName gqlWrappers,+          fieldValue = __valueApply src+        }+    ]+    where+      TypeData {gqlTypeName, gqlWrappers} = __valueGetType (Proxy @a)+  conRep DeriveTypeDefinitionOptions {..} _ =+    [ FieldRep+        { fieldSelector = selNameProxy __typeGQLOptions (Proxy @s),+          fieldTypeRef = TypeRef gqlTypeName gqlWrappers,+          fieldValue = __typeApply (Proxy @a)+        }+    ]+    where+      TypeData {gqlTypeName, gqlWrappers} = __typeGetType (Proxy @a)++instance DeriveFieldRep c v U1 where+  toFieldRep _ _ = []+  conRep _ _ = []

@@ -21,7 +21,10 @@ import Data.Morpheus.Kind import Data.Morpheus.NamedResolvers (NamedResolverT) import Data.Morpheus.Server.Deriving.Utils.Kinded-import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __type), TypeData (gqlFingerprint))+import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __type))+import Data.Morpheus.Server.Types.Internal+  ( TypeData (gqlFingerprint),+  ) import Data.Morpheus.Server.Types.SchemaT (TypeFingerprint) import Data.Morpheus.Types.Internal.AST import GHC.Generics

@@ -0,0 +1,75 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Utils.Proxy+  ( conNameProxy,+    isRecordProxy,+    selNameProxy,+    symbolName,+    ContextValue (..),+  )+where++import Data.Morpheus.Kind (DerivingKind)+import Data.Morpheus.Server.Types.Internal+  ( GQLTypeOptions (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    TypeName,+    packName,+  )+import Data.Text+  ( pack,+  )+import qualified Data.Text as T+import GHC.Generics+  ( C,+    Constructor,+    M1 (..),+    Meta,+    S,+    Selector,+    U1 (..),+    conIsRecord,+    conName,+    selName,+  )+import GHC.TypeLits+import Relude hiding (undefined)+import Prelude (undefined)++conNameProxy :: forall f (c :: Meta). Constructor c => GQLTypeOptions -> f c -> TypeName+conNameProxy options _ =+  packName $ pack $ constructorTagModifier options $ conName (undefined :: M1 C c U1 a)++selNameProxy :: forall f (s :: Meta). Selector s => GQLTypeOptions -> f s -> FieldName+selNameProxy options _ =+  fromHaskellName $+    fieldLabelModifier options $+      selName (undefined :: M1 S s f a)++fromHaskellName :: String -> FieldName+fromHaskellName hsName+  | not (null hsName) && (T.last name == '\'') = packName (T.init name)+  | otherwise = packName name+  where+    name = T.pack hsName+{-# INLINE fromHaskellName #-}++isRecordProxy :: forall f (c :: Meta). Constructor c => f c -> Bool+isRecordProxy _ = conIsRecord (undefined :: (M1 C c f a))++symbolName :: KnownSymbol a => f a -> FieldName+symbolName = fromString . symbolVal++newtype ContextValue (kind :: DerivingKind) a = ContextValue+  { unContextValue :: a+  }

@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Deriving.Utils.Types+  ( ConsRep (..),+    FieldRep (..),+    DataType (..),+    enumerate,+    isEmptyConstraint,+    fieldTypeName,+    isUnionRef,+    toFieldRes,+    unpackMonad,+  )+where++import Data.Morpheus.Types.Internal.AST+import qualified Data.Text as T+import Relude++data DataType (v :: Type) = DataType+  { dataTypeName :: TypeName,+    tyIsUnion :: Bool,+    tyCons :: ConsRep v+  }+  deriving (Functor)++data ConsRep (v :: Type) = ConsRep+  { consName :: TypeName,+    consFields :: [FieldRep v]+  }+  deriving (Functor)++data FieldRep (a :: Type) = FieldRep+  { fieldSelector :: FieldName,+    fieldTypeRef :: TypeRef,+    fieldValue :: a+  }+  deriving (Functor)++-- setFieldNames ::  Power Int Text -> Power { _1 :: Int, _2 :: Text }+enumerate :: [FieldRep a] -> [FieldRep a]+enumerate = zipWith setFieldName ([0 ..] :: [Int])+  where+    setFieldName i field = field {fieldSelector = packName $ "_" <> T.pack (show i)}++isEmptyConstraint :: ConsRep a -> Bool+isEmptyConstraint ConsRep {consFields = []} = True+isEmptyConstraint _ = False++fieldTypeName :: FieldRep k -> TypeName+fieldTypeName = typeConName . fieldTypeRef++isUnionRef :: TypeName -> ConsRep k -> Bool+isUnionRef baseName ConsRep {consName, consFields = [fieldRep]} =+  consName == baseName <> fieldTypeName fieldRep+isUnionRef _ _ = False++toFieldRes :: FieldRep (m a) -> (FieldName, m a)+toFieldRes FieldRep {fieldSelector, fieldValue} = (fieldSelector, fieldValue)++unpackMonad :: Monad m => [ConsRep (m a)] -> m [ConsRep a]+unpackMonad = traverse unpackMonadFromCons++unpackMonadFromField :: Monad m => FieldRep (m a) -> m (FieldRep a)+unpackMonadFromField FieldRep {..} = do+  cont <- fieldValue+  pure (FieldRep {fieldValue = cont, ..})++unpackMonadFromCons :: Monad m => ConsRep (m a) -> m (ConsRep a)+unpackMonadFromCons ConsRep {..} = ConsRep consName <$> traverse unpackMonadFromField consFields

@@ -14,8 +14,8 @@ import Data.Functor (fmap) import Data.Semigroup ((<>)) import Prelude-  ( (.),-    mconcat,+  ( mconcat,+    (.),   )  link :: ByteString -> ByteString -> ByteString

@@ -10,8 +10,8 @@ -- --  Morpheus -import qualified Data.ByteString.Lazy.Char8 as LB import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as LB import Data.Morpheus.CodeGen   ( parseServerTypeDefinitions,   )

@@ -12,6 +12,9 @@   ( CodeGenConfig (..),     ServerTypeDefinition,   )+import Data.Morpheus.Server.TH.Declare.GQLDirective+  ( deriveGQLDirective,+  ) import Data.Morpheus.Server.TH.Declare.GQLType   ( deriveGQLType,   )@@ -32,4 +35,8 @@   declare = fmap concat . traverse declare  instance Declare ServerTypeDefinition where-  declare typeDef = (declareType typeDef <>) <$> deriveGQLType typeDef+  declare typeDef = do+    let typeDecs = declareType typeDef+    gqlDirDecs <- deriveGQLDirective typeDef+    gqlTypeDecs <- deriveGQLType typeDef+    pure (typeDecs <> gqlDirDecs <> gqlTypeDecs)

@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.TH.Declare.GQLDirective+  ( deriveGQLDirective,+  )+where++import Data.Morpheus.CodeGen.Internal.AST+  ( ServerConstructorDefinition (..),+    ServerTypeDefinition (..),+    TypeName,+  )+import Data.Morpheus.CodeGen.Internal.TH+  ( apply,+    applyVars,+    typeInstanceDec,+  )+import Data.Morpheus.Server.TH.Utils+  ( ServerDec,+    mkTypeableConstraints,+  )+import Data.Morpheus.Server.Types.Directives+  ( GQLDirective (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( DirectiveLocation (..),+  )+import Language.Haskell.TH+  ( Dec,+    Name,+    Q,+    Type (..),+    instanceD,+  )+import Relude hiding (Type, toString)++noVars :: [Name]+noVars = []++deriveGQLDirective :: ServerTypeDefinition -> ServerDec [Dec]+deriveGQLDirective DirectiveTypeDefinition {..} = do+  let constrains = mkTypeableConstraints noVars+  let tName = constructorName directiveConstructor+  let typeSignature = apply ''GQLDirective [applyVars tName noVars]+  methods <- defineMethods (constructorName directiveConstructor) directiveLocations+  gqlTypeDeclaration <- lift (instanceD constrains typeSignature methods)+  pure [gqlTypeDeclaration]+deriveGQLDirective _ = pure []++defineMethods :: TypeName -> [DirectiveLocation] -> ServerDec [Q Dec]+defineMethods tName locations = do+  let currentType = applyVars tName noVars+  let inst = typeInstanceDec ''DIRECTIVE_LOCATIONS currentType (promotedList locations)+  pure [pure inst]++locationName :: DirectiveLocation -> Name+locationName QUERY = 'QUERY+locationName MUTATION = 'MUTATION+locationName SUBSCRIPTION = 'SUBSCRIPTION+locationName FIELD = 'FIELD+locationName FRAGMENT_DEFINITION = 'FRAGMENT_DEFINITION+locationName FRAGMENT_SPREAD = 'FRAGMENT_SPREAD+locationName INLINE_FRAGMENT = 'INLINE_FRAGMENT+locationName SCHEMA = 'SCHEMA+locationName SCALAR = 'SCALAR+locationName OBJECT = 'OBJECT+locationName FIELD_DEFINITION = 'FIELD_DEFINITION+locationName ARGUMENT_DEFINITION = 'ARGUMENT_DEFINITION+locationName INTERFACE = 'INTERFACE+locationName UNION = 'UNION+locationName ENUM = 'ENUM+locationName ENUM_VALUE = 'ENUM_VALUE+locationName INPUT_OBJECT = 'INPUT_OBJECT+locationName INPUT_FIELD_DEFINITION = 'INPUT_FIELD_DEFINITION++promotedList :: [DirectiveLocation] -> Type+promotedList =+  foldr+    (AppT . AppT PromotedConsT . PromotedT . locationName)+    PromotedNilT

@@ -6,7 +6,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -15,15 +16,19 @@   ) where -import Data.Char (toLower) import Data.Morpheus.CodeGen.Internal.AST   ( CodeGenConfig (..),     GQLTypeDefinition (..),     Kind (..),+    ServerConstructorDefinition (constructorName),+    ServerDirectiveUsage (..),     ServerTypeDefinition (..),+    TypeValue (..),+    unpackName,   ) import Data.Morpheus.CodeGen.Internal.TH-  ( apply,+  ( ToName (..),+    apply,     applyVars,     typeInstanceDec,   )@@ -37,60 +42,63 @@     mkTypeableConstraints,     renderTypeVars,   )+import Data.Morpheus.Server.Types.GQLType+  ( enumDirective,+    fieldDirective,+    typeDirective,+  )+import Data.Morpheus.Server.Types.Internal+  ( dropNamespaceOptions,+  ) import Data.Morpheus.Types   ( GQLType (..),-    GQLTypeOptions (..),   ) import Data.Morpheus.Types.Internal.AST-  ( TypeKind (..),+  ( FieldName,+    TypeKind (..),   ) import qualified Data.Text as T import Language.Haskell.TH   ( Dec,     DecQ,+    ExpQ,+    FieldExp,     Name,     Q,     Type (ConT),+    appE,+    conE,     instanceD,+    listE,+    litE,+    recConE,+    stringL,   )-import Relude--dropPrefix :: Text -> String -> String-dropPrefix name = drop (T.length name)--stripConstructorNamespace :: Text -> String -> String-stripConstructorNamespace = dropPrefix--stripFieldNamespace :: Text -> String -> String-stripFieldNamespace prefix = __uncapitalize . dropPrefix prefix-  where-    __uncapitalize [] = []-    __uncapitalize (x : xs) = toLower x : xs--dropNamespaceOptions :: TypeKind -> Text -> GQLTypeOptions -> GQLTypeOptions-dropNamespaceOptions KindInterface tName opt =-  opt-    { typeNameModifier = const (stripConstructorNamespace "Interface"),-      fieldLabelModifier = stripFieldNamespace tName-    }-dropNamespaceOptions KindEnum tName opt = opt {constructorTagModifier = stripConstructorNamespace tName}-dropNamespaceOptions _ tName opt = opt {fieldLabelModifier = stripFieldNamespace tName}+import Relude hiding (toString)  deriveGQLType :: ServerTypeDefinition -> ServerDec [Dec]-deriveGQLType ServerInterfaceDefinition {} = pure [] deriveGQLType   ServerTypeDefinition     { tName,       tKind,       typeParameters,-      gql+      typeGQLType     } = do     let typeVars = renderTypeVars typeParameters     let constrains = mkTypeableConstraints typeVars     let typeSignature = apply ''GQLType [applyVars tName typeVars]-    methods <- defineMethods tName tKind typeVars gql+    methods <- defineMethods tName tKind typeVars typeGQLType     gqlTypeDeclaration <- lift (instanceD constrains typeSignature methods)     pure [gqlTypeDeclaration]+deriveGQLType DirectiveTypeDefinition {..} = do+  let typeVars = [] :: [Name]+  let tName = unpackName (constructorName directiveConstructor)+  let constrains = mkTypeableConstraints typeVars+  let typeSignature = apply ''GQLType [applyVars tName typeVars]+  methods <- defineMethods tName KindInputObject typeVars (Just directiveGQLType)+  gqlTypeDeclaration <- lift (instanceD constrains typeSignature methods)+  pure [gqlTypeDeclaration]+deriveGQLType _ = pure []  defineTypeOptions :: Text -> TypeKind -> ServerDec [DecQ] defineTypeOptions tName kind = do@@ -112,8 +120,8 @@       GQLTypeDefinition         { gqlTypeDescription,           gqlTypeDescriptions,-          gqlTypeDirectives,           gqlTypeDefaultValues,+          gqlTypeDirectiveUses,           gqlKind         }     ) = do@@ -124,9 +132,10 @@         funDProxy           [ ('description, [|gqlTypeDescription|]),             ('getDescriptions, [|gqlTypeDescriptions|]),-            ('getDirectives, [|gqlTypeDirectives|]),-            ('defaultValues, [|gqlTypeDefaultValues|])+            ('defaultValues, [|gqlTypeDefaultValues|]),+            ('directives, renderDirectiveUsages gqlTypeDirectiveUses)           ]+       typeFamilies = do         currentType <- applyVars tName typeParameters         pure $ typeInstanceDec ''KIND currentType (ConT (kindName gqlKind))@@ -134,3 +143,28 @@ kindName :: Kind -> Name kindName Scalar = ''SCALAR kindName Type = ''TYPE++renderDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ+renderDirectiveUsages =+  foldr+    (appE . appE [|(<>)|] . renderDirectiveUsage)+    [|mempty|]++renderDirectiveUsage :: ServerDirectiveUsage -> ExpQ+renderDirectiveUsage (TypeDirectiveUsage x) = [|typeDirective $(renderValue x)|]+renderDirectiveUsage (FieldDirectiveUsage field x) = [|fieldDirective field $(renderValue x)|]+renderDirectiveUsage (EnumDirectiveUsage enum x) = [|enumDirective enum $(renderValue x)|]++renderField :: (FieldName, TypeValue) -> Q FieldExp+renderField (fName, fValue) = do+  v <- renderValue fValue+  pure (toName fName, v)++renderValue :: TypeValue -> ExpQ+renderValue (TypeValueObject name xs) = recConE (toName name) (map renderField xs)+renderValue (TypeValueNumber x) = [|x|]+renderValue (TypeValueString x) = litE (stringL (T.unpack x))+renderValue (TypeValueBool _) = [|x|]+renderValue (TypedValueMaybe (Just x)) = appE (conE 'Just) (renderValue x)+renderValue (TypedValueMaybe Nothing) = conE 'Nothing+renderValue (TypeValueList xs) = listE $ map renderValue xs

@@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -10,14 +11,7 @@   ) where -import Data.Morpheus.CodeGen.Internal.AST-  ( DerivingClass (..),-    FIELD_TYPE_WRAPPER (..),-    ServerConstructorDefinition (..),-    ServerFieldDefinition (..),-    ServerTypeDefinition (..),-    unpackName,-  )+import Data.Morpheus.CodeGen.Internal.AST (DerivingClass (..), FIELD_TYPE_WRAPPER (..), ServerConstructorDefinition (..), ServerFieldDefinition (..), ServerTypeDefinition (..), unpackName) import Data.Morpheus.CodeGen.Internal.TH   ( apply,     declareTypeRef,@@ -42,6 +36,8 @@ import Language.Haskell.TH import Relude hiding (Type) +{- ORMOLU_DISABLE -}+ declareType :: ServerTypeDefinition -> [Dec] declareType (ServerInterfaceDefinition name interfaceName unionName) =   [ TySynD@@ -70,6 +66,13 @@ #else       vars = map PlainTV (renderTypeVars typeParameters) #endif+declareType+  DirectiveTypeDefinition {..} +    = [DataD [] name [] Nothing [declareCons directiveConstructor] [derivingClause]]+    where+      name = toName (constructorName directiveConstructor)+      derivingClause = DerivClause Nothing (map (ConT . genName) directiveDerives)+{- ORMOLU_ENABLE -}  genName :: DerivingClass -> Name genName GENERIC = ''Generic

@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Types.DirectiveDefinitions+  ( Prefixes (..),+    Deprecated (..),+  )+where++import Data.Morpheus.Server.Types.Directives (GQLDirective (..))+import Data.Morpheus.Server.Types.GQLType (GQLType (__type))+import Data.Morpheus.Server.Types.Internal+import Data.Morpheus.Server.Types.Visitors (VisitEnum, VisitField, VisitType (..))+import Data.Morpheus.Types.Internal.AST+  ( DirectiveLocation (..),+  )+import qualified Data.Text as T+import Relude++-- | a custom GraphQL directive for adding or removing+-- of prefixes+data Prefixes = Prefixes+  { addPrefix :: Text,+    removePrefix :: Text+  }+  deriving (Generic, GQLType)++instance GQLDirective Prefixes where+  type+    DIRECTIVE_LOCATIONS Prefixes =+      '[ 'OBJECT,+         'ENUM,+         'INPUT_OBJECT,+         'UNION,+         'SCALAR,+         'INTERFACE+       ]++instance VisitType Prefixes where+  visitTypeName Prefixes {addPrefix, removePrefix} name = addPrefix <> T.drop (T.length removePrefix) name+  visitTypeDescription _ = id++-- native GraphQL directive @deprecated+--+newtype Deprecated = Deprecated+  { reason :: Maybe Text+  }+  deriving+    ( Generic,+      VisitEnum,+      VisitField+    )++instance GQLType Deprecated where+  __type _ = mkTypeData "deprecated"++instance GQLDirective Deprecated where+  type+    DIRECTIVE_LOCATIONS Deprecated =+      '[ 'FIELD_DEFINITION,+         'ENUM_VALUE+       ]

@@ -0,0 +1,188 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Types.Directives+  ( GQLDirective (..),+    ToLocations (..),+    getLocations,+    -- visitors+    visitTypeName,+    visitTypeDescription,+    visitFieldName,+    visitFieldDescription,+    visitEnumName,+    visitEnumDescription,+  )+where++import Data.Morpheus.Server.Types.TypeName (getTypename)+import qualified Data.Morpheus.Server.Types.Visitors as Visitors+import Data.Morpheus.Types.Internal.AST+  ( Description,+    DirectiveLocation (..),+    FALSE,+    FieldName,+    TRUE,+    TypeName,+    packName,+    unpackName,+  )+import Relude++type family OR (a :: Bool) (b :: Bool) where+  OR FALSE FALSE = FALSE+  OR a b = TRUE++type family INCLUDES (x :: DirectiveLocation) (xs :: [DirectiveLocation]) :: Bool where+  INCLUDES x '[] = FALSE+  INCLUDES x (x ': xs) = TRUE+  INCLUDES x (a ': xs) = INCLUDES x xs++type family OVERLAPS (xs :: [DirectiveLocation]) (ys :: [DirectiveLocation]) :: Bool where+  OVERLAPS (x ': xs) ys = OR (INCLUDES x ys) (OVERLAPS xs ys)+  OVERLAPS '[] ys = FALSE++-- type VisitorOption (k :: DirectiveLocation) (a :: Type) = VisitorContext a (Allow k (ALLOWED_DIRECTIVE_LOCATIONS a))++class ToLocation (l :: DirectiveLocation) where+  toLocation :: f l -> DirectiveLocation++-- types+instance ToLocation 'OBJECT where+  toLocation = const OBJECT++instance ToLocation 'ENUM where+  toLocation = const ENUM++instance ToLocation 'INPUT_OBJECT where+  toLocation = const INPUT_OBJECT++instance ToLocation 'UNION where+  toLocation = const UNION++instance ToLocation 'SCALAR where+  toLocation = const SCALAR++instance ToLocation 'INTERFACE where+  toLocation = const INTERFACE++-- fields, values+instance ToLocation 'INPUT_FIELD_DEFINITION where+  toLocation = const INPUT_FIELD_DEFINITION++instance ToLocation 'ARGUMENT_DEFINITION where+  toLocation = const ARGUMENT_DEFINITION++instance ToLocation 'FIELD_DEFINITION where+  toLocation = const FIELD_DEFINITION++instance ToLocation 'ENUM_VALUE where+  toLocation = const ENUM_VALUE++class ToLocations (k :: [DirectiveLocation]) where+  toLocations :: f k -> [DirectiveLocation]++instance (ToLocation l, ToLocations ls) => ToLocations (l : ls) where+  toLocations _ = toLocation (Proxy @l) : toLocations (Proxy @ls)++instance ToLocations '[] where+  toLocations _ = []++getLocations :: forall f a. ToLocations (DIRECTIVE_LOCATIONS a) => f a -> [DirectiveLocation]+getLocations _ = toLocations (Proxy :: Proxy (DIRECTIVE_LOCATIONS a))++type ALLOWED (a :: Type) (l :: [DirectiveLocation]) = OVERLAPS l (DIRECTIVE_LOCATIONS a)++type WITH_VISITOR (a :: Type) (f :: Type -> Bool -> Constraint) (l :: [DirectiveLocation]) = f a (ALLOWED a l)++-- types++type TYPE_VISITOR_KIND = '[ 'OBJECT, 'ENUM, 'INPUT_OBJECT, 'UNION, 'SCALAR, 'INTERFACE]++type FIELD_VISITOR_KIND = '[ 'INPUT_FIELD_DEFINITION, 'FIELD_DEFINITION]++type ENUM_VISITOR_KIND = '[ 'ENUM_VALUE]++__directiveName :: GQLDirective a => f a -> FieldName+__directiveName = coerce . getTypename++class+  ( 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+  ) =>+  GQLDirective a+  where+  type DIRECTIVE_LOCATIONS a :: [DirectiveLocation]++-- TYPE VISITORS++visitTypeName :: forall a. GQLDirective a => a -> TypeName -> TypeName+visitTypeName = __visitTypeName (Proxy :: Proxy (ALLOWED a TYPE_VISITOR_KIND))++visitTypeDescription :: forall a. GQLDirective a => a -> Maybe Description -> Maybe Description+visitTypeDescription = __visitTypeDescription (Proxy :: Proxy (ALLOWED a TYPE_VISITOR_KIND))++class VISIT_TYPE a (t :: Bool) where+  __visitTypeName :: f t -> a -> TypeName -> TypeName+  __visitTypeDescription :: f t -> a -> Maybe Description -> Maybe Description++instance VISIT_TYPE a 'False where+  __visitTypeName _ _ = id+  __visitTypeDescription _ _ = id++instance Visitors.VisitType a => VISIT_TYPE a TRUE where+  __visitTypeName _ x name = packName $ Visitors.visitTypeName x (unpackName name)+  __visitTypeDescription _ = Visitors.visitTypeDescription++-- FIELD VISITORS++visitFieldName :: forall a. GQLDirective a => a -> FieldName -> FieldName+visitFieldName = __visitFieldName (Proxy :: Proxy (ALLOWED a FIELD_VISITOR_KIND))++visitFieldDescription :: forall a. GQLDirective a => a -> Maybe Description -> Maybe Description+visitFieldDescription = __visitFieldDescription (Proxy :: Proxy (ALLOWED a FIELD_VISITOR_KIND))++class VISIT_FIELD a (t :: Bool) where+  __visitFieldName :: f t -> a -> FieldName -> FieldName+  __visitFieldDescription :: f t -> a -> Maybe Description -> Maybe Description++instance VISIT_FIELD a FALSE where+  __visitFieldName _ _ = id+  __visitFieldDescription _ _ = id++instance Visitors.VisitField a => VISIT_FIELD a TRUE where+  __visitFieldName _ x name = packName $ Visitors.visitFieldName x (unpackName name)+  __visitFieldDescription _ = Visitors.visitFieldDescription++-- VISIT_ENUM++visitEnumName :: forall a. GQLDirective a => a -> FieldName -> FieldName+visitEnumName = __visitEnumName (Proxy :: Proxy (ALLOWED a ENUM_VISITOR_KIND))++visitEnumDescription :: forall a. GQLDirective a => a -> Maybe Description -> Maybe Description+visitEnumDescription = __visitEnumDescription (Proxy :: Proxy (ALLOWED a ENUM_VISITOR_KIND))++class VISIT_ENUM a (t :: Bool) where+  __visitEnumName :: f t -> a -> FieldName -> FieldName+  __visitEnumDescription :: f t -> a -> Maybe Description -> Maybe Description++instance VISIT_ENUM a FALSE where+  __visitEnumName _ _ = id+  __visitEnumDescription _ _ = id++instance Visitors.VisitEnum a => VISIT_ENUM a TRUE where+  __visitEnumName _ x name = packName $ Visitors.visitEnumName x (unpackName name)+  __visitEnumDescription _ = Visitors.visitEnumDescription

@@ -1,7 +1,10 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-}@@ -9,6 +12,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Types.GQLType@@ -19,49 +23,90 @@         typeOptions,         getDirectives,         defaultValues,-        __type+        directives,+        __type,+        __isEmptyType       ),-    GQLTypeOptions (..),-    defaultTypeOptions,-    TypeData (..),-    __isEmptyType,     __typeData,+    deriveTypename,+    deriveFingerprint,+    encodeArguments,+    DirectiveUsage (..),+    DeriveArguments (..),+    applyOnTypeName,+    DirectiveUsages (..),+    typeDirective,+    fieldDirective,+    enumDirective,   ) 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.Kind   ( CUSTOM,-    DerivingKind,+    DerivingKind (..),     SCALAR,     TYPE,     WRAPPER,   ) import Data.Morpheus.NamedResolvers (NamedResolverT (..))-import Data.Morpheus.Server.Deriving.Utils.Kinded (CategoryValue (..))-import Data.Morpheus.Server.Types.SchemaT-  ( TypeFingerprint (..),+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.Proxy (ContextValue (..))+import Data.Morpheus.Server.Types.Directives+  ( GQLDirective (..),+    ToLocations,+    visitTypeName,   )+import Data.Morpheus.Server.Types.Internal+  ( GQLTypeOptions (..),+    TypeData (..),+    defaultTypeOptions,+    mkTypeData,+    prefixInputs,+  )+import Data.Morpheus.Server.Types.SchemaT (SchemaT)+import Data.Morpheus.Server.Types.TypeName+  ( TypeFingerprint,+    getFingerprint,+    getTypename,+  ) import Data.Morpheus.Server.Types.Types   ( Arg,     Pair,     TypeGuard,     Undefined (..),   )+import Data.Morpheus.Types.GQLScalar (EncodeScalar (..))+import Data.Morpheus.Types.GQLWrapper (EncodeWrapperValue (..)) import Data.Morpheus.Types.ID (ID) import Data.Morpheus.Types.Internal.AST-  ( CONST,+  ( Argument (..),+    Arguments,+    ArgumentsDefinition,+    CONST,     Description,     Directives,+    FieldName,+    IN,+    OUT,+    ObjectEntry (..),+    Position (..),     TypeCategory (..),     TypeName,     TypeWrapper (..),-    Value,+    Value (..),+    internal,     mkBaseType,     packName,     toNullable,@@ -69,62 +114,12 @@   ) import Data.Sequence (Seq) import Data.Text-  ( intercalate,-    pack,+  ( pack,     unpack,   )-import Data.Typeable-  ( TyCon,-    TypeRep,-    splitTyConApp,-    tyConFingerprint,-    tyConName,-    typeRep,-    typeRepTyCon,-  ) import Data.Vector (Vector)-import Relude hiding (Seq, Undefined, intercalate)--data TypeData = TypeData-  { gqlTypeName :: TypeName,-    gqlWrappers :: TypeWrapper,-    gqlFingerprint :: TypeFingerprint-  }-  deriving (Show)---- | Options that specify how to map GraphQL field, type, and constructor names--- to and from their Haskell equivalent.------ Options can be set using record syntax on 'defaultOptions' with the fields--- below.-data GQLTypeOptions = GQLTypeOptions-  { -- | Function applied to field labels.-    -- Handy for removing common record prefixes for example.-    fieldLabelModifier :: String -> String,-    -- | Function applied to constructor tags.-    constructorTagModifier :: String -> String,-    -- | Construct a new type name depending on whether it is an input,-    -- and being given the original type name.-    typeNameModifier :: Bool -> String -> String-  }---- | Default encoding 'GQLTypeOptions':------ @--- 'GQLTypeOptions'---   { 'fieldLabelModifier'      = id---   , 'constructorTagModifier'  = id---   , 'typeNameModifier'        = const id---   }--- @-defaultTypeOptions :: GQLTypeOptions-defaultTypeOptions =-  GQLTypeOptions-    { fieldLabelModifier = id,-      constructorTagModifier = id,-      -- default is just a pass through for the original type name-      typeNameModifier = const id-    }+import GHC.Generics+import Relude hiding (Seq, Undefined, fromList, intercalate)  __typeData ::   forall kinded (kind :: TypeCategory) (a :: Type).@@ -133,17 +128,11 @@   TypeData __typeData proxy = __type proxy (categoryValue (Proxy @kind)) -getTypename :: Typeable a => f a -> TypeName-getTypename = packName . intercalate "" . getTypeConstructorNames--getTypeConstructorNames :: Typeable a => f a -> [Text]-getTypeConstructorNames = fmap (pack . tyConName . replacePairCon) . getTypeConstructors--getTypeConstructors :: Typeable a => f a -> [TyCon]-getTypeConstructors = ignoreResolver . splitTyConApp . typeRep+deriveTypename :: (GQLType a, CategoryValue kind) => kinded kind a -> TypeName+deriveTypename proxy = gqlTypeName $ __typeData proxy -prefixInputs :: GQLTypeOptions -> GQLTypeOptions-prefixInputs options = options {typeNameModifier = \isInput name -> if isInput then "Input" <> name else name}+deriveFingerprint :: (GQLType a, CategoryValue kind) => kinded kind a -> TypeFingerprint+deriveFingerprint proxy = gqlFingerprint $ __typeData proxy  deriveTypeData :: Typeable a => f a -> (Bool -> String -> String) -> TypeCategory -> TypeData deriveTypeData proxy typeNameModifier cat =@@ -155,38 +144,12 @@   where     originalTypeName = unpack . unpackName $ getTypename proxy -getFingerprint :: Typeable a => TypeCategory -> f a -> TypeFingerprint-getFingerprint category = TypeableFingerprint category . fmap tyConFingerprint . getTypeConstructors--mkTypeData :: TypeName -> a -> TypeData-mkTypeData name _ =-  TypeData-    { gqlTypeName = name,-      gqlFingerprint = InternalFingerprint name,-      gqlWrappers = mkBaseType-    }- list :: TypeWrapper -> TypeWrapper list = flip TypeList True  wrapper :: (TypeWrapper -> TypeWrapper) -> TypeData -> TypeData wrapper f TypeData {..} = TypeData {gqlWrappers = f gqlWrappers, ..} --- | replaces typeName (A,B) with Pair_A_B-replacePairCon :: TyCon -> TyCon-replacePairCon x | hsPair == x = gqlPair-  where-    hsPair = typeRepTyCon $ typeRep $ Proxy @(Int, Int)-    gqlPair = typeRepTyCon $ typeRep $ Proxy @(Pair Int Int)-replacePairCon x = x---- Ignores Resolver name  from typeName-ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]-ignoreResolver (con, _) | con == typeRepTyCon (typeRep $ Proxy @Resolver) = []-ignoreResolver (con, _) | con == typeRepTyCon (typeRep $ Proxy @NamedResolverT) = []-ignoreResolver (con, args) =-  con : concatMap (ignoreResolver . splitTyConApp) args- -- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'. -- --  @@@ -201,6 +164,8 @@ --     instance GQLType ... where --       description = const "your description ..." --  @+{-# DEPRECATED getDirectives "use: directives" #-}+ class GQLType a where   type KIND a :: DerivingKind   type KIND a = TYPE@@ -211,6 +176,9 @@   description :: f a -> Maybe Text   description _ = Nothing +  directives :: f a -> DirectiveUsages+  directives _ = mempty+   -- | A dictionary of descriptions for fields, keyed on field name.   --   -- Used for documentation in the GraphQL schema.@@ -231,8 +199,9 @@    __type :: f a -> TypeCategory -> TypeData   default __type :: Typeable a => f a -> TypeCategory -> TypeData-  __type proxy = deriveTypeData proxy typeNameModifier+  __type proxy category = editTypeData derivedType (directives proxy)     where+      derivedType = deriveTypeData proxy typeNameModifier category       GQLTypeOptions {typeNameModifier} = typeOptions proxy defaultTypeOptions  instance GQLType Int where@@ -330,3 +299,111 @@ instance (GQLType a) => GQLType (NamedResolverT m a) where   type KIND (NamedResolverT m a) = CUSTOM   __type _ = __type (Proxy :: Proxy a)++type Decode a = EncodeKind (KIND a) a++encodeArguments :: forall a. Decode a => a -> GQLResult (Arguments CONST)+encodeArguments x = encode x >>= unpackValue+  where+    unpackValue (Object v) = pure $ fmap toArgument v+    unpackValue _ = throwError (internal "TODO: expected arguments!")+    toArgument ObjectEntry {..} = Argument (Position 0 0) entryName entryValue++encode :: forall a. Decode 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+  encodeKind = encodeWrapperValue encode . unContextValue++instance (EncodeScalar a) => EncodeKind SCALAR a where+  encodeKind = pure . Scalar . encodeScalar . unContextValue++instance (EncodeConstraint a) => EncodeKind TYPE a where+  encodeKind = exploreResolvers . unContextValue++convertNode ::+  DataType (GQLResult (Value CONST)) ->+  GQLResult (Value CONST)+convertNode+  DataType+    { tyIsUnion,+      tyCons = ConsRep {consFields, consName}+    } = encodeTypeFields consFields+    where+      encodeTypeFields ::+        [FieldRep (GQLResult (Value CONST))] -> GQLResult (Value CONST)+      encodeTypeFields [] = pure $ Enum consName+      encodeTypeFields fields | not tyIsUnion = Object <$> (traverse fromField fields >>= fromElems)+        where+          fromField FieldRep {fieldSelector, fieldValue} = do+            entryValue <- fieldValue+            pure ObjectEntry {entryName = fieldSelector, entryValue}+      -- Type References --------------------------------------------------------------+      encodeTypeFields _ = throwError (internal "TODO: union not supported")++-- Types & Constrains -------------------------------------------------------+class (EncodeKind (KIND a) a, GQLType a) => ExplorerConstraint a++instance (EncodeKind (KIND a) a, GQLType a) => ExplorerConstraint a++exploreResolvers :: forall a. EncodeConstraint a => a -> GQLResult (Value CONST)+exploreResolvers =+  convertNode+    . deriveValue+      ( DeriveValueOptions+          { __valueApply = encode,+            __valueTypeName = deriveTypename (KindedProxy :: KindedProxy IN a),+            __valueGQLOptions = typeOptions (Proxy @a) defaultTypeOptions,+            __valueGetType = __typeData . kinded (Proxy @IN)+          } ::+          DeriveValueOptions IN ExplorerConstraint (GQLResult (Value CONST))+      )++type EncodeConstraint a =+  ( Generic a,+    GQLType a,+    DeriveWith 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++instance Semigroup DirectiveUsages where+  DirectiveUsages td1 fd1 ed1 <> DirectiveUsages td2 fd2 ed2 = DirectiveUsages (td1 <> td2) (fd1 <> fd2) (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 fieldName x = DirectiveUsages mempty (M.singleton fieldName [DirectiveUsage x]) mempty++enumDirective :: TypeDirectiveConstraint a => TypeName -> a -> DirectiveUsages+enumDirective fieldName x = DirectiveUsages mempty mempty (M.singleton fieldName [DirectiveUsage x])++data DirectiveUsage where+  DirectiveUsage :: (GQLDirective a, GQLType a, Decode a, DeriveArguments (KIND a) a, ToLocations (DIRECTIVE_LOCATIONS a)) => a -> DirectiveUsage++applyOnTypeName :: DirectiveUsage -> TypeName -> TypeName+applyOnTypeName (DirectiveUsage x) = visitTypeName x++typeNameWithDirectives :: TypeName -> [DirectiveUsage] -> TypeName+typeNameWithDirectives = foldr applyOnTypeName++editTypeData :: TypeData -> DirectiveUsages -> TypeData+editTypeData TypeData {..} DirectiveUsages {typeDirectives} = TypeData {gqlTypeName = typeNameWithDirectives gqlTypeName typeDirectives, ..}

@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Types.Internal+  ( GQLTypeOptions (..),+    defaultTypeOptions,+    TypeData (..),+    prefixInputs,+    mkTypeData,+    dropNamespaceOptions,+  )+where++-- MORPHEUS++import Data.Char (toLower)+import Data.Morpheus.Server.Types.TypeName (TypeFingerprint (..))+import Data.Morpheus.Types.Internal.AST+  ( TypeKind (..),+    TypeName,+    TypeWrapper (..),+    mkBaseType,+  )+import qualified Data.Text as T+import Relude hiding (Seq, Undefined, intercalate)++data TypeData = TypeData+  { gqlTypeName :: TypeName,+    gqlWrappers :: TypeWrapper,+    gqlFingerprint :: TypeFingerprint+  }+  deriving (Show)++-- | Options that specify how to map GraphQL field, type, and constructor names+-- to and from their Haskell equivalent.+--+-- Options can be set using record syntax on 'defaultOptions' with the fields+-- below.+data GQLTypeOptions = GQLTypeOptions+  { -- | Function applied to field labels.+    -- Handy for removing common record prefixes for example.+    fieldLabelModifier :: String -> String,+    -- | Function applied to constructor tags.+    constructorTagModifier :: String -> String,+    -- | Construct a new type name depending on whether it is an input,+    -- and being given the original type name.+    typeNameModifier :: Bool -> String -> String+  }++-- | Default encoding 'GQLTypeOptions':+--+-- @+-- 'GQLTypeOptions'+--   { 'fieldLabelModifier'      = id+--   , 'constructorTagModifier'  = id+--   , 'typeNameModifier'        = const id+--   }+-- @+defaultTypeOptions :: GQLTypeOptions+defaultTypeOptions =+  GQLTypeOptions+    { fieldLabelModifier = id,+      constructorTagModifier = id,+      -- default is just a pass through for the original type name+      typeNameModifier = const id+    }++prefixInputs :: GQLTypeOptions -> GQLTypeOptions+prefixInputs options = options {typeNameModifier = \isInput name -> if isInput then "Input" <> name else name}++mkTypeData :: TypeName -> a -> TypeData+mkTypeData name _ =+  TypeData+    { gqlTypeName = name,+      gqlFingerprint = InternalFingerprint name,+      gqlWrappers = mkBaseType+    }++dropPrefix :: Text -> String -> String+dropPrefix name = drop (T.length name)++stripConstructorNamespace :: Text -> String -> String+stripConstructorNamespace = dropPrefix++stripFieldNamespace :: Text -> String -> String+stripFieldNamespace prefix = __uncapitalize . dropPrefix prefix+  where+    __uncapitalize [] = []+    __uncapitalize (x : xs) = toLower x : xs++dropNamespaceOptions :: TypeKind -> Text -> GQLTypeOptions -> GQLTypeOptions+dropNamespaceOptions KindInterface tName opt =+  opt+    { typeNameModifier = const (stripConstructorNamespace "Interface"),+      fieldLabelModifier = stripFieldNamespace tName+    }+dropNamespaceOptions KindEnum tName opt = opt {constructorTagModifier = stripConstructorNamespace tName}+dropNamespaceOptions _ tName opt = opt {fieldLabelModifier = stripFieldNamespace tName}

@@ -1,15 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Types.SchemaT@@ -20,50 +17,57 @@     toSchema,     withInput,     extendImplements,+    insertDirectiveDefinition,+    outToAny,   ) where  import Control.Monad.Except (MonadError (..)) import qualified Data.Map as Map import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Server.Types.TypeName import Data.Morpheus.Types.Internal.AST   ( ANY,     CONST,+    DirectiveDefinition,     GQLError,     IN,     OBJECT,     OUT,-    Schema (..),+    Schema,     TypeCategory (..),     TypeContent (..),     TypeDefinition (..),     TypeName,+    defineDirective,     defineSchemaWith,     msg,     toAny,   )-import GHC.Fingerprint.Type (Fingerprint) import Relude hiding (empty) -data TypeFingerprint-  = TypeableFingerprint TypeCategory [Fingerprint]-  | InternalFingerprint TypeName-  | CustomFingerprint TypeName-  deriving-    ( Generic,-      Show,-      Eq,-      Ord-    )+data SchemaState where+  SchemaState ::+    { typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST),+      implements :: Map TypeName [TypeName],+      directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)+    } ->+    SchemaState -type MyMap = (Map TypeFingerprint (TypeDefinition ANY CONST), Map TypeName [TypeName])+emptyMyMap :: SchemaState+emptyMyMap =+  SchemaState+    { typeDefinitions = Map.empty,+      implements = Map.empty,+      directiveDefinitions = Map.empty+    }  -- Helper Functions newtype SchemaT (cat :: TypeCategory) a = SchemaT   { runSchemaT ::       GQLResult         ( a,-          [MyMap -> GQLResult MyMap]+          [SchemaState -> GQLResult SchemaState]         )   }   deriving (Functor)@@ -97,9 +101,10 @@   GQLResult (Schema CONST) toSchema (SchemaT v) = do   ((q, m, s), typeDefs) <- v-  (typeDefinitions, implements) <- execUpdates (Map.empty, Map.empty) typeDefs+  SchemaState {typeDefinitions, implements, directiveDefinitions} <- execUpdates emptyMyMap typeDefs   types <- map (insertImplements implements) <$> checkTypeCollisions (Map.toList typeDefinitions)-  defineSchemaWith types (Just q, m, s)+  schema <- defineSchemaWith types (Just q, m, s)+  foldlM defineDirective schema directiveDefinitions  insertImplements :: Map TypeName [TypeName] -> TypeDefinition c CONST -> TypeDefinition c CONST insertImplements x TypeDefinition {typeContent = DataObject {..}, ..} =@@ -119,6 +124,9 @@ withInput :: SchemaT IN a -> SchemaT OUT a withInput (SchemaT x) = SchemaT x +outToAny :: SchemaT OUT a -> SchemaT k' a+outToAny (SchemaT x) = SchemaT x+ checkTypeCollisions :: [(TypeFingerprint, TypeDefinition k a)] -> GQLResult [TypeDefinition k a] checkTypeCollisions = fmap Map.elems . foldlM collectTypes Map.empty   where@@ -162,20 +170,46 @@ updateSchema fingerprint f x =   SchemaT $ pure ((), [upLib])   where-    upLib :: MyMap -> GQLResult MyMap-    upLib (lib, conn)-      | Map.member fingerprint lib = pure (lib, conn)+    upLib :: SchemaState -> GQLResult SchemaState+    upLib schema+      | Map.member fingerprint (typeDefinitions schema) = pure schema       | otherwise = do-        (type', updates) <- runSchemaT (f x)-        execUpdates (lib, conn) (update type' : updates)+          (type', updates) <- runSchemaT (f x)+          execUpdates schema (update type' : updates)       where-        update t (ts, c) = pure (Map.insert fingerprint (toAny t) ts, c)+        update t schemaState =+          pure+            schemaState+              { typeDefinitions = Map.insert fingerprint (toAny t) (typeDefinitions schemaState)+              } +insertDirectiveDefinition ::+  TypeFingerprint ->+  (a -> SchemaT cat' (DirectiveDefinition CONST)) ->+  a ->+  SchemaT cat' ()+insertDirectiveDefinition InternalFingerprint {} _ _ = SchemaT $ pure ((), [])+insertDirectiveDefinition fingerprint f x =+  SchemaT $ pure ((), [upLib])+  where+    upLib :: SchemaState -> GQLResult SchemaState+    upLib schema+      | Map.member fingerprint (typeDefinitions schema) = pure schema+      | otherwise = do+          (type', updates) <- runSchemaT (f x)+          execUpdates schema (update type' : updates)+      where+        update t schemaState =+          pure+            schemaState+              { directiveDefinitions = Map.insert fingerprint t (directiveDefinitions schemaState)+              }+ extendImplements :: TypeName -> [TypeName] -> SchemaT cat' () extendImplements interface types = SchemaT $ pure ((), [upLib])   where     -- TODO: what happens if interface name collides?-    upLib :: MyMap -> GQLResult MyMap-    upLib (lib, con) = pure (lib, foldr insertInterface con types)+    upLib :: SchemaState -> GQLResult SchemaState+    upLib schema = pure schema {implements = foldr insertInterface (implements schema) types}     insertInterface :: TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]     insertInterface = Map.alter (Just . (interface :) . fromMaybe [])

@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Types.TypeName+  ( getTypename,+    getTypeConstructorNames,+    getFingerprint,+    TypeFingerprint (..),+  )+where++-- MORPHEUS++import Data.Data (tyConFingerprint)+import Data.Morpheus.App.Internal.Resolving+  ( Resolver,+  )+import Data.Morpheus.NamedResolvers (NamedResolverT (..))+import Data.Morpheus.Server.Types.Types+  ( Pair,+  )+import Data.Morpheus.Types.Internal.AST+  ( TypeCategory,+    TypeName,+    packName,+  )+import Data.Text+  ( intercalate,+    pack,+  )+import Data.Typeable+  ( TyCon,+    TypeRep,+    splitTyConApp,+    tyConName,+    typeRep,+    typeRepTyCon,+  )+import GHC.Fingerprint+import Relude hiding (Seq, Undefined, intercalate)++data TypeFingerprint+  = TypeableFingerprint TypeCategory [Fingerprint]+  | InternalFingerprint TypeName+  | CustomFingerprint TypeName+  deriving+    ( Generic,+      Show,+      Eq,+      Ord+    )++getTypename :: Typeable a => f a -> TypeName+getTypename = packName . intercalate "" . getTypeConstructorNames++getTypeConstructorNames :: Typeable a => f a -> [Text]+getTypeConstructorNames = fmap (pack . tyConName . replacePairCon) . getTypeConstructors++getTypeConstructors :: Typeable a => f a -> [TyCon]+getTypeConstructors = ignoreResolver . splitTyConApp . typeRep++-- | replaces typeName (A,B) with Pair_A_B+replacePairCon :: TyCon -> TyCon+replacePairCon x | hsPair == x = gqlPair+  where+    hsPair = typeRepTyCon $ typeRep $ Proxy @(Int, Int)+    gqlPair = typeRepTyCon $ typeRep $ Proxy @(Pair Int Int)+replacePairCon x = x++-- Ignores Resolver name  from typeName+ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]+ignoreResolver (con, _) | con == typeRepTyCon (typeRep $ Proxy @Resolver) = []+ignoreResolver (con, _) | con == typeRepTyCon (typeRep $ Proxy @NamedResolverT) = []+ignoreResolver (con, args) =+  con : concatMap (ignoreResolver . splitTyConApp) args++getFingerprint :: Typeable a => TypeCategory -> f a -> TypeFingerprint+getFingerprint category = TypeableFingerprint category . fmap tyConFingerprint . getTypeConstructors

@@ -0,0 +1,40 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Server.Types.Visitors+  ( VisitType (..),+    VisitField (..),+    VisitEnum (..),+  )+where++import Relude++class VisitType a where+  visitTypeName :: a -> Text -> Text+  visitTypeName _ = id++  visitTypeDescription :: a -> Maybe Text -> Maybe Text+  visitTypeDescription = const id++class VisitField a where+  visitFieldName :: a -> Text -> Text+  visitFieldName _ = id++  visitFieldDescription :: a -> Maybe Text -> Maybe Text+  visitFieldDescription _ = id++class VisitEnum a where+  visitEnumName :: a -> Text -> Text+  visitEnumName _ = id++  visitEnumDescription :: a -> Maybe Text -> Maybe Text+  visitEnumDescription _ = id

@@ -11,7 +11,15 @@  -- | GQL Types module Data.Morpheus.Types-  ( GQLType (KIND, description, getDescriptions, typeOptions, getDirectives, defaultValues),+  ( GQLType+      ( KIND,+        description,+        getDescriptions,+        typeOptions,+        getDirectives,+        defaultValues,+        directives+      ),     EncodeScalar (..),     EncodeWrapper (..),     DecodeScalar (..),@@ -65,6 +73,20 @@     constructorTagModifier,     typeNameModifier,     defaultRootResolver,++    -- * GQL directives API+    Prefixes (..),+    VisitType (..),+    VisitField (..),+    VisitEnum (..),+    typeDirective,+    fieldDirective,+    enumDirective,++    -- * default GQL directives+    GQLDirective (..),+    Deprecated (..),+    dropNamespaceOptions,   ) where @@ -90,16 +112,31 @@   ( NamedResolverT (..),     ResolveNamed (..),   )+-- FIXME: TO ENABLE DECODE INSTANCE ON DIRECTIVES+import Data.Morpheus.Server.Deriving.Decode ()+import Data.Morpheus.Server.Types.DirectiveDefinitions+import Data.Morpheus.Server.Types.Directives import Data.Morpheus.Server.Types.GQLType   ( GQLType (..),-    GQLTypeOptions (..),+    enumDirective,+    fieldDirective,+    typeDirective,+  )+import Data.Morpheus.Server.Types.Internal+  ( GQLTypeOptions (..),     defaultTypeOptions,+    dropNamespaceOptions,   ) import Data.Morpheus.Server.Types.Types   ( Arg (..),     TypeGuard (..),     Undefined (..),   )+import Data.Morpheus.Server.Types.Visitors+  ( VisitEnum (..),+    VisitField (..),+    VisitType (..),+  ) import Data.Morpheus.Types.GQLScalar   ( DecodeScalar (..),     EncodeScalar (..),@@ -134,13 +171,9 @@   type Flexible m a = m (a m)   type Composed m f a = m (f (a m)) -type ResolverO o e m a =-  (WithOperation o) =>-  Flexible (Resolver o e m) a+type ResolverO o e m a = Flexible (Resolver o e m) a -type ComposedResolver o e m f a =-  (WithOperation o) =>-  Composed (Resolver o e m) f a+type ComposedResolver o e m f a = Composed (Resolver o e m) f a  type ResolverQ e m a = Flexible (Resolver QUERY e m) a 

@@ -0,0 +1,99 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Feature.Directive.Definition+  ( api,+  )+where++import Data.Kind (Type)+import Data.Morpheus (interpreter)+import Data.Morpheus.Types+  ( Deprecated (..),+    GQLDirective (..),+    GQLRequest,+    GQLResponse,+    GQLType (..),+    Prefixes (..),+    RootResolver (..),+    Undefined,+    VisitType (..),+    defaultRootResolver,+    enumDirective,+    fieldDirective,+    typeDirective,+  )+import Data.Morpheus.Types.Internal.AST+  ( DirectiveLocation (..),+  )+import Data.Text (Text)+import GHC.Generics (Generic)++data MythologyDeity = MythologyDeity+  { deityName :: Text,+    deprecatedField :: Maybe Text,+    deprecatedFieldWithReason :: Bool+  }+  deriving (Generic)++data Power = Power+  { name :: Text,+    isLimited :: Bool+  }+  deriving (GQLType, Generic)++instance GQLDirective Power where+  type DIRECTIVE_LOCATIONS Power = '[ 'OBJECT]++instance VisitType Power where+  visitTypeName _ = id++instance GQLType MythologyDeity where+  directives _ =+    typeDirective Power {name = "Lightning bolts", isLimited = False}+      <> typeDirective Prefixes {addPrefix = "", removePrefix = "Mythology"}+      <> fieldDirective "deprecatedField" Deprecated {reason = Nothing}+      <> fieldDirective "deprecatedFieldWithReason" Deprecated {reason = Just "this should be deprecated"}++data City+  = Athens+  | Sparta+  | Corinth+  | Delphi+  | Argos+  deriving+    (Generic)++instance GQLType City where+  directives _ =+    enumDirective "Sparta" Deprecated {reason = Nothing}+      <> enumDirective "Delphi" Deprecated {reason = Just "oracle left the place"}+      <> enumDirective "Argos" Deprecated {reason = Just "for some reason"}++data Query (m :: Type -> Type) = Query+  { deity :: MythologyDeity,+    city :: City+  }+  deriving (Generic, GQLType)++root :: RootResolver IO () Query Undefined Undefined+root =+  defaultRootResolver+    { queryResolver =+        Query+          { deity =+              MythologyDeity+                { deityName = "morpheus",+                  deprecatedField = Nothing,+                  deprecatedFieldWithReason = False+                },+            city = Corinth+          }+    }++api :: GQLRequest -> IO GQLResponse+api = interpreter root

@@ -0,0 +1,53 @@+query Get__Type {+  __schema {+    directives {+      name+      description+      locations+      args {+        ...InputValue+      }+    }+  }+}++fragment InputValue on __InputValue {+  name+  type {+    ...TypeRef+  }+  defaultValue+}++fragment TypeRef on __Type {+  kind+  name+  ofType {+    kind+    name+    ofType {+      kind+      name+      ofType {+        kind+        name+        ofType {+          kind+          name+          ofType {+            kind+            name+            ofType {+              kind+              name+              ofType {+                kind+                name+              }+            }+          }+        }+      }+    }+  }+}

@@ -0,0 +1,121 @@+{+  "data": {+    "__schema": {+      "directives": [+        {+          "args": [+            {+              "defaultValue": null,+              "name": "name",+              "type": {+                "kind": "NON_NULL",+                "name": null,+                "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }+              }+            },+            {+              "defaultValue": null,+              "name": "isLimited",+              "type": {+                "kind": "NON_NULL",+                "name": null,+                "ofType": {+                  "kind": "SCALAR",+                  "name": "Boolean",+                  "ofType": null+                }+              }+            }+          ],+          "description": null,+          "locations": ["OBJECT"],+          "name": "Power"+        },+        {+          "args": [+            {+              "defaultValue": null,+              "name": "addPrefix",+              "type": {+                "kind": "NON_NULL",+                "name": null,+                "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }+              }+            },+            {+              "defaultValue": null,+              "name": "removePrefix",+              "type": {+                "kind": "NON_NULL",+                "name": null,+                "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }+              }+            }+          ],+          "description": null,+          "locations": [+            "OBJECT",+            "ENUM",+            "INPUT_OBJECT",+            "UNION",+            "SCALAR",+            "INTERFACE"+          ],+          "name": "Prefixes"+        },+        {+          "args": [+            {+              "defaultValue": null,+              "name": "reason",+              "type": { "kind": "SCALAR", "name": "String", "ofType": null }+            }+          ],+          "description": "\nMarks an element of a GraphQL schema as no longer supported.\n",+          "locations": ["FIELD_DEFINITION", "ENUM_VALUE"],+          "name": "deprecated"+        },+        {+          "args": [+            {+              "defaultValue": null,+              "name": "if",+              "type": {+                "kind": "NON_NULL",+                "name": null,+                "ofType": {+                  "kind": "SCALAR",+                  "name": "Boolean",+                  "ofType": null+                }+              }+            }+          ],+          "description": "\nDirects the executor to include this field or fragment only when the `if` argument is true.\n",+          "locations": ["FIELD", "FRAGMENT_SPREAD", "INLINE_FRAGMENT"],+          "name": "include"+        },+        {+          "args": [+            {+              "defaultValue": null,+              "name": "if",+              "type": {+                "kind": "NON_NULL",+                "name": null,+                "ofType": {+                  "kind": "SCALAR",+                  "name": "Boolean",+                  "ofType": null+                }+              }+            }+          ],+          "description": "\nDirects the executor to skip this field or fragment when the `if` argument is true.\n",+          "locations": ["FIELD", "FRAGMENT_SPREAD", "INLINE_FRAGMENT"],+          "name": "skip"+        }+      ]+    }+  }+}

@@ -0,0 +1,76 @@+query Get__Type {+  city: __type(name: "City") {+    ...FullType+  }+}++fragment FullType on __Type {+  kind+  name+  fields(includeDeprecated: true) {+    name+    args {+      ...InputValue+    }+    type {+      ...TypeRef+    }+    isDeprecated+    deprecationReason+  }+  inputFields {+    ...InputValue+  }+  interfaces {+    ...TypeRef+  }+  enumValues(includeDeprecated: true) {+    name+    isDeprecated+    deprecationReason+  }+  possibleTypes {+    ...TypeRef+  }+}++fragment InputValue on __InputValue {+  name+  type {+    ...TypeRef+  }+  defaultValue+}++fragment TypeRef on __Type {+  kind+  name+  ofType {+    kind+    name+    ofType {+      kind+      name+      ofType {+        kind+        name+        ofType {+          kind+          name+          ofType {+            kind+            name+            ofType {+              kind+              name+              ofType {+                kind+                name+              }+            }+          }+        }+      }+    }+  }+}

@@ -0,0 +1,39 @@+{+  "data": {+    "city": {+      "enumValues": [+        {+          "deprecationReason": null,+          "isDeprecated": false,+          "name": "Athens"+        },+        {+          "deprecationReason": null,+          "isDeprecated": true,+          "name": "Sparta"+        },+        {+          "deprecationReason": null,+          "isDeprecated": false,+          "name": "Corinth"+        },+        {+          "deprecationReason": "oracle left the place",+          "isDeprecated": true,+          "name": "Delphi"+        },+        {+          "deprecationReason": "for some reason",+          "isDeprecated": true,+          "name": "Argos"+        }+      ],+      "fields": null,+      "inputFields": null,+      "interfaces": null,+      "kind": "ENUM",+      "name": "City",+      "possibleTypes": null+    }+  }+}

@@ -0,0 +1,79 @@+query Get__Type {+  deity: __type(name: "Deity") {+    ...FullType+  }+  shouldBeNull: __type(name: "MythologyDeity") {+    ...FullType+  }+}++fragment FullType on __Type {+  kind+  name+  fields(includeDeprecated: true) {+    name+    args {+      ...InputValue+    }+    type {+      ...TypeRef+    }+    isDeprecated+    deprecationReason+  }+  inputFields {+    ...InputValue+  }+  interfaces {+    ...TypeRef+  }+  enumValues(includeDeprecated: true) {+    name+    isDeprecated+    deprecationReason+  }+  possibleTypes {+    ...TypeRef+  }+}++fragment InputValue on __InputValue {+  name+  type {+    ...TypeRef+  }+  defaultValue+}++fragment TypeRef on __Type {+  kind+  name+  ofType {+    kind+    name+    ofType {+      kind+      name+      ofType {+        kind+        name+        ofType {+          kind+          name+          ofType {+            kind+            name+            ofType {+              kind+              name+              ofType {+                kind+                name+              }+            }+          }+        }+      }+    }+  }+}

@@ -0,0 +1,56 @@+{+  "data": {+    "deity": {+      "enumValues": null,+      "fields": [+        {+          "args": [],+          "deprecationReason": null,+          "isDeprecated": false,+          "name": "deityName",+          "type": {+            "kind": "NON_NULL",+            "name": null,+            "ofType": {+              "kind": "SCALAR",+              "name": "String",+              "ofType": null+            }+          }+        },+        {+          "args": [],+          "deprecationReason": null,+          "isDeprecated": true,+          "name": "deprecatedField",+          "type": {+            "kind": "SCALAR",+            "name": "String",+            "ofType": null+          }+        },+        {+          "args": [],+          "deprecationReason": "this should be deprecated",+          "isDeprecated": true,+          "name": "deprecatedFieldWithReason",+          "type": {+            "kind": "NON_NULL",+            "name": null,+            "ofType": {+              "kind": "SCALAR",+              "name": "Boolean",+              "ofType": null+            }+          }+        }+      ],+      "inputFields": null,+      "interfaces": [],+      "kind": "OBJECT",+      "name": "Deity",+      "possibleTypes": null+    },+    "shouldBeNull": null+  }+}

@@ -18,6 +18,9 @@ where  import Control.Monad.Fail (fail)+import Data.FileEmbed+  ( makeRelativeToProject,+  ) import Data.Morpheus (deriveApp, runApp) import Data.Morpheus.Document   ( importGQLDocument,@@ -28,6 +31,7 @@ import Data.Morpheus.Types   ( Arg (..),     DecodeScalar (..),+    Deprecated (..),     EncodeScalar (..),     GQLRequest,     GQLResponse,@@ -59,6 +63,7 @@     (+),     (.),     (<$>),+    (=<<),   )  data TestScalar@@ -82,9 +87,9 @@  type EVENT = Event Channel () -importGQLDocumentWithNamespace "test/Feature/Holistic/schema.gql"+importGQLDocumentWithNamespace =<< makeRelativeToProject "test/Feature/Holistic/schema.gql" -importGQLDocument "test/Feature/Holistic/schema-ext.gql"+importGQLDocument =<< makeRelativeToProject "test/Feature/Holistic/schema-ext.gql"  alwaysFail :: IO (Either String a) alwaysFail = pure $ Left "fail with Either"@@ -95,7 +100,8 @@     { queryResolver =         Query           { queryUser,-            queryTestUnion = Just . TestUnionUser <$> queryUser,+            queryTestUnion =+              Just . TestUnionUser <$> queryUser,             queryPerson =               pure                 ( ResolveType

@@ -3,11 +3,21 @@     "__schema": {       "directives": [         {-          "name": "skip",-          "description": "\nDirects the executor to skip this field or fragment when the `if` argument is true.\n",-          "locations": ["FIELD", "FRAGMENT_SPREAD", "INLINE_FRAGMENT"],           "args": [             {+              "defaultValue": null,+              "name": "reason",+              "type": { "kind": "SCALAR", "name": "String", "ofType": null }+            }+          ],+          "description": "\nMarks an element of a GraphQL schema as no longer supported.\n",+          "locations": ["FIELD_DEFINITION", "ENUM_VALUE"],+          "name": "deprecated"+        },+        {+          "args": [+            {+              "defaultValue": null,               "name": "if",               "type": {                 "kind": "NON_NULL",@@ -17,17 +27,17 @@                   "name": "Boolean",                   "ofType": null                 }-              },-              "defaultValue": null+              }             }-          ]-        },-        {-          "name": "include",+          ],           "description": "\nDirects the executor to include this field or fragment only when the `if` argument is true.\n",           "locations": ["FIELD", "FRAGMENT_SPREAD", "INLINE_FRAGMENT"],+          "name": "include"+        },+        {           "args": [             {+              "defaultValue": null,               "name": "if",               "type": {                 "kind": "NON_NULL",@@ -37,22 +47,12 @@                   "name": "Boolean",                   "ofType": null                 }-              },-              "defaultValue": null-            }-          ]-        },-        {-          "name": "deprecated",-          "description": "\nMarks an element of a GraphQL schema as no longer supported.\n",-          "locations": ["FIELD_DEFINITION", "ENUM_VALUE"],-          "args": [-            {-              "name": "reason",-              "type": { "kind": "SCALAR", "name": "String", "ofType": null },-              "defaultValue": null+              }             }-          ]+          ],+          "description": "\nDirects the executor to skip this field or fragment when the `if` argument is true.\n",+          "locations": ["FIELD", "FRAGMENT_SPREAD", "INLINE_FRAGMENT"],+          "name": "skip"         }       ]     }

@@ -1,3 +1,5 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-}@@ -15,6 +17,9 @@   ) where +import Data.FileEmbed+  ( makeRelativeToProject,+  ) import Data.Morpheus.Document   ( importGQLDocumentWithNamespace,   )@@ -23,16 +28,19 @@     ID,     RootResolver,     Undefined,+    VisitType,   ) import Relude hiding (Undefined) -data TestScalar = TestScalar-  deriving (Show)+data TestScalar = TestScalar deriving (Show)  instance DecodeScalar TestScalar where-  decodeScalar _ = pure TestScalar+  decodeScalar = const (pure TestScalar) -importGQLDocumentWithNamespace "test/Rendering/schema.gql"+importGQLDocumentWithNamespace+  =<< makeRelativeToProject "test/Rendering/schema.gql"++instance VisitType TestDirective  type APIResolver e (m :: Type -> Type) =   RootResolver m e MyQuery MyMutation Undefined

@@ -1,19 +1,21 @@-scalar TestScalar+directive @TestDirective(name: String!, enum: TestEnum) on INPUT_OBJECT | OBJECT -enum TestEnum {+scalar TestScalar @TestDirective(name: "SomeName")++enum TestEnum @TestDirective(name: "SomeName") {   EnumA-  EnumB+  EnumB @TestDirective(name: "SomeName")   EnumC } -input Coordinates {+input Coordinates @TestDirective(name: "SomeName") {   latitude: TestScalar!-  longitude: Int!+  longitude: Int! @TestDirective(name: "SomeName") }  type Address {   street: [[[[String!]!]!]]-  score: Float!+  score: Float! @TestDirective(name: "SomeName") }  type User {@@ -22,7 +24,7 @@   friend(id: ID!, cityID: TestEnum): User! } -union TestUnion = User | Address+union TestUnion @TestDirective(name: "SomeName") = User | Address  type MyQuery {   user: User!

@@ -11,6 +11,7 @@ import qualified Feature.Collision.CategoryCollisionFail as TypeCategoryCollisionFail import qualified Feature.Collision.CategoryCollisionSuccess as TypeCategoryCollisionSuccess import qualified Feature.Collision.NameCollision as NameCollision+import qualified Feature.Directive.Definition as DirectiveDefinition import qualified Feature.Holistic.API as Holistic import qualified Feature.Inference.ObjectAndEnum as ObjectAndEnum import qualified Feature.Inference.TaggedArguments as TaggedArguments@@ -83,6 +84,10 @@           (TaggedArguments.api, "tagged-arguments"),           (TaggedArgumentsFail.api, "tagged-arguments-fail"),           (ObjectAndEnum.api, "object-and-enum")+        ],+      testFeatures+        "Directive"+        [ (DirectiveDefinition.api, "definition")         ],       testFeatures         "Holistic"

@@ -125,7 +125,7 @@ expectedResponse expected value   | expected == value = pure ()   | otherwise =-    assertFailure $ "expected: \n " <> show expected <> " \n but got: \n " <> show value+      assertFailure $ "expected: \n " <> show expected <> " \n but got: \n " <> show value  testResponse :: [ByteString] -> [ByteString] -> TestTree testResponse expected =@@ -144,35 +144,37 @@ storeIsEmpty :: (Show ch) => Store (Event ch con) -> TestTree storeIsEmpty cStore   | null (toList cStore) =-    testCase "connectionStore: is empty" $ pure ()+      testCase "connectionStore: is empty" $ pure ()   | otherwise =-    testCase "connectionStore: is empty"-      $ assertFailure-      $ " must be empty but "-        <> show-          cStore+      testCase "connectionStore: is empty" $+        assertFailure $+          " must be empty but "+            <> show+              cStore  storedSingle :: (Show ch) => Store (Event ch con) -> TestTree storedSingle cStore   | length (toList cStore) == 1 =-    testCase "stored single connection" $ pure ()+      testCase "stored single connection" $ pure ()   | otherwise =-    testCase "stored single connection"-      $ assertFailure-      $ "connectionStore must store single connection"-        <> show-          cStore+      testCase "stored single connection" $+        assertFailure $+          "connectionStore must store single connection"+            <> show+              cStore  stored :: (Show ch) => Input SUB -> Store (Event ch con) -> TestTree stored (InitConnection uuid) cStore   | isJust (lookup uuid (toList cStore)) =-    testCase "stored connection" $ pure ()+      testCase "stored connection" $ pure ()   | otherwise =-    testCase "stored connection"-      $ assertFailure-      $ " must store connection \"" <> show uuid <> "\" but stored: "-        <> show-          cStore+      testCase "stored connection" $+        assertFailure $+          " must store connection \""+            <> show uuid+            <> "\" but stored: "+            <> show+              cStore  storeSubscriptions ::   (Show ch) =>@@ -188,19 +190,23 @@     where       checkSession (Just conn)         | sort sids == sort (connectionSessionIds conn) =-          testCase "stored subscriptions" $ pure ()+            testCase "stored subscriptions" $ pure ()         | otherwise =-          testCase "stored subscriptions"-            $ assertFailure-            $ " must store subscriptions with id \"" <> show sids <> "\" but stored: "-              <> show-                (connectionSessionIds conn)+            testCase "stored subscriptions" $+              assertFailure $+                " must store subscriptions with id \""+                  <> show sids+                  <> "\" but stored: "+                  <> show+                    (connectionSessionIds conn)       checkSession _ =-        testCase "stored connection"-          $ assertFailure-          $ " must store connection \"" <> show uuid <> "\" but: "-            <> show-              cStore+        testCase "stored connection" $+          assertFailure $+            " must store connection \""+              <> show uuid+              <> "\" but: "+              <> show+                cStore  apolloStart :: ByteString -> ByteString -> ByteString apolloStart query sid = "{\"id\":\"" <> sid <> "\",\"type\":\"start\",\"payload\":{\"variables\":{},\"operationName\":\"MySubscription\",\"query\":\"" <> query <> "\"}}"