morpheus-graphql-core 0.13.0 → 0.14.0

raw patch · 166 files changed

+7196/−4053 lines, 166 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +4/−7
• changelog.md +80/−1
• morpheus-graphql-core.cabal +91/−15
• src/Data/Morpheus/Core.hs +57/−48
• src/Data/Morpheus/Error.hs +0/−3
• src/Data/Morpheus/Error/Document/Interface.hs +18/−33
• src/Data/Morpheus/Error/Fragment.hs +12/−9
• src/Data/Morpheus/Error/Input.hs +8/−7
• src/Data/Morpheus/Error/Internal.hs +0/−37
• src/Data/Morpheus/Error/NameCollision.hs +4/−3
• src/Data/Morpheus/Error/Operation.hs +11/−7
• src/Data/Morpheus/Error/Schema.hs +9/−11
• src/Data/Morpheus/Error/Selection.hs +11/−9
• src/Data/Morpheus/Error/Utils.hs +8/−0
• src/Data/Morpheus/Error/Variable.hs +10/−8
• src/Data/Morpheus/Error/Warning.hs +9/−0
• src/Data/Morpheus/Internal/Graph.hs +62/−0
• src/Data/Morpheus/Internal/TH.hs +265/−90
• src/Data/Morpheus/Internal/Utils.hs +167/−27
• src/Data/Morpheus/Parser.hs +20/−11
• src/Data/Morpheus/Parsing/Document/TypeSystem.hs +204/−28
• src/Data/Morpheus/Parsing/Internal/Pattern.hs +74/−13
• src/Data/Morpheus/Parsing/Internal/Terms.hs +142/−113
• src/Data/Morpheus/Parsing/Internal/Value.hs +17/−35
• src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +0/−116
• src/Data/Morpheus/Parsing/JSONSchema/Types.hs +0/−86
• src/Data/Morpheus/Parsing/Request/Operation.hs +4/−18
• src/Data/Morpheus/Parsing/Request/Parser.hs +2/−2
• src/Data/Morpheus/Parsing/Request/Selection.hs +2/−2
• src/Data/Morpheus/QuasiQuoter.hs +2/−2
• src/Data/Morpheus/Rendering/RenderGQL.hs +57/−6
• src/Data/Morpheus/Rendering/RenderIntrospection.hs +94/−139
• src/Data/Morpheus/Schema/DSL.hs +7/−7
• src/Data/Morpheus/Schema/Directives.hs +0/−43
• src/Data/Morpheus/Schema/Schema.hs +35/−49
• src/Data/Morpheus/Schema/SchemaAPI.hs +20/−25
• src/Data/Morpheus/Schema/TypeKind.hs +0/−22
• src/Data/Morpheus/Types/GQLScalar.hs +15/−2
• src/Data/Morpheus/Types/ID.hs +12/−4
• src/Data/Morpheus/Types/IO.hs +19/−7
• src/Data/Morpheus/Types/Internal/AST.hs +45/−24
• src/Data/Morpheus/Types/Internal/AST/Base.hs +169/−56
• src/Data/Morpheus/Types/Internal/AST/DirectiveLocation.hs +6/−1
• src/Data/Morpheus/Types/Internal/AST/Fields.hs +368/−0
• src/Data/Morpheus/Types/Internal/AST/MergeSet.hs +40/−26
• src/Data/Morpheus/Types/Internal/AST/OrdMap.hs +100/−0
• src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs +0/−122
• src/Data/Morpheus/Types/Internal/AST/SafeHashMap.hs +86/−0
• src/Data/Morpheus/Types/Internal/AST/Selection.hs +112/−56
• src/Data/Morpheus/Types/Internal/AST/Stage.hs +31/−0
• src/Data/Morpheus/Types/Internal/AST/TH.hs +20/−9
• src/Data/Morpheus/Types/Internal/AST/TypeCategory.hs +133/−0
• src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs +466/−513
• src/Data/Morpheus/Types/Internal/AST/Value.hs +56/−42
• src/Data/Morpheus/Types/Internal/Config.hs +40/−0
• src/Data/Morpheus/Types/Internal/Resolving.hs +57/−12
• src/Data/Morpheus/Types/Internal/Resolving/Core.hs +14/−64
• src/Data/Morpheus/Types/Internal/Resolving/Event.hs +32/−0
• src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +175/−295
• src/Data/Morpheus/Types/Internal/Resolving/ResolverState.hs +202/−0
• src/Data/Morpheus/Types/Internal/Validation.hs +110/−201
• src/Data/Morpheus/Types/Internal/Validation/Error.hs +90/−144
• src/Data/Morpheus/Types/Internal/Validation/Internal.hs +184/−0
• src/Data/Morpheus/Types/Internal/Validation/SchemaValidator.hs +20/−45
• src/Data/Morpheus/Types/Internal/Validation/Validator.hs +256/−153
• src/Data/Morpheus/Types/SelectionTree.hs +26/−6
• src/Data/Morpheus/Validation/Document/Validation.hs +257/−100
• src/Data/Morpheus/Validation/Internal/Arguments.hs +179/−0
• src/Data/Morpheus/Validation/Internal/Directive.hs +75/−31
• src/Data/Morpheus/Validation/Internal/Value.hs +204/−223
• src/Data/Morpheus/Validation/Query/Arguments.hs +0/−147
• src/Data/Morpheus/Validation/Query/Fragment.hs +83/−102
• src/Data/Morpheus/Validation/Query/FragmentPreconditions.hs +108/−0
• src/Data/Morpheus/Validation/Query/Selection.hs +147/−115
• src/Data/Morpheus/Validation/Query/UnionSelection.hs +114/−60
• src/Data/Morpheus/Validation/Query/Validation.hs +57/−17
• src/Data/Morpheus/Validation/Query/Variable.hs +38/−17
• test/Lib.hs +100/−18
• test/Schema.hs +0/−93
• test/Spec.hs +25/−136
• test/Utils/Api.hs +77/−0
• test/Utils/Schema.hs +106/−0
• test/api/deity/interface/query.gql +79/−0
• test/api/deity/interface/response.json +67/−0
• test/api/deity/resolvers.json +8/−0
• test/api/deity/schema.gql +20/−0
• test/api/deity/simple/query.gql +6/−0
• test/api/deity/simple/response.json +8/−0
• test/api/interface/query.gql +0/−79
• test/api/interface/response.json +0/−65
• test/api/simple/query.gql +0/−6
• test/api/simple/response.json +0/−6
• test/api/validation/fragment/fail-unknown-field-on-interface/query.gql +16/−0
• test/api/validation/fragment/fail-unknown-field-on-interface/response.json +12/−0
• test/api/validation/fragment/on-interface-fail-without-casting/query.gql +7/−0
• test/api/validation/fragment/on-interface-fail-without-casting/response.json +22/−0
• test/api/validation/fragment/on-interface-inline/query.gql +12/−0
• test/api/validation/fragment/on-interface-inline/response.json +10/−0
• test/api/validation/fragment/on-interface-type-casting-inline/query.gql +13/−0
• test/api/validation/fragment/on-interface-type-casting-inline/response.json +17/−0
• test/api/validation/fragment/on-interface-type-casting/query.gql +19/−0
• test/api/validation/fragment/on-interface-type-casting/response.json +17/−0
• test/api/validation/fragment/on-interface/query.gql +16/−0
• test/api/validation/fragment/on-interface/response.json +10/−0
• test/api/validation/fragment/on-type/query.gql +9/−0
• test/api/validation/fragment/on-type/response.json +7/−0
• test/api/validation/fragment/on-union-type/query.gql +9/−0
• test/api/validation/fragment/on-union-type/response.json +5/−0
• test/api/validation/fragment/resolvers.json +29/−0
• test/api/validation/fragment/schema.gql +25/−0
• test/schema/parsing/directive/ok/simple/response.json +1/−0
• test/schema/parsing/directive/ok/simple/schema.gql +5/−0
• test/schema/parsing/directive/ok/sophisticated/response.json +1/−0
• test/schema/parsing/directive/ok/sophisticated/schema.gql +17/−0
• test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/response.json +20/−0
• test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/schema.gql +21/−0
• test/schema/parsing/schema-definition/fail/dupplicate-field/query/response.json +12/−0
• test/schema/parsing/schema-definition/fail/dupplicate-field/query/schema.gql +9/−0
• test/schema/parsing/schema-definition/fail/dupplicate-schema-definition/response.json +6/−0
• test/schema/parsing/schema-definition/fail/dupplicate-schema-definition/schema.gql +29/−0
• test/schema/parsing/schema-definition/fail/unknown-fields/bla/response.json +8/−0
• test/schema/parsing/schema-definition/fail/unknown-fields/bla/schema.gql +9/−0
• test/schema/parsing/schema-definition/fail/unknown-fields/uppercase/response.json +8/−0
• test/schema/parsing/schema-definition/fail/unknown-fields/uppercase/schema.gql +7/−0
• test/schema/parsing/schema-definition/ok/query-mutation-subscription/response.json +1/−0
• test/schema/parsing/schema-definition/ok/query-mutation-subscription/schema.gql +17/−0
• test/schema/parsing/schema-definition/ok/query-mutation/response.json +1/−0
• test/schema/parsing/schema-definition/ok/query-mutation/schema.gql +12/−0
• test/schema/parsing/schema-definition/ok/query/response.json +1/−0
• test/schema/parsing/schema-definition/ok/query/schema.gql +12/−0
• test/schema/validation/default-value/argument/missing-field/response.json +2/−2
• test/schema/validation/default-value/argument/unexpected-value/response.json +7/−7
• test/schema/validation/default-value/argument/unknown-field/response.json +2/−2
• test/schema/validation/default-value/field/missing-field/response.json +2/−2
• test/schema/validation/default-value/field/unexpected-value/response.json +16/−8
• test/schema/validation/default-value/field/unknown-field/response.json +3/−3
• test/schema/validation/directive/fail/at-invalid-place/response.json +36/−0
• test/schema/validation/directive/fail/at-invalid-place/schema.gql +23/−0
• test/schema/validation/directive/fail/missing-argument/response.json +48/−0
• test/schema/validation/directive/fail/missing-argument/schema.gql +25/−0
• test/schema/validation/directive/fail/sopthisticated/response.json +64/−0
• test/schema/validation/directive/fail/sopthisticated/schema.gql +19/−0
• test/schema/validation/directive/fail/unexpected-value/response.json +36/−0
• test/schema/validation/directive/fail/unexpected-value/schema.gql +26/−0
• test/schema/validation/directive/fail/unknown-directive/response.json +56/−0
• test/schema/validation/directive/fail/unknown-directive/schema.gql +24/−0
• test/schema/validation/directive/ok/deprecated/custom-directive/response.json +1/−0
• test/schema/validation/directive/ok/deprecated/custom-directive/schema.gql +25/−0
• test/schema/validation/directive/ok/deprecated/response.json +1/−0
• test/schema/validation/directive/ok/deprecated/schema.gql +15/−0
• test/schema/validation/schema-definition/fail/non-object-kind/from-schema/response.json +16/−0
• test/schema/validation/schema-definition/fail/non-object-kind/from-schema/schema.gql +19/−0
• test/schema/validation/schema-definition/fail/non-object-kind/without-schema/response.json +16/−0
• test/schema/validation/schema-definition/fail/non-object-kind/without-schema/schema.gql +13/−0
• test/schema/validation/schema-definition/fail/required query/empty/response.json +8/−0
• test/schema/validation/schema-definition/fail/required query/empty/schema.gql +5/−0
• test/schema/validation/schema-definition/fail/required query/no-query/response.json +8/−0
• test/schema/validation/schema-definition/fail/required query/no-query/schema.gql +7/−0
• test/schema/validation/schema-definition/fail/required query/no-schema-no-query/response.json +8/−0
• test/schema/validation/schema-definition/fail/required query/no-schema-no-query/schema.gql +3/−0
• test/schema/validation/schema-definition/fail/required query/schema-with-query/response.json +8/−0
• test/schema/validation/schema-definition/fail/required query/schema-with-query/schema.gql +11/−0
• test/schema/validation/schema-definition/fail/unknown-type/unknown/response.json +16/−0
• test/schema/validation/schema-definition/fail/unknown-type/unknown/schema.gql +9/−0
• test/schema/validation/schema-definition/ok/full/response.json +1/−0
• test/schema/validation/schema-definition/ok/full/schema.gql +17/−0

@@ -9,10 +9,9 @@ ## Build GraphQL api with Core  ```hs-getSchema :: Monad m => ResponseStream e m Schema-getSchema =-  fromList-    [dsl|+schema :: Schema VALID+schema =+  [dsl|   type Query {     deity(name: String): Deity!   }@@ -45,7 +44,5 @@       ]  api :: GQLRequest -> ResponseStream e Identity (Value VALID)-api request = do-  schema <- getSchema-  runApi schema resolver request+api = runApi schema resolver ```

@@ -1,6 +1,85 @@ # Changelog -## 0.13.0 - Unreleased Changes+## 0.14.0 - 15.08.2020++### new features++- query validation supports interfaces+- exposed: `Data.Morpheus.Types.SelectionTree`+- configurable api: `Data.Morpheus.Core` exports++  - `Config`+  - `defaultConfig`+  - `debugConfig`++- for better debuging, internal errors messages will display resolving state:+  - `current TypeName`+  - `current Selection`+  - `OperationDefinition`+  - `SchemaDefinition`+- rendering graphql "AST". e.g `render ( slection :: Selection VALID)` will render++```graphql+{+  user(arg1: 1) {+    name+  }+}+```++- quasiqouter `[dsl| <type definitions> |]` generates `Schema VALID`.+- parser supports custom directive definition. e.g++```graphql+directive @MyDirective on FIELD_DEFINITION | OBJECT+```++- directive Validation for Document (TypeSystem).+- supports of block string values. e.g:++  ```graphql+  query {+    createDeity(+      name: """+      powerqwe+      bla \n sd+      blu \\ dete+      """+    ) {+      name+    }+  }+  ```++- support of `schema`. issue #412++  ```graphql+  schema {+    query: MyQuery+  }+  ```++### Breaking Changes++- `Context' renamed to`ResolverContext'+- removed : `EventCon` from `Data.Morpheus.Core`+- internal refactoring: changed AST.+  Schema AST Types now need parameter `stage = RAW | CONST | VALID`.+  - `Schema VALID`+  - `TypeDefinition VALID`+  - `FieldDefinition IN VALID`+  - ...+- runApi requires argument config+  ```hs+    runApi ::+      Schema s ->+      RootResModel event m ->+      Config ->+      GQLRequest ->+      ResponseStream event m (Value VALID)+  ```++## 0.13.0 - 22.06.2020  ### new features 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: b13e1668b9269ab28dfdd66f04b342a5bdbec82e6ba59c98c0467604df7270a6+-- hash: b767cd6b24899f096032a5231c2edb2e7fb1e5d3c29e1a8b775ecbb1ca730ebd  name:           morpheus-graphql-core-version:        0.13.0+version:        0.14.0 synopsis:       Morpheus GraphQL Core description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -23,8 +23,28 @@     changelog.md     README.md data-files:-    test/api/interface/query.gql-    test/api/simple/query.gql+    test/api/deity/interface/query.gql+    test/api/deity/schema.gql+    test/api/deity/simple/query.gql+    test/api/validation/fragment/fail-unknown-field-on-interface/query.gql+    test/api/validation/fragment/on-interface-fail-without-casting/query.gql+    test/api/validation/fragment/on-interface-inline/query.gql+    test/api/validation/fragment/on-interface-type-casting-inline/query.gql+    test/api/validation/fragment/on-interface-type-casting/query.gql+    test/api/validation/fragment/on-interface/query.gql+    test/api/validation/fragment/on-type/query.gql+    test/api/validation/fragment/on-union-type/query.gql+    test/api/validation/fragment/schema.gql+    test/schema/parsing/directive/ok/simple/schema.gql+    test/schema/parsing/directive/ok/sophisticated/schema.gql+    test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/schema.gql+    test/schema/parsing/schema-definition/fail/dupplicate-field/query/schema.gql+    test/schema/parsing/schema-definition/fail/dupplicate-schema-definition/schema.gql+    test/schema/parsing/schema-definition/fail/unknown-fields/bla/schema.gql+    test/schema/parsing/schema-definition/fail/unknown-fields/uppercase/schema.gql+    test/schema/parsing/schema-definition/ok/query-mutation-subscription/schema.gql+    test/schema/parsing/schema-definition/ok/query-mutation/schema.gql+    test/schema/parsing/schema-definition/ok/query/schema.gql     test/schema/validation/default-value/argument/compound-ok/schema.gql     test/schema/validation/default-value/argument/missing-field/schema.gql     test/schema/validation/default-value/argument/unexpected-value/schema.gql@@ -33,12 +53,47 @@     test/schema/validation/default-value/field/missing-field/schema.gql     test/schema/validation/default-value/field/unexpected-value/schema.gql     test/schema/validation/default-value/field/unknown-field/schema.gql+    test/schema/validation/directive/fail/at-invalid-place/schema.gql+    test/schema/validation/directive/fail/missing-argument/schema.gql+    test/schema/validation/directive/fail/sopthisticated/schema.gql+    test/schema/validation/directive/fail/unexpected-value/schema.gql+    test/schema/validation/directive/fail/unknown-directive/schema.gql+    test/schema/validation/directive/ok/deprecated/custom-directive/schema.gql+    test/schema/validation/directive/ok/deprecated/schema.gql     test/schema/validation/interface/field-args/fail/schema.gql     test/schema/validation/interface/field-args/ok/schema.gql     test/schema/validation/interface/field-type/fail/schema.gql     test/schema/validation/interface/field-type/ok/schema.gql-    test/api/interface/response.json-    test/api/simple/response.json+    test/schema/validation/schema-definition/fail/non-object-kind/from-schema/schema.gql+    test/schema/validation/schema-definition/fail/non-object-kind/without-schema/schema.gql+    "test/schema/validation/schema-definition/fail/required query/empty/schema.gql"+    "test/schema/validation/schema-definition/fail/required query/no-query/schema.gql"+    "test/schema/validation/schema-definition/fail/required query/no-schema-no-query/schema.gql"+    "test/schema/validation/schema-definition/fail/required query/schema-with-query/schema.gql"+    test/schema/validation/schema-definition/fail/unknown-type/unknown/schema.gql+    test/schema/validation/schema-definition/ok/full/schema.gql+    test/api/deity/interface/response.json+    test/api/deity/resolvers.json+    test/api/deity/simple/response.json+    test/api/validation/fragment/fail-unknown-field-on-interface/response.json+    test/api/validation/fragment/on-interface-fail-without-casting/response.json+    test/api/validation/fragment/on-interface-inline/response.json+    test/api/validation/fragment/on-interface-type-casting-inline/response.json+    test/api/validation/fragment/on-interface-type-casting/response.json+    test/api/validation/fragment/on-interface/response.json+    test/api/validation/fragment/on-type/response.json+    test/api/validation/fragment/on-union-type/response.json+    test/api/validation/fragment/resolvers.json+    test/schema/parsing/directive/ok/simple/response.json+    test/schema/parsing/directive/ok/sophisticated/response.json+    test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/response.json+    test/schema/parsing/schema-definition/fail/dupplicate-field/query/response.json+    test/schema/parsing/schema-definition/fail/dupplicate-schema-definition/response.json+    test/schema/parsing/schema-definition/fail/unknown-fields/bla/response.json+    test/schema/parsing/schema-definition/fail/unknown-fields/uppercase/response.json+    test/schema/parsing/schema-definition/ok/query-mutation-subscription/response.json+    test/schema/parsing/schema-definition/ok/query-mutation/response.json+    test/schema/parsing/schema-definition/ok/query/response.json     test/schema/validation/default-value/argument/compound-ok/response.json     test/schema/validation/default-value/argument/missing-field/response.json     test/schema/validation/default-value/argument/unexpected-value/response.json@@ -47,10 +102,25 @@     test/schema/validation/default-value/field/missing-field/response.json     test/schema/validation/default-value/field/unexpected-value/response.json     test/schema/validation/default-value/field/unknown-field/response.json+    test/schema/validation/directive/fail/at-invalid-place/response.json+    test/schema/validation/directive/fail/missing-argument/response.json+    test/schema/validation/directive/fail/sopthisticated/response.json+    test/schema/validation/directive/fail/unexpected-value/response.json+    test/schema/validation/directive/fail/unknown-directive/response.json+    test/schema/validation/directive/ok/deprecated/custom-directive/response.json+    test/schema/validation/directive/ok/deprecated/response.json     test/schema/validation/interface/field-args/fail/response.json     test/schema/validation/interface/field-args/ok/response.json     test/schema/validation/interface/field-type/fail/response.json     test/schema/validation/interface/field-type/ok/response.json+    test/schema/validation/schema-definition/fail/non-object-kind/from-schema/response.json+    test/schema/validation/schema-definition/fail/non-object-kind/without-schema/response.json+    "test/schema/validation/schema-definition/fail/required query/empty/response.json"+    "test/schema/validation/schema-definition/fail/required query/no-query/response.json"+    "test/schema/validation/schema-definition/fail/required query/no-schema-no-query/response.json"+    "test/schema/validation/schema-definition/fail/required query/schema-with-query/response.json"+    test/schema/validation/schema-definition/fail/unknown-type/unknown/response.json+    test/schema/validation/schema-definition/ok/full/response.json  source-repository head   type: git@@ -68,11 +138,11 @@       Data.Morpheus.Types.Internal.Resolving       Data.Morpheus.Types.GQLScalar       Data.Morpheus.Types.ID+      Data.Morpheus.Types.SelectionTree   other-modules:       Data.Morpheus.Error.Document.Interface       Data.Morpheus.Error.Fragment       Data.Morpheus.Error.Input-      Data.Morpheus.Error.Internal       Data.Morpheus.Error.NameCollision       Data.Morpheus.Error.Operation       Data.Morpheus.Error.Schema@@ -80,6 +150,7 @@       Data.Morpheus.Error.Utils       Data.Morpheus.Error.Variable       Data.Morpheus.Error.Warning+      Data.Morpheus.Internal.Graph       Data.Morpheus.Parser       Data.Morpheus.Parsing.Document.TypeSystem       Data.Morpheus.Parsing.Internal.Arguments@@ -87,38 +158,42 @@       Data.Morpheus.Parsing.Internal.Pattern       Data.Morpheus.Parsing.Internal.Terms       Data.Morpheus.Parsing.Internal.Value-      Data.Morpheus.Parsing.JSONSchema.Parse-      Data.Morpheus.Parsing.JSONSchema.Types       Data.Morpheus.Parsing.Request.Operation       Data.Morpheus.Parsing.Request.Parser       Data.Morpheus.Parsing.Request.Selection       Data.Morpheus.Rendering.RenderGQL       Data.Morpheus.Rendering.RenderIntrospection-      Data.Morpheus.Schema.Directives       Data.Morpheus.Schema.DSL       Data.Morpheus.Schema.Schema       Data.Morpheus.Schema.SchemaAPI-      Data.Morpheus.Schema.TypeKind       Data.Morpheus.Types.Internal.AST.Base       Data.Morpheus.Types.Internal.AST.DirectiveLocation+      Data.Morpheus.Types.Internal.AST.Fields       Data.Morpheus.Types.Internal.AST.MergeSet-      Data.Morpheus.Types.Internal.AST.OrderedMap+      Data.Morpheus.Types.Internal.AST.OrdMap+      Data.Morpheus.Types.Internal.AST.SafeHashMap       Data.Morpheus.Types.Internal.AST.Selection+      Data.Morpheus.Types.Internal.AST.Stage       Data.Morpheus.Types.Internal.AST.TH+      Data.Morpheus.Types.Internal.AST.TypeCategory       Data.Morpheus.Types.Internal.AST.TypeSystem       Data.Morpheus.Types.Internal.AST.Value+      Data.Morpheus.Types.Internal.Config       Data.Morpheus.Types.Internal.Resolving.Core+      Data.Morpheus.Types.Internal.Resolving.Event       Data.Morpheus.Types.Internal.Resolving.Resolver+      Data.Morpheus.Types.Internal.Resolving.ResolverState       Data.Morpheus.Types.Internal.Validation       Data.Morpheus.Types.Internal.Validation.Error+      Data.Morpheus.Types.Internal.Validation.Internal       Data.Morpheus.Types.Internal.Validation.SchemaValidator       Data.Morpheus.Types.Internal.Validation.Validator-      Data.Morpheus.Types.SelectionTree       Data.Morpheus.Validation.Document.Validation+      Data.Morpheus.Validation.Internal.Arguments       Data.Morpheus.Validation.Internal.Directive       Data.Morpheus.Validation.Internal.Value-      Data.Morpheus.Validation.Query.Arguments       Data.Morpheus.Validation.Query.Fragment+      Data.Morpheus.Validation.Query.FragmentPreconditions       Data.Morpheus.Validation.Query.Selection       Data.Morpheus.Validation.Query.UnionSelection       Data.Morpheus.Validation.Query.Validation@@ -148,7 +223,8 @@   main-is: Spec.hs   other-modules:       Lib-      Schema+      Utils.Api+      Utils.Schema       Paths_morpheus_graphql_core   hs-source-dirs:       test

@@ -9,11 +9,9 @@  module Data.Morpheus.Core   ( runApi,-    EventCon,     parseDSL,     parseFullGQLDocument,     parseGQLDocument,-    decodeIntrospection,     parseTypeSystemDefinition,     parseTypeDefinitions,     validateRequest,@@ -22,6 +20,10 @@     parseRequest,     RenderGQL (..),     SelectionTree (..),+    Config (..),+    VALIDATION_MODE (..),+    defaultConfig,+    debugConfig,   ) where @@ -31,7 +33,8 @@   ( ByteString,   ) import Data.Morpheus.Internal.Utils-  ( empty,+  ( (<:>),+    empty,   ) import Data.Morpheus.Parser   ( parseRequest,@@ -39,13 +42,10 @@     parseTypeDefinitions,     parseTypeSystemDefinition,   )-import Data.Morpheus.Parsing.JSONSchema.Parse-  ( decodeIntrospection,-  ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),   )-import Data.Morpheus.Schema.Schema (withSystemTypes)+import Data.Morpheus.Schema.Schema (internalSchema) import Data.Morpheus.Schema.SchemaAPI (withSystemFields) import Data.Morpheus.Types.IO   ( GQLRequest (..),@@ -58,10 +58,15 @@     VALID,     Value,   )+import Data.Morpheus.Types.Internal.Config+  ( Config (..),+    VALIDATION_MODE (..),+    debugConfig,+    defaultConfig,+  ) import Data.Morpheus.Types.Internal.Resolving-  ( Context (..),-    Eventless,-    GQLChannel (..),+  ( Eventless,+    ResolverContext (..),     ResponseStream,     ResultT (..),     RootResModel,@@ -70,7 +75,7 @@     runRootResModel,   ) import Data.Morpheus.Types.SelectionTree (SelectionTree (..))-import Data.Morpheus.Validation.Document.Validation (validateSchema)+import Data.Morpheus.Validation.Document.Validation (ValidateSchema (..)) import Data.Morpheus.Validation.Query.Validation   ( validateRequest,   )@@ -78,50 +83,54 @@   ( toStrict,   ) import Data.Text.Lazy.Encoding (decodeUtf8)-import Data.Typeable (Typeable) -type EventCon event =-  (Eq (StreamChannel event), Typeable event, GQLChannel event)- runApi ::-  forall event m.-  (Monad m) =>-  Schema ->+  forall event m s.+  (Monad m, ValidateSchema s) =>+  Schema s ->   RootResModel event m ->+  Config ->   GQLRequest ->   ResponseStream event m (Value VALID)-runApi inputSchema resModel request = do-  ctx <- validRequest-  model <- withSystemFields (schema ctx) resModel-  runRootResModel model ctx-  where-    validRequest ::-      Monad m => ResponseStream event m Context-    validRequest = cleanEvents $ ResultT $ pure $ do-      validSchema <- validateSchema inputSchema-      schema <- withSystemTypes validSchema-      operation <- parseRequestWith schema request-      pure $-        Context-          { schema,-            operation,-            currentTypeName = "Root",-            currentSelection =-              Selection-                { selectionName = "Root",-                  selectionArguments = empty,-                  selectionPosition = operationPosition operation,-                  selectionAlias = Nothing,-                  selectionContent = SelectionSet (operationSelection operation),-                  selectionDirectives = []-                }-          }+runApi inputSchema resModel config request = do+  validRequest <- validateReq inputSchema config request+  resovers <- withSystemFields (schema validRequest) resModel+  runRootResModel resovers validRequest -parseDSL :: ByteString -> Either String Schema+validateReq ::+  ( Monad m,+    ValidateSchema s+  ) =>+  Schema s ->+  Config ->+  GQLRequest ->+  ResponseStream event m ResolverContext+validateReq inputSchema config request = cleanEvents $ ResultT $ pure $ do+  validSchema <- validateSchema True config inputSchema+  schema <- internalSchema <:> validSchema+  operation <- parseRequestWith config schema request+  pure $+    ResolverContext+      { schema,+        config,+        operation,+        currentTypeName = "Root",+        currentSelection =+          Selection+            { selectionName = "Root",+              selectionArguments = empty,+              selectionPosition = operationPosition operation,+              selectionAlias = Nothing,+              selectionContent = SelectionSet (operationSelection operation),+              selectionDirectives = []+            }+      }++parseDSL :: ByteString -> Either String (Schema VALID) parseDSL = resultOr (Left . show) pure . parseGQLDocument -parseGQLDocument :: ByteString -> Eventless Schema+parseGQLDocument :: ByteString -> Eventless (Schema VALID) parseGQLDocument = parseTypeSystemDefinition . LT.toStrict . decodeUtf8 -parseFullGQLDocument :: ByteString -> Eventless Schema-parseFullGQLDocument = parseGQLDocument >=> withSystemTypes+parseFullGQLDocument :: ByteString -> Eventless (Schema VALID)+parseFullGQLDocument = parseGQLDocument >=> (internalSchema <:>)

@@ -1,15 +1,12 @@ module Data.Morpheus.Error   ( errorMessage,     globalErrorMessage,-    internalError,-    internalTypeMismatch,     gqlWarnings,     renderGQLErrors,     deprecatedField,   ) where -import Data.Morpheus.Error.Internal import Data.Morpheus.Error.Utils import Data.Morpheus.Error.Warning   ( deprecatedField,

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Document.Interface   ( unknownInterface,@@ -10,14 +11,13 @@   ) where -import Data.Morpheus.Error.Utils (globalErrorMessage)+import Data.Maybe (Maybe (..)) import Data.Morpheus.Types.Internal.AST.Base   ( FieldName (..),-    GQLError (..),-    GQLErrors,     TypeName (..),     TypeRef,-    msg,+    ValidationError,+    msgValidation,   ) import Data.Morpheus.Types.Internal.Validation.SchemaValidator   ( Field (..),@@ -26,10 +26,8 @@   ) import Data.Semigroup ((<>)) -unknownInterface :: TypeName -> GQLErrors-unknownInterface name = globalErrorMessage message-  where-    message = "Unknown Interface " <> msg name <> "."+unknownInterface :: TypeName -> ValidationError+unknownInterface name = "Unknown Interface " <> msgValidation name <> "."  data ImplementsError   = UnexpectedType@@ -45,31 +43,25 @@   }  class PartialImplements ctx where-  partialImplements :: ctx -> ImplementsError -> GQLErrors+  partialImplements :: ctx -> ImplementsError -> ValidationError  instance PartialImplements (Interface, FieldName) where   partialImplements (Interface interfaceName typename, fieldname) errorType =-    [ GQLError-        { message = message,-          locations = []-        }-    ]+    "Interface field "+      <> renderField interfaceName fieldname Nothing+      <> detailedMessage errorType     where-      message =-        "Interface field "-          <> renderField interfaceName fieldname Nothing-          <> detailedMessage errorType       detailedMessage UnexpectedType {expectedType, foundType} =         " expects type "-          <> msg expectedType+          <> msgValidation expectedType           <> " but "           <> renderField typename fieldname Nothing           <> " is type "-          <> msg foundType+          <> msgValidation foundType           <> "."       detailedMessage Missing =         " expected but "-          <> msg typename+          <> msgValidation typename           <> " does not provide it."  -- Interface field TestInterface.name expected but User does not provide it.@@ -77,24 +69,17 @@  instance PartialImplements (Interface, Field) where   partialImplements (Interface interfaceName typename, Field fieldname argName) errorType =-    [ GQLError-        { message = message,-          locations = []-        }-    ]+    "Interface field argument "+      <> renderField interfaceName fieldname (Just argName)+      <> detailedMessage errorType     where-      ---      message =-        "Interface field argument "-          <> renderField interfaceName fieldname (Just argName)-          <> detailedMessage errorType       detailedMessage UnexpectedType {expectedType, foundType} =         " expects type"-          <> msg expectedType+          <> msgValidation expectedType           <> " but "           <> renderField typename fieldname (Just argName)           <> " is type "-          <> msg foundType+          <> msgValidation foundType           <> "."       detailedMessage Missing =         " expected but "

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Fragment   ( cannotSpreadWithinItself,@@ -7,18 +8,20 @@ where  -- MORPHEUS-import Data.Morpheus.Error.Utils (errorMessage)++import Data.Maybe (Maybe (..))+import Data.Morpheus.Error.Utils (validationErrorMessage) import Data.Morpheus.Types.Internal.AST.Base   ( FieldName,-    GQLError (..),-    GQLErrors,     Position,     Ref (..),     TypeName,+    ValidationError (..),     msg,     msgSepBy,   ) import Data.Semigroup ((<>))+import Prelude (($), fmap, head)  {-   FRAGMENT:@@ -32,21 +35,21 @@     {...H} -> "Unknown fragment \"H\"." -} -cannotSpreadWithinItself :: [Ref] -> GQLErrors-cannotSpreadWithinItself fragments = [GQLError {message = text, locations = map refPosition fragments}]+cannotSpreadWithinItself :: [Ref] -> ValidationError+cannotSpreadWithinItself fragments = ValidationError text (fmap refPosition fragments)   where     text =       "Cannot spread fragment "         <> msg (refName $ head fragments)         <> " within itself via "-        <> msgSepBy ", " (map refName fragments)+        <> msgSepBy ", " (fmap refName fragments)         <> "."  -- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."-cannotBeSpreadOnType :: Maybe FieldName -> TypeName -> Position -> [TypeName] -> GQLErrors+cannotBeSpreadOnType :: Maybe FieldName -> TypeName -> Position -> [TypeName] -> ValidationError cannotBeSpreadOnType key fragmentType position typeMembers =-  errorMessage-    position+  validationErrorMessage+    (Just position)     text   where     text =

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Input   ( typeViolation,@@ -6,19 +7,19 @@ where  import Data.Morpheus.Types.Internal.AST-  ( Message,-    ResolvedValue,-    TypeRef (..),-    msg,+  ( TypeRef (..),+    ValidationError,+    Value,+    msgValidation,   ) import Data.Semigroup ((<>)) -typeViolation :: TypeRef -> ResolvedValue -> Message+typeViolation :: TypeRef -> Value s -> ValidationError typeViolation expected found =   "Expected type "-    <> msg expected+    <> msgValidation expected     <> " found "-    <> msg found+    <> msgValidation found     <> "."  {-

@@ -1,37 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Internal-  ( internalTypeMismatch,-    internalError,-    internalResolvingError,-  )-where---- MORPHEUS-import Data.Morpheus.Error.Utils (globalErrorMessage)-import Data.Morpheus.Types.Internal.AST.Base-  ( GQLErrors,-    Message,-    msg,-  )-import Data.Morpheus.Types.Internal.AST.Value-  ( ValidValue,-  )-import Data.Morpheus.Types.Internal.Resolving.Core-  ( Eventless,-    Failure (..),-  )-import Data.Semigroup ((<>))---- GQL:: if no mutation defined -> "Schema is not configured for mutations."--- all kind internal error in development-internalError :: Message -> Eventless a-internalError x = failure $ globalErrorMessage $ "INTERNAL ERROR: " <> x--internalResolvingError :: Message -> GQLErrors-internalResolvingError = globalErrorMessage . ("INTERNAL ERROR:" <>)---- if value is already validated but value has different type-internalTypeMismatch :: Message -> ValidValue -> Eventless a-internalTypeMismatch text jsType =-  internalError $ "Type mismatch " <> text <> msg jsType

@@ -1,12 +1,13 @@+{-# LANGUAGE NoImplicitPrelude #-}+ module Data.Morpheus.Error.NameCollision   ( NameCollision (..),   ) where -import Data.Morpheus.Internal.Utils (KeyOf (..)) import Data.Morpheus.Types.Internal.AST.Base-  ( GQLError (..),+  ( ValidationError,   )  class NameCollision a where-  nameCollision :: KEY a -> a -> GQLError+  nameCollision :: a -> ValidationError

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Operation   ( mutationIsNotDefined,@@ -6,16 +7,19 @@   ) where -import Data.Morpheus.Error.Utils (errorMessage) import Data.Morpheus.Types.Internal.AST.Base-  ( GQLErrors,-    Position,+  ( Position,+    ValidationError (..),   ) -mutationIsNotDefined :: Position -> GQLErrors+mutationIsNotDefined :: Position -> ValidationError mutationIsNotDefined position =-  errorMessage position "Schema is not configured for mutations."+  ValidationError+    "Schema is not configured for mutations."+    [position] -subscriptionIsNotDefined :: Position -> GQLErrors+subscriptionIsNotDefined :: Position -> ValidationError subscriptionIsNotDefined position =-  errorMessage position "Schema is not configured for subscriptions."+  ValidationError+    "Schema is not configured for subscriptions."+    [position]

@@ -1,27 +1,25 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Schema   ( nameCollisionError,-    schemaValidationError,   ) where -import Data.Morpheus.Error.Utils (globalErrorMessage) import Data.Morpheus.Types.Internal.AST.Base-  ( GQLErrors,-    Message,-    TypeName,-    msg,+  ( TypeName,+    ValidationError,+    msgValidation,   ) import Data.Semigroup ((<>))+import Prelude (($)) -schemaValidationError :: Message -> GQLErrors-schemaValidationError error' =-  globalErrorMessage $ "Schema Validation Error, " <> error'+schemaValidationError :: ValidationError -> ValidationError+schemaValidationError error = "Schema Validation Error, " <> error -nameCollisionError :: TypeName -> GQLErrors+nameCollisionError :: TypeName -> ValidationError nameCollisionError typeName =   schemaValidationError $     "Name collision: "-      <> msg typeName+      <> msgValidation typeName       <> " is used for different dataTypes in two separate modules"

@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Selection   ( unknownSelectionField,@@ -8,20 +9,21 @@   ) where -import Data.Morpheus.Error.Utils (errorMessage)-import Data.Morpheus.Types.Internal.AST.Base+import Data.Morpheus.Types.Internal.AST   ( FieldName,-    GQLErrors,     Position,     Ref (..),+    TypeDefinition (..),     TypeName,+    VALID,+    ValidationError (..),     msg,   ) import Data.Semigroup ((<>))  -- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields."-hasNoSubfields :: Ref -> TypeName -> GQLErrors-hasNoSubfields (Ref selectionName position) typeName = errorMessage position text+hasNoSubfields :: Ref -> TypeDefinition s VALID -> ValidationError+hasNoSubfields (Ref selectionName position) TypeDefinition {typeName} = ValidationError text [position]   where     text =       "Field "@@ -30,8 +32,8 @@         <> msg typeName         <> " has no subfields." -unknownSelectionField :: TypeName -> Ref -> GQLErrors-unknownSelectionField typeName Ref {refName, refPosition} = errorMessage refPosition text+unknownSelectionField :: TypeName -> Ref -> ValidationError+unknownSelectionField typeName Ref {refName, refPosition} = ValidationError text [refPosition]   where     text =       "Cannot query field " <> msg refName@@ -40,8 +42,8 @@         <> "."  -- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"?-subfieldsNotSelected :: FieldName -> TypeName -> Position -> GQLErrors-subfieldsNotSelected fieldName typeName position = errorMessage position text+subfieldsNotSelected :: FieldName -> TypeName -> Position -> ValidationError+subfieldsNotSelected fieldName typeName position = ValidationError text [position]   where     text =       "Field " <> msg fieldName <> " of type "

@@ -1,10 +1,12 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Utils   ( errorMessage,     globalErrorMessage,     badRequestError,+    validationErrorMessage,   ) where @@ -12,13 +14,19 @@   ( ByteString,     pack,   )+import Data.Maybe (Maybe, maybeToList) import Data.Morpheus.Types.Internal.AST.Base   ( GQLError (..),     GQLErrors,     Message,     Position (..),+    ValidationError (..),   ) import Data.Semigroup ((<>))+import Prelude ((.), String)++validationErrorMessage :: Maybe Position -> Message -> ValidationError+validationErrorMessage pos message = ValidationError message (maybeToList pos)  errorMessage :: Position -> Message -> GQLErrors errorMessage position message = [GQLError {message, locations = [position]}]

@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Variable   ( uninitializedVariable,@@ -7,23 +8,24 @@   ) where -import Data.Morpheus.Error.Utils (errorMessage)+import Data.Morpheus.Error.Utils (validationErrorMessage) import Data.Morpheus.Types.Internal.AST-  ( GQLErrors,-    Ref (..),+  ( Ref (..),     TypeRef,+    ValidationError,     Variable (..),     msg,   ) import Data.Semigroup ((<>))+import Prelude (($), Maybe (..))  -- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"."-incompatibleVariableType :: Ref -> Variable s -> TypeRef -> GQLErrors+incompatibleVariableType :: Ref -> Variable s -> TypeRef -> ValidationError incompatibleVariableType   (Ref variableName argPosition)   Variable {variableType}   argumentType =-    errorMessage argPosition text+    validationErrorMessage (Just argPosition) text     where       text =         "Variable "@@ -34,10 +36,10 @@           <> msg argumentType           <> "." -uninitializedVariable :: Variable s -> GQLErrors+uninitializedVariable :: Variable s -> ValidationError uninitializedVariable Variable {variableName, variableType, variablePosition} =-  errorMessage-    variablePosition+  validationErrorMessage+    (Just variablePosition)     $ "Variable "       <> msg ("$" <> variableName)       <> " of required type "

@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Warning   ( renderGQLErrors,@@ -13,6 +14,8 @@ import Data.ByteString.Lazy.Char8 (unpack) import Data.Foldable (traverse_) -- MORPHEUS++import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Error.Utils (errorMessage) import Data.Morpheus.Types.Internal.AST.Base   ( Description,@@ -25,6 +28,12 @@ import Language.Haskell.TH   ( Q,     reportWarning,+  )+import Prelude+  ( ($),+    (.),+    String,+    pure,   )  renderGQLErrors :: GQLErrors -> String

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Internal.Graph+  ( cycleChecking,+    Node,+    Graph,+    Edges,+  )+where++import Control.Applicative (Applicative, pure)+import Data.Foldable (traverse_)+import Data.List (elem, lookup)+import Data.Maybe (Maybe (..))+-- MORPHEUS+import Data.Morpheus.Types.Internal.AST+  ( Ref (..),+  )+import Data.Semigroup ((<>))+import Prelude+  ( otherwise,+  )++type Node = Ref++type Edges = (Ref, [Ref])++type Graph = [Edges]++cycleChecking ::+  Applicative m =>+  ([Ref] -> m ()) ->+  Graph ->+  m ()+cycleChecking fail graph = traverse_ checkNode graph+  where+    checkNode (node, _) = cycleCheckingWith graph node [node] fail++cycleCheckingWith ::+  Applicative m =>+  Graph ->+  Ref ->+  [Ref] ->+  ([Ref] -> m ()) ->+  m ()+cycleCheckingWith graph parentNode history fail =+  case lookup parentNode graph of+    Just node -> traverse_ checkNode node+    Nothing -> pure ()+  where+    checkNode node+      | node `elem` history =+        fail (node : history)+      | otherwise =+        cycleCheckingWith+          graph+          node+          (history <> [node])+          fail

@@ -1,78 +1,117 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE TypeApplications #-}+-- MORPHEUS+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Internal.TH-  ( tyConArgs,+  ( _',     apply,-    applyT,-    typeT,-    instanceHeadT,-    instanceProxyFunD,-    instanceFunD,-    instanceHeadMultiT,-    destructRecord,-    typeInstanceDec,-    infoTyVars,+    applyCons,+    applyVars,     decArgs,-    nameLitP,-    nameStringE,-    nameStringL,-    nameConT,-    nameVarE,-    nameVarT,-    nameConType,-    nameConE,-    nameVarP,-    mkTypeName,-    mkFieldName,     declareTypeRef,+    destructRecord,+    funDProxy,+    funDSimple,+    infoTyVars,+    isEnum,+    m',+    m_,+    mkFieldsE,     nameSpaceField,     nameSpaceType,-    m_,-    m',-    isEnum,+    toCon,+    toConE,+    toConT,+    ToName (..),+    toString,+    toVarE,+    toVarT,+    tyConArgs,+    typeInstanceDec,+    v',+    cat',+    _2',+    o',+    e',+    vars,+    decodeObjectE,+    matchWith,   ) where --- MORPHEUS+import Control.Applicative ((<*>), pure)+import Control.Monad.Fail (fail)+import Data.Foldable (foldl, foldr1)+import Data.Functor ((<$>))+import Data.Maybe (Maybe (..)) import Data.Morpheus.Internal.Utils   ( nameSpaceField,     nameSpaceType,   ) import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    TypeKind (..),+  ( FieldDefinition (..),+    FieldName (..),     TypeKind (..),     TypeName (..),     TypeRef (..),     TypeWrapper (..),     convertToHaskellName,     isEnum,+    isNullable,     isOutputObject,     readName,   )-import Data.Morpheus.Types.Internal.Resolving-  ( UnSubResolver,-  )+import Data.Semigroup ((<>)) import Data.Text (unpack) import Language.Haskell.TH--m' :: Type-m' = VarT $ mkTypeName m_+import Prelude+  ( ($),+    (.),+    (==),+    Bool (..),+    id,+    map,+    otherwise,+    show,+    (||),+  )  m_ :: TypeName m_ = "m" -declareTypeRef :: Bool -> TypeRef -> Type-declareTypeRef isSub TypeRef {typeConName, typeWrappers, typeArgs} =+m' :: Type+m' = VarT (mkName "m")++o' :: Type+o' = VarT (mkName "o")++e' :: Type+e' = VarT (mkName "event")++_' :: PatQ+_' = toVar (mkName "_")++_2' :: PatQ+_2' = toVar (mkName "_2")++v' :: ToVar Name a => a+v' = toVar (mkName "v")++cat' :: Type+cat' = VarT (mkName "cat")++declareTypeRef :: TypeRef -> Type+declareTypeRef TypeRef {typeConName, typeWrappers, typeArgs} =   wrappedT     typeWrappers   where@@ -80,63 +119,133 @@     wrappedT (TypeList : xs) = AppT (ConT ''[]) $ wrappedT xs     wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs     wrappedT [] = decType typeArgs-    -------------------------------------------------------    typeName = nameConType typeConName     ---------------------------------------------    decType _-      | isSub =-        AppT typeName (AppT (ConT ''UnSubResolver) m')-    decType (Just par) = AppT typeName (VarT $ mkTypeName par)-    decType _ = typeName+    decType (Just par) = apply typeConName [toVar par]+    decType _ = toCon typeConName  tyConArgs :: TypeKind -> [TypeName] tyConArgs kindD   | isOutputObject kindD || kindD == KindUnion = [m_]   | otherwise = [] -apply :: Name -> [Q Exp] -> Q Exp-apply n = foldl appE (conE n)+cons :: ToCon a b => [a] -> [b]+cons = map toCon -applyT :: Name -> [Q Type] -> Q Type-applyT name = foldl appT (conT name)+vars :: ToVar a b => [a] -> [b]+vars = map toVar -typeT :: Name -> [TypeName] -> Q Type-typeT name li = applyT name (map (varT . mkTypeName) li)+class ToName a where+  toName :: a -> Name -instanceHeadT :: Name -> TypeName -> [TypeName] -> Q Type-instanceHeadT cName iType tArgs = applyT cName [applyT (mkTypeName iType) (map (varT . mkTypeName) tArgs)]+instance ToName Name where+  toName = id -instanceProxyFunD :: (Name, ExpQ) -> DecQ-instanceProxyFunD (name, body) = instanceFunD name ["_"] body+instance ToName TypeName where+  toName = mkName . unpack . readTypeName -instanceFunD :: Name -> [TypeName] -> ExpQ -> Q Dec-instanceFunD name args body = funD name [clause (map (varP . mkTypeName) args) (normalB body) []]+instance ToName FieldName where+  toName = mkName . unpack . readName . convertToHaskellName -instanceHeadMultiT :: Name -> Q Type -> [Q Type] -> Q Type-instanceHeadMultiT className iType li = applyT className (iType : li)+class ToString a b where+  toString :: a -> b --- "User" -> ["name","id"] -> (User name id)-destructRecord :: TypeName -> [FieldName] -> PatQ-destructRecord conName fields = conP (mkTypeName conName) (map (varP . mkFieldName) fields)+instance ToString a b => ToString a (Q b) where+  toString = pure . toString -typeInstanceDec :: Name -> Type -> Type -> Dec+instance ToString TypeName Lit where+  toString = stringL . unpack . readTypeName -nameLitP :: TypeName -> PatQ-nameLitP = litP . nameStringL+instance ToString TypeName Pat where+  toString = LitP . toString -nameStringL :: TypeName -> Lit-nameStringL = stringL . unpack . readTypeName+instance ToString FieldName Lit where+  toString (FieldName x) = stringL (unpack x) -nameStringE :: TypeName -> ExpQ-nameStringE = stringE . (unpack . readTypeName)+instance ToString TypeName Exp where+  toString = LitE . toString -#if MIN_VERSION_template_haskell(2,15,0)--- fix breaking changes-typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res)-#else+instance ToString FieldName Exp where+  toString = LitE . toString++class ToCon a b where+  toCon :: a -> b++instance ToCon a b => ToCon a (Q b) where+  toCon = pure . toCon++instance (ToName a) => ToCon a Type where+  toCon = ConT . toName++instance (ToName a) => ToCon a Exp where+  toCon = ConE . toName++class ToVar a b where+  toVar :: a -> b++instance ToVar a b => ToVar a (Q b) where+  toVar = pure . toVar++instance (ToName a) => ToVar a Type where+  toVar = VarT . toName++instance (ToName a) => ToVar a Exp where+  toVar = VarE . toName++instance (ToName a) => ToVar a Pat where+  toVar = VarP . toName++class Apply a where+  apply :: ToCon i a => i -> [a] -> a++instance Apply TypeQ where+  apply = foldl appT . toCon++instance Apply Type where+  apply = foldl AppT . toCon++instance Apply Exp where+  apply = foldl AppE . toCon++instance Apply ExpQ where+  apply = foldl appE . toCon++applyVars ::+  ( ToName con,+    ToName var,+    Apply res,+    ToCon con res,+    ToVar var res+  ) =>+  con ->+  [var] ->+  res+applyVars name li = apply name (vars li)++applyCons :: (ToName con, ToName cons) => con -> [cons] -> Q Type+applyCons name li = apply name (cons li)++funDProxy :: [(Name, ExpQ)] -> [DecQ]+funDProxy = map fun+  where+    fun (name, body) = funDSimple name [_'] body++funDSimple :: Name -> [PatQ] -> ExpQ -> DecQ+funDSimple name args body = funD name [clause args (normalB body) []]++-- |+-- input:+-- >>>+-- destructRecord "User" ["name","id"]+-- >>> ---typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res)-#endif+-- expression:+-- >>>+-- (User name id)+-- >>>+destructRecord :: TypeName -> [FieldDefinition cat s] -> PatQ+destructRecord conName fields = conP (toName conName) (vars names)+  where+    names = map fieldName fields  infoTyVars :: Info -> [TyVarBndr] infoTyVars (TyConI x) = decArgs x@@ -148,26 +257,92 @@ decArgs (TySynD _ args _) = args decArgs _ = [] -mkTypeName :: TypeName -> Name-mkTypeName = mkName . unpack . readTypeName+toConT :: ToName a => a -> Q Type+toConT = conT . toName -mkFieldName :: FieldName -> Name-mkFieldName = mkName . unpack . readName . convertToHaskellName+toVarT :: ToVar a TypeQ => a -> TypeQ+toVarT = toVar -nameConT :: TypeName -> Q Type-nameConT = conT . mkTypeName+toVarE :: ToVar a Exp => a -> ExpQ+toVarE = toVar -nameConType :: TypeName -> Type-nameConType = ConT . mkTypeName+toConE :: ToCon a Exp => a -> ExpQ+toConE = toCon -nameVarT :: TypeName -> Q Type-nameVarT = varT . mkTypeName+-- | 'mkFieldsE'+--+--  input :+--  >>>+--       mkFieldsE 'mkValue [FieldDefinition { fieldName = \"field1" ,..} ,..]+--  >>>+--+--  expression :+--  >>>+--    [ mkValue \"field1\" field1,+--    ..+--    ]+-- >>>+mkFieldsE :: Name -> [FieldDefinition cat s] -> Exp+mkFieldsE name = ListE . map (mkEntryWith name) -nameVarE :: FieldName -> ExpQ-nameVarE = varE . mkFieldName+--  input : mkFieldWith 'mkValue (FieldDefinition { fieldName = "field1", ..})+--  expression: mkValue "field1"  field1+mkEntryWith ::+  Name ->+  FieldDefinition cat s ->+  Exp+mkEntryWith f FieldDefinition {fieldName} =+  AppE+    (AppE (VarE f) (toString fieldName))+    (toVar fieldName) -nameConE :: TypeName -> ExpQ-nameConE = conE . mkTypeName+decodeObjectE :: (Bool -> Name) -> TypeName -> [FieldDefinition cat s] -> ExpQ+decodeObjectE _ conName [] = appE (varE 'pure) (toCon conName)+decodeObjectE funName conName fields =+  uInfixE+    (toCon conName)+    (varE '(<$>))+    (foldr1 withApplicative $ map (defField funName) fields) -nameVarP :: FieldName -> PatQ-nameVarP = varP . mkFieldName+withApplicative :: ExpQ -> ExpQ -> ExpQ+withApplicative x = uInfixE x (varE '(<*>))++matchWith ::+  Bool ->+  (t -> (PatQ, ExpQ)) ->+  [t] ->+  ExpQ+matchWith isClosed f xs = lamCaseE (map buildMatch xs <> fallback)+  where+    fallback+      | isClosed = []+      | otherwise = [elseCaseEXP]+    buildMatch x = match pat (normalB body) []+      where+        (pat, body) = f x++elseCaseEXP :: MatchQ+elseCaseEXP = match v' body []+  where+    body =+      normalB $+        appE+          (toVarE 'fail)+          ( uInfixE+              (appE (varE 'show) v')+              (varE '(<>))+              (stringE " is Not Valid Union Constructor")+          )++defField :: (Bool -> Name) -> FieldDefinition cat s -> ExpQ+defField f field@FieldDefinition {fieldName} = uInfixE v' (varE $ f (isNullable field)) (toString fieldName)++#if MIN_VERSION_template_haskell(2,15,0)+-- fix breaking changes+typeInstanceDec :: Name -> Type -> Type -> Dec+typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res)+#else+--+typeInstanceDec :: Name -> Type -> Type -> Dec+typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res)+#endif

@@ -2,9 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Internal.Utils   ( capital,@@ -27,17 +25,36 @@     mapFst,     mapSnd,     mapTuple,+    UpdateT (..),+    resolveUpdates,+    concatUpdates,+    failUpdates,+    ordTraverse,+    ordTraverse_,+    traverseCollection,+    (<.>),+    SemigroupM (..),   ) where +import Control.Applicative (Applicative (..))+import Control.Monad ((=<<), foldM)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader+  ( ReaderT (..),+  ) import Data.Char   ( toLower,     toUpper,   )+import Data.Foldable (null, traverse_)+import Data.Function ((&)) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HM import Data.Hashable (Hashable) import Data.List (find)+import Data.Maybe (isJust, maybe)+import Data.Morpheus.Error.NameCollision (NameCollision (..)) import Data.Morpheus.Types.Internal.AST.Base   ( FieldName,     FieldName (..),@@ -46,22 +63,42 @@     Token,     TypeName (..),     TypeNameRef (..),+    ValidationErrors,+    toGQLError,   )-import Data.Semigroup ((<>))+import Data.Semigroup (Semigroup (..)) import qualified Data.Text as T   ( concat,     pack,     unpack,   )+import Data.Traversable (traverse) import Instances.TH.Lift () import Text.Megaparsec.Internal (ParsecT (..)) import Text.Megaparsec.Stream (Stream)+import Prelude+  ( ($),+    (.),+    Bool (..),+    Either (..),+    Eq (..),+    Functor (..),+    Int,+    Monad,+    Ord,+    String,+    const,+    fst,+    length,+    otherwise,+    snd,+  )  mapText :: (String -> String) -> Token -> Token mapText f = T.pack . f . T.unpack  nameSpaceType :: [FieldName] -> TypeName -> TypeName-nameSpaceType list (TypeName name) = TypeName . T.concat $ map capital (map readName list <> [name])+nameSpaceType list (TypeName name) = TypeName . T.concat $ fmap capital (fmap readName list <> [name])  nameSpaceField :: TypeName -> FieldName -> FieldName nameSpaceField nSpace (FieldName name) = FieldName (nonCapital nSpace <> capital name)@@ -90,61 +127,111 @@   empty = []   singleton x = [x] -instance (Hashable k, KeyOf v, k ~ KEY v) => Collection v (HashMap k v) where+instance KeyOf k v => Collection v (HashMap k v) where   empty = HM.empty   singleton x = HM.singleton (keyOf x) x -class Selectable c a | c -> a where-  selectOr :: d -> (a -> d) -> KEY a -> c -> d+class Selectable k a c | c -> a where+  selectOr :: d -> (a -> d) -> k -> c -> d -instance KeyOf a => Selectable [a] a where+instance KeyOf k a => Selectable k a [a] where   selectOr fb f key lib = maybe fb f (find ((key ==) . keyOf) lib) -instance (KEY a ~ k, Eq k, Hashable k) => Selectable (HashMap k a) a where+instance KeyOf k a => Selectable k a (HashMap k a) where   selectOr fb f key lib = maybe fb f (HM.lookup key lib) -selectBy :: (Failure e m, Selectable c a, Monad m) => e -> KEY a -> c -> m a+selectBy :: (Failure e m, Selectable k a c, Monad m) => e -> k -> c -> m a selectBy err = selectOr (failure err) pure -member :: forall a c. Selectable c a => KEY a -> c -> Bool+member :: Selectable k a c => k -> c -> Bool member = selectOr False toTrue   where     toTrue :: a -> Bool     toTrue _ = True -class Eq (KEY a) => KeyOf a where-  type KEY a :: *-  type KEY a = FieldName-  keyOf :: a -> KEY a+ordTraverse ::+  ( Monad f,+    KeyOf k b,+    Listable a (t a),+    Listable b (t b),+    Failure ValidationErrors f+  ) =>+  (a -> f b) ->+  t a ->+  f (t b)+ordTraverse = traverseCollection -instance KeyOf Ref where+traverseCollection ::+  ( Monad f,+    KeyOf k b,+    Listable a (t a),+    Listable b (t' b),+    Failure ValidationErrors f+  ) =>+  (a -> f b) ->+  t a ->+  f (t' b)+traverseCollection f a = fromElems =<< traverse f (elems a)++ordTraverse_ ::+  ( Monad f,+    Listable a (t a)+  ) =>+  (a -> f b) ->+  t a ->+  f ()+ordTraverse_ f a = traverse_ f (elems a)++class (Eq k, Hashable k) => KeyOf k a | a -> k where+  keyOf :: a -> k++instance (Eq k, Hashable k) => KeyOf k (k, a) where+  keyOf = fst++instance KeyOf FieldName Ref where   keyOf = refName -instance KeyOf TypeNameRef where-  type KEY TypeNameRef = TypeName+instance KeyOf TypeName TypeNameRef where   keyOf = typeNameRef -toPair :: KeyOf a => a -> (KEY a, a)+toPair :: KeyOf k a => a -> (k, a) toPair x = (keyOf x, x)  -- list Like Collections class Listable a coll | coll -> a where   elems :: coll -> [a]-  fromElems :: (KeyOf a, Monad m, Failure GQLErrors m) => [a] -> m coll+  fromElems :: (Monad m, Failure ValidationErrors m) => [a] -> m coll -keys :: (KeyOf a, Listable a coll) => coll -> [KEY a]-keys = map keyOf . elems+instance (NameCollision a, KeyOf k a) => Listable a (HashMap k a) where+  fromElems = safeFromList+  elems = HM.elems +keys :: (KeyOf k a, Listable a coll) => coll -> [k]+keys = fmap keyOf . elems+ size :: Listable a coll => coll -> Int size = length . elems  -- Merge Object with of Failure as an Option class Merge a where-  merge :: (Monad m, Failure GQLErrors m) => [Ref] -> a -> a -> m a+  merge :: (Monad m, Failure ValidationErrors m) => [Ref] -> a -> a -> m a -(<:>) :: (Monad m, Merge a, Failure GQLErrors m) => a -> a -> m a+instance (NameCollision a, KeyOf k a) => Merge (HashMap k a) where+  merge _ = safeJoin++(<:>) :: (Monad m, Merge a, Failure ValidationErrors m) => a -> a -> m a (<:>) = merge [] +class SemigroupM m a where+  mergeM :: [Ref] -> a -> a -> m a++(<.>) ::+  (SemigroupM m a) =>+  a ->+  a ->+  m a+(<.>) = mergeM []+ -- Failure: for custome Morpheus GrapHQL errors class Applicative f => Failure error (f :: * -> *) where   failure :: error -> f v@@ -152,9 +239,12 @@ instance Failure error (Either error) where   failure = Left -instance (Stream s, Ord e, Failure [a] m) => Failure [a] (ParsecT e s m) where-  failure x = ParsecT $ \_ _ _ _ _ -> failure x+instance (Monad m, Failure errors m) => Failure errors (ReaderT ctx m) where+  failure = lift . failure +instance (Stream s, Ord e, Failure GQLErrors m) => Failure ValidationErrors (ParsecT e s m) where+  failure x = ParsecT $ \_ _ _ _ _ -> failure (fmap toGQLError x)+ mapFst :: (a -> a') -> (a, b) -> (a', b) mapFst f (a, b) = (f a, b) @@ -163,3 +253,53 @@  mapTuple :: (a -> a') -> (b -> b') -> (a, b) -> (a', b') mapTuple f1 f2 (a, b) = (f1 a, f2 b)++-- Helper Functions+newtype UpdateT m a = UpdateT {updateTState :: a -> m a}++failUpdates :: (Failure e m) => e -> UpdateT m a+failUpdates = UpdateT . const . failure++concatUpdates :: Monad m => [UpdateT m a] -> UpdateT m a+concatUpdates x = UpdateT (`resolveUpdates` x)++resolveUpdates :: Monad m => a -> [UpdateT m a] -> m a+resolveUpdates a = foldM (&) a . fmap updateTState++safeFromList ::+  ( Failure ValidationErrors m,+    Applicative m,+    NameCollision a,+    Eq k,+    Hashable k,+    KeyOf k a+  ) =>+  [a] ->+  m (HashMap k a)+safeFromList values = safeUnionWith HM.empty (fmap toPair values)++safeJoin :: (Failure ValidationErrors m, Eq k, Hashable k, Applicative m, NameCollision a) => HashMap k a -> HashMap k a -> m (HashMap k a)+safeJoin hm newls = safeUnionWith hm (HM.toList newls)++safeUnionWith ::+  ( Failure ValidationErrors m,+    Applicative m,+    Eq k,+    Hashable k,+    NameCollision a+  ) =>+  HashMap k a ->+  [(k, a)] ->+  m (HashMap k a)+safeUnionWith hm names = case insertNoDups (hm, []) names of+  (res, dupps)+    | null dupps -> pure res+    | otherwise -> failure $ fmap (nameCollision . snd) dupps++type NoDupHashMap k a = (HashMap k a, [(k, a)])++insertNoDups :: (Eq k, Hashable k) => NoDupHashMap k a -> [(k, a)] -> NoDupHashMap k a+insertNoDups collected [] = collected+insertNoDups (coll, errors) (pair@(name, value) : xs)+  | isJust (name `HM.lookup` coll) = insertNoDups (coll, errors <> [pair]) xs+  | otherwise = insertNoDups (HM.insert name value coll, errors) xs

@@ -7,28 +7,32 @@ where  import Control.Monad ((>=>))-import Data.Morpheus.Internal.Utils-  ( fromElems,+import qualified Data.Morpheus.Parsing.Document.TypeSystem as P+  ( parseSchema,+    parseTypeDefinitions,   )-import Data.Morpheus.Parsing.Document.TypeSystem (parseSchema) import Data.Morpheus.Parsing.Request.Parser (parseGQL) import Data.Morpheus.Types.IO   ( GQLRequest (..),   ) import Data.Morpheus.Types.Internal.AST   ( ANY,+    CONST,     GQLQuery (..),     Operation,     Schema (..),     TypeDefinition (..),     VALID,+  )+import Data.Morpheus.Types.Internal.Config+  ( Config (..),     VALIDATION_MODE (..),   ) import Data.Morpheus.Types.Internal.Resolving   ( Eventless,   ) import Data.Morpheus.Validation.Document.Validation-  ( validatePartialDocument,+  ( validateSchema,   ) import Data.Morpheus.Validation.Query.Validation   ( validateRequest,@@ -36,17 +40,22 @@ import Data.Text (Text)  parseTypeSystemDefinition ::-  Text -> Eventless Schema+  Text -> Eventless (Schema VALID) parseTypeSystemDefinition =-  parseSchema >=> fromElems+  P.parseSchema+    >=> validateSchema+      True+      Config+        { debug = False,+          validationMode = FULL_VALIDATION+        }  parseTypeDefinitions ::-  Text -> Eventless [TypeDefinition ANY]-parseTypeDefinitions =-  parseSchema >=> validatePartialDocument+  Text -> Eventless [TypeDefinition ANY CONST]+parseTypeDefinitions = P.parseTypeDefinitions  parseRequest :: GQLRequest -> Eventless GQLQuery parseRequest = parseGQL -parseRequestWith :: Schema -> GQLRequest -> Eventless (Operation VALID)-parseRequestWith schema = parseRequest >=> validateRequest schema FULL_VALIDATION+parseRequestWith :: Config -> Schema VALID -> GQLRequest -> Eventless (Operation VALID)+parseRequestWith config schema = parseRequest >=> validateRequest config schema

@@ -1,50 +1,77 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Document.TypeSystem   ( parseSchema,+    parseTypeDefinitions,   ) where  -- MORPHEUS++import Control.Applicative ((*>), pure)+import Control.Monad ((>=>))+import Data.Foldable (foldr)+import Data.Functor ((<$>), fmap)+import Data.Maybe (Maybe (..))+import Data.Morpheus.Error.NameCollision (NameCollision (..)) import Data.Morpheus.Parsing.Internal.Internal   ( Parser,     processParser,   ) import Data.Morpheus.Parsing.Internal.Pattern-  ( enumValueDefinition,+  ( argumentsDefinition,+    enumValueDefinition,     fieldsDefinition,     inputFieldsDefinition,     optionalDirectives,+    parseDirectiveLocation,+    parseOperationType,     typeDeclaration,   ) import Data.Morpheus.Parsing.Internal.Terms   ( collection,+    ignoredTokens,     keyword,-    operator,     optDescription,+    optionalCollection,+    parseName,     parseTypeName,-    pipeLiteral,+    pipe,     sepByAnd,-    spaceAndComments,+    setOf,+    symbol,   )+import Data.Morpheus.Parsing.Internal.Value+  ( Parse (..),+  ) import Data.Morpheus.Types.Internal.AST   ( ANY,+    CONST,     DataFingerprint (..),     Description,+    DirectiveDefinition (..),     IN,     OUT,+    RawTypeDefinition (..),+    RootOperationTypeDefinition (..),     ScalarDefinition (..),+    Schema,+    SchemaDefinition (..),     TypeContent (..),     TypeDefinition (..),     TypeName,-    UnionMember (..),+    Value,+    buildSchema,     mkUnionMember,     toAny,   ) import Data.Morpheus.Types.Internal.Resolving   ( Eventless,+    failure,   ) import Data.Text (Text) import Text.Megaparsec@@ -52,15 +79,22 @@     eof,     label,     manyTill,-    sepBy1,+    optional,   )+import Prelude+  ( ($),+    (.),+  )  -- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars -- --  ScalarTypeDefinition: --    Description(opt) scalar Name Directives(Const)(opt) ---scalarTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY)+scalarTypeDefinition ::+  Parse (Value s) =>+  Maybe Description ->+  Parser (TypeDefinition ANY s) scalarTypeDefinition typeDescription = label "ScalarTypeDefinition" $ do   typeName <- typeDeclaration "scalar"   typeDirectives <- optionalDirectives@@ -86,7 +120,10 @@ --  FieldDefinition --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) ---objectTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)+objectTypeDefinition ::+  Parse (Value s) =>+  Maybe Description ->+  Parser (TypeDefinition OUT s) objectTypeDefinition typeDescription = label "ObjectTypeDefinition" $ do   typeName <- typeDeclaration "type"   objectImplements <- optionalImplementsInterfaces@@ -111,7 +148,10 @@ --  InterfaceTypeDefinition --    Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) ---interfaceTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)+interfaceTypeDefinition ::+  Parse (Value s) =>+  Maybe Description ->+  Parser (TypeDefinition OUT s) interfaceTypeDefinition typeDescription = label "InterfaceTypeDefinition" $ do   typeName <- typeDeclaration "interface"   typeDirectives <- optionalDirectives@@ -131,7 +171,10 @@ --    = |(opt) NamedType --      UnionMemberTypes | NamedType ---unionTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)+unionTypeDefinition ::+  Parse (Value s) =>+  Maybe Description ->+  Parser (TypeDefinition OUT s) unionTypeDefinition typeDescription = label "UnionTypeDefinition" $ do   typeName <- typeDeclaration "union"   typeDirectives <- optionalDirectives@@ -142,7 +185,9 @@         ..       }   where-    unionMemberTypes = operator '=' *> (mkUnionMember <$> parseTypeName) `sepBy1` pipeLiteral+    unionMemberTypes =+      symbol '='+        *> pipe (mkUnionMember <$> parseTypeName)  -- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums --@@ -155,7 +200,10 @@ --  EnumValueDefinition --    Description(opt) EnumValue Directives(Const)(opt) ---enumTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY)+enumTypeDefinition ::+  Parse (Value s) =>+  Maybe Description ->+  Parser (TypeDefinition ANY s) enumTypeDefinition typeDescription = label "EnumTypeDefinition" $ do   typeName <- typeDeclaration "enum"   typeDirectives <- optionalDirectives@@ -174,7 +222,10 @@ --   InputFieldsDefinition: --     { InputValueDefinition(list) } ---inputObjectTypeDefinition :: Maybe Description -> Parser (TypeDefinition IN)+inputObjectTypeDefinition ::+  Parse (Value s) =>+  Maybe Description ->+  Parser (TypeDefinition IN s) inputObjectTypeDefinition typeDescription =   label "InputObjectTypeDefinition" $ do     typeName <- typeDeclaration "input"@@ -187,20 +238,145 @@           ..         } -parseDataType :: Parser (TypeDefinition ANY)-parseDataType = label "TypeDefinition" $ do-  description <- optDescription-  -- scalar | enum |  input | object | union | interface-  (toAny <$> inputObjectTypeDefinition description)-    <|> (toAny <$> unionTypeDefinition description)-    <|> enumTypeDefinition description-    <|> scalarTypeDefinition description-    <|> (toAny <$> objectTypeDefinition description)-    <|> (toAny <$> interfaceTypeDefinition description)+-- 3.13 DirectiveDefinition+--+--  DirectiveDefinition:+--     Description[opt] directive @ Name ArgumentsDefinition[opt] repeatable[opt] on DirectiveLocations+--+--  DirectiveLocations:+--    DirectiveLocations | DirectiveLocation+--    |[opt] DirectiveLocation -parseSchema :: Text -> Eventless [TypeDefinition ANY]-parseSchema = processParser request+parseDirectiveDefinition ::+  Maybe Description ->+  Parser RawTypeDefinition+parseDirectiveDefinition directiveDefinitionDescription = label "DirectiveDefinition" $ do+  keyword "directive"+  symbol '@'+  directiveDefinitionName <- parseName+  directiveDefinitionArgs <- optionalCollection argumentsDefinition+  _ <- optional (keyword "repeatable")+  keyword "on"+  directiveDefinitionLocations <- pipe parseDirectiveLocation+  pure+    $ RawDirectiveDefinition+    $ DirectiveDefinition+      { directiveDefinitionName,+        directiveDefinitionDescription,+        directiveDefinitionLocations,+        directiveDefinitionArgs+      }++-- 3.2 Schema+-- SchemaDefinition:+--    schema Directives[Const,opt]+--      { RootOperationTypeDefinitionlist }+--+--  RootOperationTypeDefinition:+--    OperationType: NamedType++-- data SchemaDefinition = SchemaDefinition+--   { query :: TypeName,+--     mutation :: Maybe TypeName,+--     subscription :: Maybe TypeName+--   }++parseSchemaDefinition :: Maybe Description -> Parser RawTypeDefinition+parseSchemaDefinition _schemaDescription = label "SchemaDefinition" $ do+  keyword "schema"+  schemaDirectives <- optionalDirectives+  unSchemaDefinition <- setOf parseRootOperationTypeDefinition+  pure+    $ RawSchemaDefinition+    $ SchemaDefinition {schemaDirectives, unSchemaDefinition}++parseRootOperationTypeDefinition :: Parser RootOperationTypeDefinition+parseRootOperationTypeDefinition = do+  operationType <- parseOperationType+  symbol ':'+  RootOperationTypeDefinition operationType <$> parseTypeName++parseTypeSystemUnit ::+  Parser RawTypeDefinition+parseTypeSystemUnit =+  label "TypeDefinition" $+    do+      description <- optDescription+      -- scalar | enum |  input | object | union | interface+      types description+        <|> parseSchemaDefinition description+        <|> parseDirectiveDefinition description   where-    request = label "DocumentTypes" $ do-      spaceAndComments-      manyTill parseDataType eof+    types description =+      RawTypeDefinition+        <$> ( (toAny <$> inputObjectTypeDefinition description)+                <|> (toAny <$> unionTypeDefinition description)+                <|> enumTypeDefinition description+                <|> scalarTypeDefinition description+                <|> (toAny <$> objectTypeDefinition description)+                <|> (toAny <$> interfaceTypeDefinition description)+            )++typePartition ::+  [RawTypeDefinition] ->+  ( [SchemaDefinition],+    [TypeDefinition ANY CONST],+    [DirectiveDefinition CONST]+  )+typePartition = foldr split ([], [], [])++split ::+  RawTypeDefinition ->+  ( [SchemaDefinition],+    [TypeDefinition ANY CONST],+    [DirectiveDefinition CONST]+  ) ->+  ( [SchemaDefinition],+    [TypeDefinition ANY CONST],+    [DirectiveDefinition CONST]+  )+split (RawSchemaDefinition schema) (schemas, types, dirs) = (schema : schemas, types, dirs)+split (RawTypeDefinition ty) (schemas, types, dirs) = (schemas, ty : types, dirs)+split (RawDirectiveDefinition dir) (schemas, types, dirs) = (schemas, types, dir : dirs)++--  split (RawDirectiveDefinition d)++withSchemaDefinition ::+  ( [SchemaDefinition],+    [TypeDefinition ANY s],+    [DirectiveDefinition CONST]+  ) ->+  Eventless+    (Maybe SchemaDefinition, [TypeDefinition ANY s], [DirectiveDefinition CONST])+withSchemaDefinition ([], t, dirs) = pure (Nothing, t, dirs)+withSchemaDefinition ([x], t, dirs) = pure (Just x, t, dirs)+withSchemaDefinition (_ : xs, _, _) = failure (fmap nameCollision xs)++parseTypeSystemDefinition :: Parser [RawTypeDefinition]+parseTypeSystemDefinition = label "TypeSystemDefinitions" $ do+  ignoredTokens+  manyTill parseTypeSystemUnit eof++typeSystemDefinition ::+  Text ->+  Eventless+    ( Maybe SchemaDefinition,+      [TypeDefinition ANY CONST],+      [DirectiveDefinition CONST]+    )+typeSystemDefinition =+  processParser parseTypeSystemDefinition+    >=> withSchemaDefinition . typePartition++parseTypeDefinitions :: Text -> Eventless [TypeDefinition ANY CONST]+parseTypeDefinitions = fmap snd3 . typeSystemDefinition++snd3 :: (a, b, c) -> b+snd3 (_, x, _) = x++parseSchema ::+  Text ->+  Eventless (Schema CONST)+parseSchema =+  typeSystemDefinition+    >=> buildSchema

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  module Data.Morpheus.Parsing.Internal.Pattern@@ -8,9 +9,13 @@     optionalDirectives,     enumValueDefinition,     inputFieldsDefinition,+    parseOperationType,+    argumentsDefinition,+    parseDirectiveLocation,   ) where +import Data.Functor (($>)) -- MORPHEUS import Data.Morpheus.Parsing.Internal.Arguments   ( maybeArguments,@@ -20,14 +25,14 @@     getLocation,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( keyword,-    litAssignment,-    operator,+  ( ignoredTokens,+    keyword,     optDescription,     parseName,     parseType,     parseTypeName,     setOf,+    symbol,     uniqTuple,   ) import Data.Morpheus.Parsing.Internal.Value@@ -38,6 +43,7 @@   ( ArgumentsDefinition (..),     DataEnumValue (..),     Directive (..),+    DirectiveLocation (..),     FieldContent (..),     FieldDefinition (..),     FieldName,@@ -45,21 +51,28 @@     IN,     InputFieldsDefinition,     OUT,+    OperationType (..),     TypeName,     Value,   )+import Data.Text (pack) import Text.Megaparsec-  ( label,+  ( (<|>),+    choice,+    label,     many,     optional,   )+import Text.Megaparsec.Char (string)  --  EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition -- --  EnumValueDefinition --    Description(opt) EnumValue Directives(Const)(opt) ---enumValueDefinition :: Parser DataEnumValue+enumValueDefinition ::+  Parse (Value s) =>+  Parser (DataEnumValue s) enumValueDefinition = label "EnumValueDefinition" $ do   enumDescription <- optDescription   enumName <- parseTypeName@@ -71,11 +84,13 @@ -- InputValueDefinition --   Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt) ---inputValueDefinition :: Parser (FieldDefinition IN)+inputValueDefinition ::+  Parse (Value s) =>+  Parser (FieldDefinition IN s) inputValueDefinition = label "InputValueDefinition" $ do   fieldDescription <- optDescription   fieldName <- parseName-  litAssignment -- ':'+  symbol ':'   fieldType <- parseType   fieldContent <- optional (DefaultInputValue <$> parseDefaultValue)   fieldDirectives <- optionalDirectives@@ -86,7 +101,9 @@ -- ArgumentsDefinition: --   ( InputValueDefinition(list) ) ---argumentsDefinition :: Parser ArgumentsDefinition+argumentsDefinition ::+  Parse (Value s) =>+  Parser (ArgumentsDefinition s) argumentsDefinition =   label "ArgumentsDefinition" $     uniqTuple inputValueDefinition@@ -96,18 +113,20 @@ --  FieldsDefinition : --    { FieldDefinition(list) } ---fieldsDefinition :: Parser (FieldsDefinition OUT)+fieldsDefinition ::+  Parse (Value s) =>+  Parser (FieldsDefinition OUT s) fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition  --  FieldDefinition --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) ---fieldDefinition :: Parser (FieldDefinition OUT)+fieldDefinition :: Parse (Value s) => Parser (FieldDefinition OUT s) fieldDefinition = label "FieldDefinition" $ do   fieldDescription <- optDescription   fieldName <- parseName   fieldContent <- optional (FieldArgs <$> argumentsDefinition)-  litAssignment -- ':'+  symbol ':'   fieldType <- parseType   fieldDirectives <- optionalDirectives   pure FieldDefinition {..}@@ -116,7 +135,9 @@ --   InputFieldsDefinition: --     { InputValueDefinition(list) } ---inputFieldsDefinition :: Parser InputFieldsDefinition+inputFieldsDefinition ::+  Parse (Value s) =>+  Parser (InputFieldsDefinition s) inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition  -- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives@@ -135,7 +156,7 @@ directive :: Parse (Value s) => Parser (Directive s) directive = label "Directive" $ do   directivePosition <- getLocation-  operator '@'+  symbol '@'   directiveName <- parseName   directiveArgs <- maybeArguments   pure Directive {..}@@ -149,3 +170,43 @@ typeDeclaration kind = do   keyword kind   parseTypeName++parseOperationType :: Parser OperationType+parseOperationType = label "OperationType" $ do+  kind <-+    (string "query" $> Query)+      <|> (string "mutation" $> Mutation)+      <|> (string "subscription" $> Subscription)+  ignoredTokens+  return kind++parseDirectiveLocation :: Parser DirectiveLocation+parseDirectiveLocation =+  label+    "DirectiveLocation"+    ( choice $+        toKeyword+          <$> [ FIELD_DEFINITION,+                FRAGMENT_DEFINITION,+                FRAGMENT_SPREAD,+                INLINE_FRAGMENT,+                ARGUMENT_DEFINITION,+                INTERFACE,+                ENUM_VALUE,+                INPUT_OBJECT,+                INPUT_FIELD_DEFINITION,+                SCHEMA,+                SCALAR,+                OBJECT,+                QUERY,+                MUTATION,+                SUBSCRIPTION,+                UNION,+                ENUM,+                FIELD+              ]+    )+    <* ignoredTokens++toKeyword :: Show a => a -> Parser a+toKeyword x = string (pack $ show x) $> x

@@ -3,12 +3,10 @@ {-# LANGUAGE TupleSections #-}  module Data.Morpheus.Parsing.Internal.Terms-  ( token,-    qualifier,+  ( name,     variable,-    spaceAndComments,-    spaceAndComments1,-    pipeLiteral,+    ignoredTokens,+    parseString,     -------------     collection,     setOf,@@ -19,19 +17,17 @@     parseNonNull,     parseAssignment,     parseWrappedType,-    litEquals,-    litAssignment,-    parseTuple,     parseAlias,     sepByAnd,     parseName,     parseType,     keyword,-    operator,+    symbol,     optDescription,-    optionalList,+    optionalCollection,     parseNegativeSign,     parseTypeName,+    pipe,   ) where @@ -40,8 +36,10 @@ -- MORPHEUS  import Data.Morpheus.Internal.Utils-  ( KeyOf,+  ( Collection,+    KeyOf,     Listable (..),+    empty,     fromElems,   ) import Data.Morpheus.Parsing.Internal.Internal@@ -67,16 +65,16 @@   ( (<?>),     (<|>),     between,+    choice,     label,     many,     manyTill,     optional,     sepBy,+    sepBy1,     sepEndBy,-    skipMany,     skipManyTill,     try,-    try,   ) import Text.Megaparsec.Char   ( char,@@ -89,57 +87,55 @@     string,   ) --- Name : https://graphql.github.io/graphql-spec/June2018/#sec-Names------ Name :: /[_A-Za-z][_0-9A-Za-z]*/---- parseNegativeSign :: Parser Bool-parseNegativeSign = (char '-' $> True <* spaceAndComments) <|> pure False+parseNegativeSign = (char '-' $> True <* ignoredTokens) <|> pure False  parseName :: Parser FieldName-parseName = FieldName <$> token+parseName = FieldName <$> name  parseTypeName :: Parser TypeName-parseTypeName = TypeName <$> token+parseTypeName = label "TypeName" $ TypeName <$> name  keyword :: FieldName -> Parser ()-keyword (FieldName word) = string word *> space1 *> spaceAndComments+keyword (FieldName word) = string word *> space1 *> ignoredTokens -operator :: Char -> Parser ()-operator x = char x *> spaceAndComments+symbol :: Char -> Parser ()+symbol x = char x *> ignoredTokens  -- LITERALS braces :: Parser [a] -> Parser [a] braces =   between-    (char '{' *> spaceAndComments)-    (char '}' *> spaceAndComments)--pipeLiteral :: Parser ()-pipeLiteral = char '|' *> spaceAndComments--litEquals :: Parser ()-litEquals = char '=' *> spaceAndComments--litAssignment :: Parser ()-litAssignment = char ':' *> spaceAndComments+    (char '{' *> ignoredTokens)+    (char '}' *> ignoredTokens)  -- PRIMITIVE -------------------------------------token :: Parser Token-token = label "token" $ do-  firstChar <- letterChar <|> char '_'-  restToken <- many $ letterChar <|> char '_' <|> digitChar-  spaceAndComments-  return $ pack $ firstChar : restToken -qualifier :: Parser (FieldName, Position)-qualifier = label "qualifier" $ do-  position <- getLocation-  value <- parseName-  return (value, position)+-- 2.1.9 Names+-- https://spec.graphql.org/draft/#Name+-- Name ::+--  NameStart NameContinue[list,opt]+--+name :: Parser Token+name = label "Name" $ do+  start <- nameStart+  continue <- nameContinue+  ignoredTokens+  pure $ pack (start : continue) +-- NameStart::+--   Letter+--   _+nameStart :: Parser Char+nameStart = letterChar <|> char '_'++--  NameContinue::+--   Letter+--   Digit+nameContinue :: Parser String+nameContinue = many (letterChar <|> char '_' <|> digitChar)+ -- Variable : https://graphql.github.io/graphql-spec/June2018/#Variable -- -- Variable :  $Name@@ -149,37 +145,61 @@   refPosition <- getLocation   _ <- char '$'   refName <- parseName-  spaceAndComments+  ignoredTokens   pure $ Ref {refName, refPosition} -spaceAndComments1 :: Parser ()-spaceAndComments1 = space1 *> spaceAndComments- -- Descriptions: https://graphql.github.io/graphql-spec/June2018/#Description -- -- Description: --   StringValue--- TODO: should support """ and "---+parseDescription :: Parser Description+parseDescription = strip <$> parseString+ optDescription :: Parser (Maybe Description) optDescription = optional parseDescription -parseDescription :: Parser Description-parseDescription =-  strip . pack <$> (blockDescription <|> singleLine) <* spaceAndComments+parseString :: Parser Token+parseString = blockString <|> singleLineString++blockString :: Parser Token+blockString = stringWith (string "\"\"\"") (printChar <|> newline)++singleLineString :: Parser Token+singleLineString = stringWith (char '"') escapedChar++stringWith :: Parser quote -> Parser Char -> Parser Token+stringWith quote parser =+  pack+    <$> ( quote+            *> manyTill parser quote+            <* ignoredTokens+        )++escapedChar :: Parser Char+escapedChar = label "EscapedChar" $ printChar >>= handleEscape++handleEscape :: Char -> Parser Char+handleEscape '\\' = choice escape+handleEscape x = pure x++escape :: [Parser Char]+escape = map escapeCh escapeOptions   where-    blockDescription =-      blockQuotes-        *> manyTill (printChar <|> newline) blockQuotes-        <* spaceAndComments-      where-        blockQuotes = string "\"\"\""-    -----------------------------    singleLine =-      stringQuote *> manyTill printChar stringQuote <* spaceAndComments-      where-        stringQuote = char '"'+    escapeCh :: (Char, Char) -> Parser Char+    escapeCh (code, replacement) = char code $> replacement +escapeOptions :: [(Char, Char)]+escapeOptions =+  [ ('b', '\b'),+    ('n', '\n'),+    ('f', '\f'),+    ('r', '\r'),+    ('t', '\t'),+    ('\\', '\\'),+    ('\"', '\"'),+    ('/', '/')+  ]+ -- Ignored Tokens : https://graphql.github.io/graphql-spec/June2018/#sec-Source-Text.Ignored-Tokens --  Ignored: --    UnicodeBOM@@ -187,57 +207,67 @@ --    LineTerminator --    Comment --    Comma--- TODO: implement as in specification-spaceAndComments :: Parser ()-spaceAndComments = ignoredTokens- ignoredTokens :: Parser () ignoredTokens =-  label "IgnoredTokens" $ space *> skipMany inlineComment *> space-  where-    inlineComment = char '#' *> skipManyTill printChar newline *> space+  label "IgnoredTokens" $+    space+      *> many ignored+      *> space +ignored :: Parser ()+ignored =+  label "Ignored" $+    comment+      <|> comma++comment :: Parser ()+comment =+  label "Comment" $+    char '#' *> skipManyTill printChar newline *> space++comma :: Parser ()+comma = label "Comma" $ char ',' *> space+ ------------------------------------------------------------------------ --- COMPLEX sepByAnd :: Parser a -> Parser [a]-sepByAnd entry = entry `sepBy` (optional (char '&') *> spaceAndComments)+sepByAnd entry = entry `sepBy` (optional (symbol '&') *> ignoredTokens) +pipe :: Parser a -> Parser [a]+pipe x = optional (symbol '|') *> (x `sepBy1` symbol '|')+ ----------------------------- collection :: Parser a -> Parser [a]-collection entry = braces (entry `sepEndBy` many (char ',' *> spaceAndComments))+collection entry = braces (entry `sepEndBy` ignoredTokens) -setOf :: (Listable a coll, KeyOf a) => Parser a -> Parser coll+setOf :: (Listable a coll, KeyOf k a) => Parser a -> Parser coll setOf = collection >=> fromElems +optionalCollection :: Collection a c => Parser c -> Parser c+optionalCollection x = x <|> pure empty+ parseNonNull :: Parser [DataTypeWrapper] parseNonNull = do   wrapper <- (char '!' $> [NonNullType]) <|> pure []-  spaceAndComments+  ignoredTokens   return wrapper -optionalList :: Parser [a] -> Parser [a]-optionalList x = x <|> pure []--parseTuple :: Parser a -> Parser [a]-parseTuple parser =+uniqTuple :: (Listable a coll, KeyOf k a) => Parser a -> Parser coll+uniqTuple parser =   label "Tuple" $     between-      (char '(' *> spaceAndComments)-      (char ')' *> spaceAndComments)-      ( parser `sepBy` (many (char ',') *> spaceAndComments) <?> "empty Tuple value!"-      )--uniqTuple :: (Listable a coll, KeyOf a) => Parser a -> Parser coll-uniqTuple = parseTuple >=> fromElems+      (char '(' *> ignoredTokens)+      (char ')' *> ignoredTokens)+      (parser `sepBy` ignoredTokens <?> "empty Tuple value!")+      >>= fromElems -uniqTupleOpt :: (Listable a coll, KeyOf a) => Parser a -> Parser coll-uniqTupleOpt = optionalList . parseTuple >=> fromElems+uniqTupleOpt :: (Listable a coll, Collection a coll, KeyOf k a) => Parser a -> Parser coll+uniqTupleOpt x = uniqTuple x <|> pure empty  parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b) parseAssignment nameParser valueParser = label "assignment" $ do   name' <- nameParser-  litAssignment+  symbol ':'   value' <- valueParser   pure (name', value') @@ -248,8 +278,7 @@ -- parseTypeCondition :: Parser TypeName parseTypeCondition = do-  _ <- string "on"-  space1+  keyword "on"   parseTypeName  spreadLiteral :: Parser Position@@ -259,30 +288,13 @@   space   return index -parseWrappedType :: Parser ([DataTypeWrapper], TypeName)-parseWrappedType = (unwrapped <|> wrapped) <* spaceAndComments-  where-    unwrapped :: Parser ([DataTypeWrapper], TypeName)-    unwrapped = ([],) <$> parseTypeName <* spaceAndComments-    -----------------------------------------------    wrapped :: Parser ([DataTypeWrapper], TypeName)-    wrapped =-      between-        (char '[' *> spaceAndComments)-        (char ']' *> spaceAndComments)-        ( do-            (wrappers, name) <- unwrapped <|> wrapped-            nonNull' <- parseNonNull-            return ((ListType : nonNull') ++ wrappers, name)-        )- -- Field Alias : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Alias -- Alias --  Name: parseAlias :: Parser (Maybe FieldName) parseAlias = try (optional alias) <|> pure Nothing   where-    alias = label "alias" $ parseName <* char ':' <* spaceAndComments+    alias = label "alias" $ parseName <* char ':' <* ignoredTokens  parseType :: Parser TypeRef parseType = do@@ -294,3 +306,20 @@         typeArgs = Nothing,         typeWrappers = toHSWrappers $ nonNull ++ wrappers       }++parseWrappedType :: Parser ([DataTypeWrapper], TypeName)+parseWrappedType = (unwrapped <|> wrapped) <* ignoredTokens+  where+    unwrapped :: Parser ([DataTypeWrapper], TypeName)+    unwrapped = ([],) <$> parseTypeName <* ignoredTokens+    ----------------------------------------------+    wrapped :: Parser ([DataTypeWrapper], TypeName)+    wrapped =+      between+        (char '[' *> ignoredTokens)+        (char ']' *> ignoredTokens)+        ( do+            (wrappers, tname) <- unwrapped <|> wrapped+            nonNull' <- parseNonNull+            return ((ListType : nonNull') ++ wrappers, tname)+        )

@@ -17,32 +17,29 @@   ( Parser,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( litEquals,+  ( ignoredTokens,     parseAssignment,     parseName,     parseNegativeSign,+    parseString,     parseTypeName,     setOf,-    spaceAndComments,+    symbol,     variable,   ) import Data.Morpheus.Types.Internal.AST-  ( FieldName,+  ( CONST,+    FieldName,     ObjectEntry (..),-    OrderedMap,+    OrdMap,     RAW,-    ResolvedValue,     ScalarValue (..),-    VALID,     Value (..),     decodeScientific,   )-import Data.Text (pack) import Text.Megaparsec   ( (<|>),-    anySingleBut,     between,-    choice,     label,     many,     sepBy,@@ -74,53 +71,38 @@ enumValue :: Parser (Value a) enumValue = do   enum <- Enum <$> parseTypeName-  spaceAndComments+  ignoredTokens   return enum -escaped :: Parser Char-escaped = label "escaped" $ do-  x <- anySingleBut '\"'-  if x == '\\' then choice (zipWith escapeChar codes replacements) else pure x-  where-    replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']-    codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']-    escapeChar code replacement = char code >> return replacement- stringValue :: Parser (Value a)-stringValue =-  label "stringValue" $-    Scalar . String . pack-      <$> between-        (char '"')-        (char '"')-        (many escaped)+stringValue = label "stringValue" $ Scalar . String <$> parseString  listValue :: Parser a -> Parser [a] listValue parser =   label "ListValue" $     between-      (char '[' *> spaceAndComments)-      (char ']' *> spaceAndComments)-      (parser `sepBy` (many (char ',') *> spaceAndComments))+      (char '[' *> ignoredTokens)+      (char ']' *> ignoredTokens)+      (parser `sepBy` (many (char ',') *> ignoredTokens))  objectEntry :: Parser (Value a) -> Parser (ObjectEntry a) objectEntry parser = label "ObjectEntry" $ do   (entryName, entryValue) <- parseAssignment parseName parser   pure ObjectEntry {entryName, entryValue} -objectValue :: Parser (Value a) -> Parser (OrderedMap FieldName (ObjectEntry a))+objectValue :: Parser (Value a) -> Parser (OrdMap FieldName (ObjectEntry a)) objectValue = label "ObjectValue" . setOf . objectEntry  parsePrimitives :: Parser (Value a) parsePrimitives =   valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue -parseDefaultValue :: Parser ResolvedValue+parseDefaultValue :: Parser (Value s) parseDefaultValue = do-  litEquals+  symbol '='   parseV   where-    parseV :: Parser ResolvedValue+    parseV :: Parser (Value s)     parseV = structValue parseV  class Parse a where@@ -129,7 +111,7 @@ instance Parse (Value RAW) where   parse = (VariableValue <$> variable) <|> structValue parse -instance Parse (Value VALID) where+instance Parse (Value CONST) where   parse = structValue parse  structValue :: Parser (Value a) -> Parser (Value a)@@ -139,4 +121,4 @@         <|> (Object <$> objectValue parser)         <|> (List <$> listValue parser)     )-      <* spaceAndComments+      <* ignoredTokens

@@ -1,116 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Data.Morpheus.Parsing.JSONSchema.Parse-  ( decodeIntrospection,-  )-where--import Data.Aeson-import Data.ByteString.Lazy (ByteString)-import Data.Morpheus.Error.Internal (internalError)-import Data.Morpheus.Internal.Utils-  ( fromElems,-  )-import Data.Morpheus.Parsing.JSONSchema.Types-  ( EnumValue (..),-    Field (..),-    InputValue (..),-    Introspection (..),-    Schema (..),-    Type (..),-  )-import Data.Morpheus.Schema.TypeKind (TypeKind (..))-import Data.Morpheus.Types.IO (JSONResponse (..))-import qualified Data.Morpheus.Types.Internal.AST as AST-  ( Schema,-  )-import Data.Morpheus.Types.Internal.AST-  ( ANY,-    ArgumentsDefinition (..),-    DataTypeWrapper (..),-    FieldDefinition,-    IN,-    OUT,-    TypeContent (..),-    TypeDefinition (..),-    TypeName,-    TypeWrapper,-    createArgument,-    createEnumType,-    createScalarType,-    createType,-    createUnionType,-    mkField,-    mkObjectField,-    msg,-    toAny,-    toHSWrappers,-  )-import Data.Morpheus.Types.Internal.Resolving-  ( Eventless,-  )-import Data.Semigroup ((<>))--decodeIntrospection :: ByteString -> Eventless AST.Schema-decodeIntrospection jsonDoc = case jsonSchema of-  Left errors -> internalError $ msg errors-  Right JSONResponse {responseData = Just Introspection {__schema = Schema {types}}} ->-    traverse parse types >>= fromElems . concat-  Right res -> internalError (msg $ show res)-  where-    jsonSchema :: Either String (JSONResponse Introspection)-    jsonSchema = eitherDecode jsonDoc--class ParseJSONSchema a b where-  parse :: a -> Eventless b--instance ParseJSONSchema Type [TypeDefinition ANY] where-  parse Type {name = Just typeName, kind = SCALAR} =-    pure [createScalarType typeName]-  parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} =-    pure [createEnumType typeName (map enumName enums)]-  parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} =-    case traverse name unions of-      Nothing -> internalError "ERROR: GQL ERROR"-      Just uni -> pure [toAny $ createUnionType typeName uni]-  parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} =-    do-      (fields :: [FieldDefinition IN]) <- traverse parse iFields-      fs <- fromElems fields-      pure [createType typeName $ DataInputObject fs]-  parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} =-    do-      (fields :: [FieldDefinition OUT]) <- traverse parse oFields-      fs <- fromElems fields-      pure [createType typeName $ DataObject [] fs]-  parse _ = pure []--instance ParseJSONSchema Field (FieldDefinition OUT) where-  parse Field {fieldName, fieldArgs, fieldType} = do-    fType <- fieldTypeFromJSON fieldType-    args <- traverse genArg fieldArgs >>= fromElems-    pure $ mkObjectField (ArgumentsDefinition Nothing args) fieldName fType-    where-      genArg InputValue {inputName = argName, inputType = argType} =-        createArgument argName <$> fieldTypeFromJSON argType--instance ParseJSONSchema InputValue (FieldDefinition IN) where-  parse InputValue {inputName, inputType} = mkField inputName <$> fieldTypeFromJSON inputType--fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], TypeName)-fieldTypeFromJSON = fmap toHs . fieldTypeRec []-  where-    toHs (w, t) = (toHSWrappers w, t)-    fieldTypeRec ::-      [DataTypeWrapper] -> Type -> Eventless ([DataTypeWrapper], TypeName)-    fieldTypeRec acc Type {kind = LIST, ofType = Just ofType} =-      fieldTypeRec (ListType : acc) ofType-    fieldTypeRec acc Type {kind = NON_NULL, ofType = Just ofType} =-      fieldTypeRec (NonNullType : acc) ofType-    fieldTypeRec acc Type {name = Just name} = pure (acc, name)-    fieldTypeRec _ x = internalError $ "Unsuported Field" <> msg (show x)

@@ -1,86 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--module Data.Morpheus.Parsing.JSONSchema.Types-  ( Introspection (..),-    Schema (..),-    Type (..),-    Field (..),-    InputValue (..),-    EnumValue (..),-  )-where--import Data.Aeson------ MORPHEUS-import Data.Morpheus.Schema.TypeKind (TypeKind)-import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    TypeName,-  )-import GHC.Generics (Generic)---- TYPES FOR DECODING JSON INTROSPECTION----newtype Introspection = Introspection-  { __schema :: Schema-  }-  deriving (Generic, Show, FromJSON)--newtype Schema = Schema-  { types :: [Type]-  }-  deriving (Generic, Show, FromJSON)---- TYPE-data Type = Type-  { kind :: TypeKind,-    name :: Maybe TypeName,-    fields :: Maybe [Field],-    interfaces :: Maybe [Type],-    possibleTypes :: Maybe [Type],-    enumValues :: Maybe [EnumValue],-    inputFields :: Maybe [InputValue],-    ofType :: Maybe Type-  }-  deriving (Generic, Show, FromJSON)---- FIELD-data Field = Field-  { fieldName :: FieldName,-    fieldArgs :: [InputValue],-    fieldType :: Type-  }-  deriving (Show, Generic)--instance FromJSON Field where-  parseJSON = withObject "Field" objectParser-    where-      objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type"---- INPUT-data InputValue = InputValue-  { inputName :: FieldName,-    inputType :: Type-  }-  deriving (Show, Generic)--instance FromJSON InputValue where-  parseJSON = withObject "InputValue" objectParser-    where-      objectParser o = InputValue <$> o .: "name" <*> o .: "type"---- ENUM-newtype EnumValue = EnumValue-  { enumName :: TypeName-  }-  deriving (Generic, Show)--instance FromJSON EnumValue where-  parseJSON = withObject "EnumValue" objectParser-    where-      objectParser o = EnumValue <$> o .: "name"

@@ -6,10 +6,6 @@   ) where -import Data.Functor (($>))------ MORPHEUS- import Data.Morpheus.Internal.Utils   ( empty,   )@@ -19,12 +15,12 @@   ) import Data.Morpheus.Parsing.Internal.Pattern   ( optionalDirectives,+    parseOperationType,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( operator,-    parseName,+  ( parseName,     parseType,-    spaceAndComments1,+    symbol,     uniqTupleOpt,     variable,   )@@ -48,7 +44,6 @@     label,     optional,   )-import Text.Megaparsec.Char (string)  -- Variables :  https://graphql.github.io/graphql-spec/June2018/#VariableDefinition --@@ -58,7 +53,7 @@ variableDefinition :: Parser (Variable RAW) variableDefinition = label "VariableDefinition" $ do   (Ref variableName variablePosition) <- variable-  operator ':'+  symbol ':'   variableType <- parseType   variableValue <- DefaultValue <$> optional parseDefaultValue   pure Variable {..}@@ -79,15 +74,6 @@   operationDirectives <- optionalDirectives   operationSelection <- parseSelectionSet   pure Operation {..}--parseOperationType :: Parser OperationType-parseOperationType = label "OperationType" $ do-  kind <--    (string "query" $> Query)-      <|> (string "mutation" $> Mutation)-      <|> (string "subscription" $> Subscription)-  spaceAndComments1-  return kind  parseAnonymousQuery :: Parser (Operation RAW) parseAnonymousQuery = label "AnonymousQuery" $ do

@@ -18,7 +18,7 @@     processParser,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( spaceAndComments,+  ( ignoredTokens,   ) import Data.Morpheus.Parsing.Request.Operation   ( parseOperation,@@ -44,7 +44,7 @@  request :: Parser GQLQuery request = label "GQLQuery" $ do-  spaceAndComments+  ignoredTokens   operation <- parseOperation   fragments <- manyTill parseFragmentDefinition eof >>= fromElems   pure GQLQuery {operation, fragments, inputVariables = []}

@@ -108,7 +108,7 @@ --  FragmentDefinition: --   fragment FragmentName TypeCondition Directives(opt) SelectionSet ---parseFragmentDefinition :: Parser Fragment+parseFragmentDefinition :: Parser (Fragment RAW) parseFragmentDefinition = label "FragmentDefinition" $ do   keyword "fragment"   fragmentPosition <- getLocation@@ -125,7 +125,7 @@   fragmentPosition <- spreadLiteral   InlineFragment <$> fragmentBody "INLINE_FRAGMENT" fragmentPosition -fragmentBody :: FieldName -> Position -> Parser Fragment+fragmentBody :: FieldName -> Position -> Parser (Fragment RAW) fragmentBody fragmentName fragmentPosition = label "FragmentBody" $ do   fragmentType <- parseTypeCondition   fragmentDirectives <- optionalDirectives

@@ -19,7 +19,7 @@   ) import Data.Morpheus.Parser   ( parseRequest,-    parseTypeDefinitions,+    parseTypeSystemDefinition,   ) import Data.Morpheus.Types.IO (GQLRequest (..)) import Data.Morpheus.Types.Internal.Resolving@@ -72,7 +72,7 @@       error $ things ++ " are not supported by the GraphQL QuasiQuoter"  dslExpression :: Text -> Q Exp-dslExpression doc = case parseTypeDefinitions doc of+dslExpression doc = case parseTypeSystemDefinition doc of   Failure errors -> fail (renderGQLErrors errors)   Success {result, warnings} ->     gqlWarnings warnings >> [|result|]

@@ -1,26 +1,51 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),     renderObject,-    renderIndent,+    renderMembers,+    newline,+    renderArguments,+    renderEntry,+    space,+    Rendering,   ) where  -- MORPHEUS++import Data.Foldable (null)+import Data.Functor ((<$>))+import Data.Maybe (Maybe, maybe) import Data.Semigroup ((<>)) import Data.Text   ( Text,     intercalate,     pack,   )+import Prelude+  ( (.),+    Bool (..),+    Float,+    Int,+    fmap,+    otherwise,+    show,+  )  type Rendering = Text  class RenderGQL a where   render :: a -> Rendering +instance+  RenderGQL a =>+  RenderGQL (Maybe a)+  where+  render = maybe "" render+ instance RenderGQL Int where   render = pack . show @@ -34,9 +59,35 @@   render True = "true"   render False = "false" -renderIndent :: Rendering-renderIndent = "  "+indent :: Rendering+indent = "  " -renderObject :: (a -> Rendering) -> [a] -> Rendering-renderObject f list =-  " { \n  " <> intercalate ("\n" <> renderIndent) (map f list) <> "\n}"+space :: Rendering+space = " "++newline :: Rendering+newline = "\n"++indentNewline :: Rendering+indentNewline = newline <> indent++renderAtNewLine :: (RenderGQL a) => [a] -> Rendering+renderAtNewLine elems = indentNewline <> intercalate indentNewline (fmap render elems)++renderObject :: (RenderGQL a) => [a] -> Rendering+renderObject fields = " {" <> renderAtNewLine fields <> "\n}"++renderMembers :: (RenderGQL a) => [a] -> Rendering+renderMembers members = intercalate (space <> "|" <> space) (fmap render members)++renderArguments :: (RenderGQL a) => [a] -> Rendering+renderArguments arguments+  | null arguments = ""+  | otherwise = "(" <> intercalate ", " (render <$> arguments) <> ")"++renderEntry ::+  (RenderGQL name, RenderGQL value) =>+  name ->+  value ->+  Rendering+renderEntry name value = render name <> ": " <> render value

@@ -2,13 +2,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Rendering.RenderIntrospection   ( render,@@ -16,20 +14,21 @@   ) where -import Data.Maybe (isJust) -- Morpheus +import Control.Applicative (pure)+import Control.Monad (Monad (..))+import Data.Foldable (foldr)+import Data.Functor ((<$>))+import Data.List (filter)+import Data.Maybe (Maybe (..), isJust, maybe) import Data.Morpheus.Internal.Utils   ( Failure,     elems,     failure,-    fromElems,     selectBy,-    selectOr,   ) import qualified Data.Morpheus.Rendering.RenderGQL as GQL (RenderGQL (..))-import Data.Morpheus.Schema.TypeKind (TypeKind (..))-import qualified Data.Morpheus.Types.Internal.AST as AST (TypeKind (..)) import Data.Morpheus.Types.Internal.AST   ( ANY,     ArgumentsDefinition (..),@@ -47,31 +46,30 @@     IN,     Message,     OUT,-    Object,-    ObjectEntry (..),     QUERY,-    RESOLVED,     Schema,     TRUE,     TypeContent (..),     TypeDefinition (..),+    TypeKind (..),     TypeName (..),     TypeRef (..),     UnionMember (..),     VALID,     Value (..),-    createInputUnionFields,     fieldVisibility,     kindOf,     lookupDeprecated,     lookupDeprecatedReason,+    mkInputUnionFields,     msg,+    possibleInterfaceTypes,     toGQLWrapper,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Context (..),-    ResModel,+  ( ResModel,     Resolver,+    ResolverContext (..),     mkBoolean,     mkList,     mkNull,@@ -81,8 +79,13 @@   ) import Data.Semigroup ((<>)) import Data.Text (pack)--type Result e m a = Resolver QUERY e m a+import Data.Traversable (traverse)+import Prelude+  ( ($),+    (.),+    Bool,+    show,+  )  class   ( Monad m,@@ -91,7 +94,7 @@   ) =>   WithSchema m   where-  getSchema :: m Schema+  getSchema :: m (Schema VALID)  instance Monad m => WithSchema (Resolver QUERY e m) where   getSchema = schema <$> unsafeInternalContext@@ -99,7 +102,7 @@ selectType ::   WithSchema m =>   TypeName ->-  m (TypeDefinition ANY)+  m (TypeDefinition ANY VALID) selectType name =   getSchema     >>= selectBy (" INTERNAL: INTROSPECTION Type not Found: \"" <> msg name <> "\"") name@@ -119,13 +122,20 @@ instance RenderIntrospection Description where   render = pure . mkString -instance RenderIntrospection TypeKind where-  render = pure . mkString . pack . show- instance RenderIntrospection a => RenderIntrospection [a] where   render ls = mkList <$> traverse render ls -instance RenderIntrospection DirectiveDefinition where+instance RenderIntrospection a => RenderIntrospection (Maybe a) where+  render (Just value) = render value+  render Nothing = pure mkNull++instance RenderIntrospection Bool where+  render = pure . mkBoolean++instance RenderIntrospection TypeKind where+  render = pure . mkString . GQL.render++instance RenderIntrospection (DirectiveDefinition VALID) where   render     DirectiveDefinition       { directiveDefinitionName,@@ -145,7 +155,7 @@ instance RenderIntrospection DirectiveLocation where   render locations = pure $ mkString (pack $ show locations) -instance RenderIntrospection (TypeDefinition a) where+instance RenderIntrospection (TypeDefinition cat VALID) where   render     TypeDefinition       { typeName,@@ -153,44 +163,66 @@         typeContent       } = pure $ renderContent typeContent       where-        __type :: Monad m => TypeKind -> [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] -> ResModel QUERY e m+        __type ::+          Monad m =>+          TypeKind ->+          [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] ->+          ResModel QUERY e m         __type kind = mkType kind typeName typeDescription-        renderContent :: Monad m => TypeContent bool a -> ResModel QUERY e m-        renderContent DataScalar {} = __type SCALAR []-        renderContent (DataEnum enums) = __type ENUM [("enumValues", render enums)]+        renderContent ::+          Monad m =>+          TypeContent bool a VALID ->+          ResModel QUERY e m+        renderContent DataScalar {} = __type KindScalar []+        renderContent (DataEnum enums) = __type KindEnum [("enumValues", render enums)]         renderContent (DataInputObject inputFiels) =           __type-            INPUT_OBJECT+            KindInputObject             [("inputFields", render inputFiels)]         renderContent DataObject {objectImplements, objectFields} =           createObjectType typeName typeDescription objectImplements objectFields         renderContent (DataUnion union) =           __type-            UNION+            KindUnion             [("possibleTypes", render union)]         renderContent (DataInputUnion members) =           __type-            INPUT_OBJECT+            KindInputObject             [ ( "inputFields",                 render-                  $ createInputUnionFields typeName-                  $ filter visibility members+                  ( mkInputUnionFields typeName $+                      filter visibility members ::+                      FieldsDefinition IN VALID+                  )               )             ]         renderContent (DataInterface fields) =           __type-            INTERFACE+            KindInterface             [ ("fields", render fields),-              ("possibleTypes", interfacePossibleTypes typeName)+              ("possibleTypes", renderPossibleTypes typeName)             ] -instance RenderIntrospection (UnionMember OUT) where+instance RenderIntrospection (UnionMember OUT s) where   render UnionMember {memberName} = selectType memberName >>= render -instance RenderIntrospection (FieldDefinition cat) => RenderIntrospection (FieldsDefinition cat) where+instance+  RenderIntrospection (FieldDefinition cat s) =>+  RenderIntrospection (FieldsDefinition cat s)+  where   render = render . filter fieldVisibility . elems -instance RenderIntrospection (FieldDefinition OUT) where+instance RenderIntrospection (FieldContent TRUE IN VALID) where+  render = render . defaultInputValue++instance RenderIntrospection (Value VALID) where+  render Null = pure mkNull+  render x = pure $ mkString $ GQL.render x++instance+  RenderIntrospection+    (FieldDefinition OUT VALID)+  where   render FieldDefinition {..} =     pure       $ mkObject "__Field"@@ -201,13 +233,13 @@         ]         <> renderDeprecated fieldDirectives -instance RenderIntrospection (FieldContent TRUE OUT) where+instance RenderIntrospection (FieldContent TRUE OUT VALID) where   render (FieldArgs args) = render args -instance RenderIntrospection ArgumentsDefinition where+instance RenderIntrospection (ArgumentsDefinition VALID) where   render ArgumentsDefinition {arguments} = mkList <$> traverse render (elems arguments) -instance RenderIntrospection (FieldDefinition IN) where+instance RenderIntrospection (FieldDefinition IN VALID) where   render FieldDefinition {..} =     pure $       mkObject@@ -215,10 +247,10 @@         [ renderName fieldName,           description fieldDescription,           type' fieldType,-          defaultValue fieldType (fmap defaultInputValue fieldContent)+          defaultValue fieldContent         ] -instance RenderIntrospection DataEnumValue where+instance RenderIntrospection (DataEnumValue VALID) where   render DataEnumValue {enumName, enumDescription, enumDirectives} =     pure $ mkObject "__Field" $       [ renderName enumName,@@ -228,7 +260,7 @@  instance RenderIntrospection TypeRef where   render TypeRef {typeConName, typeWrappers} = do-    kind <- lookupKind typeConName+    kind <- kindOf <$> selectType typeConName     let currentType = mkType kind typeConName Nothing []     pure $ foldr wrap currentType (toGQLWrapper typeWrappers)     where@@ -239,50 +271,30 @@           [ renderKind (wrapperKind wrapper),             ("ofType", pure contentType)           ]-      wrapperKind ListType = LIST-      wrapperKind NonNullType = NON_NULL+      wrapperKind ListType = KindList+      wrapperKind NonNullType = KindNonNull -interfacePossibleTypes ::+renderPossibleTypes ::   (Monad m) =>   TypeName ->   Resolver QUERY e m (ResModel QUERY e m)-interfacePossibleTypes interfaceName =+renderPossibleTypes name =   mkList     <$> ( getSchema-            >>= sequence-              . concatMap implements-              . elems+            >>= traverse render . possibleInterfaceTypes name         )-  where-    implements typeDef@TypeDefinition {typeContent = DataObject {objectImplements}, ..}-      | interfaceName `elem` objectImplements = [render typeDef]-    implements _ = []  renderDeprecated ::   (Monad m) =>-  Directives VALID ->+  Directives s ->   [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] renderDeprecated dirs =-  [ ("isDeprecated", pure $ mkBoolean (isJust $ lookupDeprecated dirs)),-    ("deprecationReason", opt (pure . mkString) (lookupDeprecated dirs >>= lookupDeprecatedReason))+  [ ("isDeprecated", render (isJust $ lookupDeprecated dirs)),+    ("deprecationReason", render (lookupDeprecated dirs >>= lookupDeprecatedReason))   ]  description :: Monad m => Maybe Description -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))-description desc = ("description", opt render desc)--lookupKind :: (Monad m) => TypeName -> Result e m TypeKind-lookupKind = fmap (renderTypeKind . kindOf) . selectType--renderTypeKind :: AST.TypeKind -> TypeKind-renderTypeKind AST.KindScalar = SCALAR-renderTypeKind (AST.KindObject _) = OBJECT-renderTypeKind AST.KindUnion = UNION-renderTypeKind AST.KindInputUnion = INPUT_OBJECT-renderTypeKind AST.KindEnum = ENUM-renderTypeKind AST.KindInputObject = INPUT_OBJECT-renderTypeKind AST.KindList = LIST-renderTypeKind AST.KindNonNull = NON_NULL-renderTypeKind AST.KindInterface = INTERFACE+description = ("description",) . render  mkType ::   (Monad m, RenderIntrospection name) =>@@ -302,9 +314,14 @@     )  createObjectType ::-  Monad m => TypeName -> Maybe Description -> [TypeName] -> FieldsDefinition OUT -> ResModel QUERY e m+  Monad m =>+  TypeName ->+  Maybe Description ->+  [TypeName] ->+  FieldsDefinition OUT VALID ->+  ResModel QUERY e m createObjectType name desc interfaces fields =-  mkType OBJECT name desc [("fields", render fields), ("interfaces", mkList <$> traverse implementedInterface interfaces)]+  mkType (KindObject Nothing) name desc [("fields", render fields), ("interfaces", mkList <$> traverse implementedInterface interfaces)]  implementedInterface ::   (Monad m) =>@@ -317,10 +334,6 @@     renderContent typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef     renderContent _ = failure ("Type " <> msg name <> " must be an Interface" :: Message) -opt :: Monad m => (a -> Resolver QUERY e m (ResModel QUERY e m)) -> Maybe a -> Resolver QUERY e m (ResModel QUERY e m)-opt f (Just x) = f x-opt _ Nothing = pure mkNull- renderName ::   ( RenderIntrospection name,     Monad m@@ -333,70 +346,12 @@ renderKind = ("kind",) . render  type' :: Monad m => TypeRef -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))-type' ref = ("type", render ref)+type' = ("type",) . render  defaultValue ::   Monad m =>-  TypeRef ->-  Maybe (Value RESOLVED) ->+  Maybe (FieldContent TRUE IN VALID) ->   ( FieldName,     Resolver QUERY e m (ResModel QUERY e m)   )-defaultValue-  typeRef-  value =-    ( "defaultValue",-      opt-        ( fmap-            (mkString . GQL.render)-            . fulfill typeRef-            . Just-        )-        value-    )--fulfill ::-  WithSchema m =>-  TypeRef ->-  Maybe (Value RESOLVED) ->-  m (Value RESOLVED)-fulfill TypeRef {typeConName} (Just (Object fields)) =-  selectType typeConName-    >>= \case-      TypeDefinition-        { typeContent =-            DataInputObject {inputObjectFields}-        } ->-          Object-            <$> ( traverse-                    (handleField fields)-                    (elems inputObjectFields)-                    >>= fromElems-                )-      _ -> failure (msg typeConName <> "is not must be Object")-fulfill typeRef (Just (List values)) =-  List <$> traverse (fulfill typeRef . Just) values-fulfill _ (Just v) = pure v-fulfill _ Nothing = pure Null--handleField ::-  WithSchema m =>-  Object RESOLVED ->-  FieldDefinition IN ->-  m (ObjectEntry RESOLVED)-handleField-  fields-  FieldDefinition-    { fieldName,-      fieldType,-      fieldContent = x-    } =-    ObjectEntry fieldName-      <$> fulfill-        fieldType-        ( selectOr-            (fmap defaultInputValue x)-            (Just . entryValue)-            fieldName-            fields-        )+defaultValue = ("defaultValue",) . render

@@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}  module Data.Morpheus.Schema.DSL (dsl) where@@ -11,11 +12,11 @@   ( gqlWarnings,     renderGQLErrors,   )-import Data.Morpheus.Parsing.Document.TypeSystem (parseSchema)-import Data.Morpheus.Types.Internal.AST (ANY, TypeDefinition)+import Data.Morpheus.Parsing.Document.TypeSystem+  ( parseSchema,+  ) import Data.Morpheus.Types.Internal.Resolving-  ( Eventless,-    Result (..),+  ( Result (..),   ) import Data.Text   ( Text,@@ -37,7 +38,6 @@       error $ things ++ " are not supported by the GraphQL QuasiQuoter"  dslExpression :: Text -> Q Exp-dslExpression doc = case (parseSchema doc :: Eventless [TypeDefinition ANY]) of+dslExpression doc = case parseSchema doc of   Failure errors -> fail (renderGQLErrors errors)-  Success {result, warnings} ->-    gqlWarnings warnings >> [|result|]+  Success {result, warnings} -> gqlWarnings warnings >> [|result|]

@@ -1,43 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Schema.Directives (defaultDirectives) where--import Data.Morpheus.Internal.Utils-  ( singleton,-  )-import Data.Morpheus.Types.Internal.AST-  ( ArgumentsDefinition (..),-    DirectiveDefinition (..),-    DirectiveLocation (..),-    TypeWrapper (..),-    mkField,-  )--defaultDirectives :: [DirectiveDefinition]-defaultDirectives =-  [ DirectiveDefinition-      { directiveDefinitionName = "skip",-        directiveDefinitionDescription = Just "Directs the executor to skip this field or fragment when the `if` argument is true.",-        directiveDefinitionLocations = [FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT],-        directiveDefinitionArgs = argumentsIf-      },-    DirectiveDefinition-      { directiveDefinitionName = "include",-        directiveDefinitionDescription = Just "Directs the executor to include this field or fragment only when the `if` argument is true.",-        directiveDefinitionLocations = [FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT],-        directiveDefinitionArgs = argumentsIf-      },-    DirectiveDefinition-      { directiveDefinitionName = "deprecated",-        directiveDefinitionDescription = Just "Marks an element of a GraphQL schema as no longer supported.",-        directiveDefinitionLocations = [FIELD_DEFINITION, ENUM_VALUE],-        directiveDefinitionArgs =-          singleton $-            mkField-              "reason"-              ([TypeMaybe], "String")-      }-  ]--argumentsIf :: ArgumentsDefinition-argumentsIf = singleton $ mkField "if" ([], "Boolean")

@@ -3,80 +3,61 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}  module Data.Morpheus.Schema.Schema-  ( withSystemTypes,-    systemTypes,+  ( internalSchema,   ) where  -- MORPHEUS -import Data.Morpheus.Internal.Utils-  ( (<:>),-    singleton,-  ) import Data.Morpheus.Schema.DSL (dsl) import Data.Morpheus.Types.Internal.AST-  ( ANY,-    DataFingerprint (..),-    FieldsDefinition,-    Message,-    OUT,+  ( DataFingerprint (..),     Schema (..),-    TypeContent (..),     TypeDefinition (..),-    TypeUpdater,-    TypeWrapper (..),-    createArgument,-    insertType,     internalFingerprint,-    mkField,-    mkObjectField,-    unsafeFromFields,   )-import Data.Morpheus.Types.Internal.Resolving-  ( failure,-    resolveUpdates,-  ) -withSystemTypes :: TypeUpdater-withSystemTypes s@Schema {query = q@TypeDefinition {typeContent = DataObject inter fields}} =-  ( do-      fs <- fields <:> hiddenFields-      pure $ s {query = q {typeContent = DataObject inter fs}}-  )-    >>= (`resolveUpdates` map (insertType . internalType) systemTypes)-withSystemTypes _ = failure ("Query must be an Object Type" :: Message)--hiddenFields :: FieldsDefinition OUT-hiddenFields =-  unsafeFromFields-    [ mkObjectField-        (singleton (createArgument "name" ([], "String")))-        "__type"-        ([TypeMaybe], "__Type"),-      mkField-        "__schema"-        ([], "__Schema")-    ]+toInternalSchema :: Schema s -> Schema s+toInternalSchema Schema {..} = Schema {types = fmap toInternalType types, ..} -internalType :: TypeDefinition a -> TypeDefinition a-internalType+toInternalType :: TypeDefinition a s -> TypeDefinition a s+toInternalType   tyDef@TypeDefinition     { typeFingerprint = DataFingerprint name xs     } =     tyDef {typeFingerprint = internalFingerprint name xs} -systemTypes :: [TypeDefinition ANY]-systemTypes =-  [dsl|+internalSchema :: Schema s+internalSchema =+  toInternalSchema+    [dsl| -# default scalars+"""+Directs the executor to skip this field or fragment when the `if` argument is true.+"""+directive @skip(if: Boolean!) +  on FIELD | FRAGMENT_SPREAD | INLINE_FRAGMENT++"""+Directs the executor to include this field or fragment only when the `if` argument is true.+"""+directive @include(if: Boolean!) +  on FIELD | FRAGMENT_SPREAD | INLINE_FRAGMENT++"""+Marks an element of a GraphQL schema as no longer supported.+"""+directive @deprecated(reason: String) +  on FIELD_DEFINITION | ENUM_VALUE++ scalar Boolean scalar Int scalar Float@@ -175,6 +156,11 @@   INPUT_OBJECT   LIST   NON_NULL+}++type Query {+  __type(name: String!): __Type+  __schema: __Schema! }  |]

@@ -3,7 +3,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeOperators #-}  module Data.Morpheus.Schema.SchemaAPI   ( withSystemFields,@@ -12,7 +11,7 @@  -- MORPHEUS import Data.Morpheus.Internal.Utils-  ( (<:>),+  ( (<.>),     elems,     empty,     selectOr,@@ -21,20 +20,19 @@   ( createObjectType,     render,   )-import Data.Morpheus.Schema.Directives-  ( defaultDirectives,-  ) import Data.Morpheus.Schema.Schema   (   ) import Data.Morpheus.Types.Internal.AST   ( Argument (..),-    OUT,+    FieldName,+    OBJECT,     QUERY,     ScalarValue (..),     Schema (..),     TypeDefinition (..),     TypeName (..),+    VALID,     Value (..),   ) import Data.Morpheus.Types.Internal.Resolving@@ -49,35 +47,28 @@   )  resolveTypes ::-  Monad m => Schema -> Resolver QUERY e m (ResModel QUERY e m)+  Monad m => Schema VALID -> Resolver QUERY e m (ResModel QUERY e m) resolveTypes schema = mkList <$> traverse render (elems schema)  renderOperation ::-  Monad m => Maybe (TypeDefinition OUT) -> Resolver QUERY e m (ResModel QUERY e m)+  Monad m =>+  Maybe (TypeDefinition OBJECT VALID) ->+  Resolver QUERY e m (ResModel QUERY e m) renderOperation (Just TypeDefinition {typeName}) = pure $ createObjectType typeName Nothing [] empty renderOperation Nothing = pure mkNull  findType ::   Monad m =>   TypeName ->-  Schema ->+  Schema VALID ->   Resolver QUERY e m (ResModel QUERY e m) findType = selectOr (pure mkNull) render -renderDirectives ::-  Monad m =>-  Resolver QUERY e m (ResModel QUERY e m)-renderDirectives =-  mkList-    <$> traverse-      render-      defaultDirectives- schemaResolver ::   Monad m =>-  Schema ->+  Schema VALID ->   Resolver QUERY e m (ResModel QUERY e m)-schemaResolver schema@Schema {query, mutation, subscription} =+schemaResolver schema@Schema {query, mutation, subscription, directiveDefinitions} =   pure $     mkObject       "__Schema"@@ -85,10 +76,10 @@         ("queryType", renderOperation (Just query)),         ("mutationType", renderOperation mutation),         ("subscriptionType", renderOperation subscription),-        ("directives", renderDirectives)+        ("directives", render directiveDefinitions)       ] -schemaAPI :: Monad m => Schema -> ResModel QUERY e m+schemaAPI :: Monad m => Schema VALID -> ResModel QUERY e m schemaAPI schema =   mkObject     "Root"@@ -96,7 +87,7 @@       ("__schema", schemaResolver schema)     ]   where-    typeResolver = selectOr (pure mkNull) handleArg "name"+    typeResolver = selectOr (pure mkNull) handleArg ("name" :: FieldName)       where         handleArg           Argument@@ -104,10 +95,14 @@             } = findType (TypeName typename) schema         handleArg _ = pure mkNull -withSystemFields :: Monad m => Schema -> RootResModel e m -> ResultT e' m (RootResModel e m)+withSystemFields ::+  Monad m =>+  Schema VALID ->+  RootResModel e m ->+  ResultT e' m (RootResModel e m) withSystemFields schema RootResModel {query, ..} =   pure $     RootResModel-      { query = query >>= (<:> schemaAPI schema),+      { query = query >>= (<.> schemaAPI schema),         ..       }

@@ -1,22 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Schema.TypeKind-  ( TypeKind (..),-  )-where--import Data.Aeson (FromJSON (..))-import GHC.Generics--data TypeKind-  = SCALAR-  | OBJECT-  | INTERFACE-  | UNION-  | ENUM-  | INPUT_OBJECT-  | LIST-  | NON_NULL-  deriving (Eq, Generic, FromJSON, Show)

@@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.GQLScalar   ( GQLScalar (..),@@ -11,8 +12,9 @@   ) where -import Control.Monad.Fail (MonadFail)+import Control.Monad.Fail (MonadFail (..)) import qualified Data.Aeson as A+import Data.Either (Either (..), either) import Data.Morpheus.Types.Internal.AST   ( ScalarDefinition (..),     ScalarValue (..),@@ -22,6 +24,17 @@   ) import Data.Proxy (Proxy (..)) import Data.Text (Text, unpack)+import Prelude+  ( ($),+    (.),+    Bool,+    Float,+    Int,+    Monad,+    fromInteger,+    pure,+    toInteger,+  )  toScalar :: ValidValue -> Either Text ScalarValue toScalar (Scalar x) = pure x@@ -53,7 +66,7 @@       validator value = do         scalarValue' <- toScalar value         (_ :: a) <- parseValue scalarValue'-        return value+        pure value  instance GQLScalar Text where   parseValue (String x) = pure x

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.ID   ( ID (..),@@ -21,6 +22,13 @@     pack,   ) import GHC.Generics (Generic)+import Prelude+  ( ($),+    Either (..),+    Eq,+    Show (..),+    pure,+  )  -- | default GraphQL type, -- parses only 'String' and 'Int' values,@@ -28,12 +36,12 @@ newtype ID = ID   { unpackID :: Text   }-  deriving (Show, Generic)+  deriving (Show, Generic, Eq)  instance GQLScalar ID where-  parseValue (Int x) = return (ID $ pack $ show x)-  parseValue (String x) = return (ID x)-  parseValue _ = Left ""+  parseValue (Int x) = pure (ID $ pack $ show x)+  parseValue (String x) = pure (ID x)+  parseValue _ = Left "ID can only be String or number"   serialize (ID x) = String x  instance ToJSON ID where

@@ -1,8 +1,10 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.IO   ( GQLRequest (..),@@ -13,6 +15,10 @@   ) where +-- MORPHEUS++import Control.Applicative (Applicative (..))+import Control.Monad.Fail (fail) import Data.Aeson   ( (.:?),     (.=),@@ -40,10 +46,12 @@     fromStrict,     toStrict,   )+import Data.Either (Either (..))+import Data.Functor ((<$>), fmap) import qualified Data.HashMap.Lazy as LH   ( toList,   )--- MORPHEUS+import Data.Maybe (Maybe (..)) import Data.Morpheus.Error.Utils (badRequestError) import Data.Morpheus.Types.Internal.AST   ( FieldName,@@ -66,27 +74,31 @@     encodeUtf8,   ) import GHC.Generics (Generic)+import Prelude (($), (.), Show, String)  decodeNoDup :: Failure String m => LB.ByteString -> m GQLRequest decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of   Left (path, x) -> failure $ formatError path x   Right value -> pure value -class MapAPI a where-  mapAPI :: Applicative m => (GQLRequest -> m GQLResponse) -> a -> m a+class MapAPI a b where+  mapAPI :: Applicative m => (GQLRequest -> m GQLResponse) -> a -> m b -instance MapAPI LB.ByteString where+instance MapAPI GQLRequest GQLResponse where+  mapAPI f = f++instance MapAPI LB.ByteString LB.ByteString where   mapAPI api request = case decodeNoDup request of     Left aesonError -> pure $ badRequestError aesonError     Right req -> encode <$> api req -instance MapAPI LT.Text where+instance MapAPI LT.Text LT.Text where   mapAPI api = fmap decodeUtf8 . mapAPI api . encodeUtf8 -instance MapAPI ByteString where+instance MapAPI ByteString ByteString where   mapAPI api = fmap LB.toStrict . mapAPI api . LB.fromStrict -instance MapAPI Text where+instance MapAPI Text Text where   mapAPI api = fmap LT.toStrict . mapAPI api . LT.fromStrict  renderResponse :: Result e ValidValue -> GQLResponse

@@ -2,6 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST   ( -- BASE@@ -12,10 +13,9 @@     FieldName (..),     Description,     Stage,-    RESOLVED,+    CONST,     VALID,     RAW,-    VALIDATION_MODE (..),     -- VALUE     Value (..),     ScalarValue (..),@@ -47,7 +47,6 @@     VariableDefinitions,     DefaultValue,     getOperationName,-    getOperationDataType,     -- DSL     ScalarDefinition (..),     DataEnum,@@ -71,17 +70,14 @@     MUTATION,     SUBSCRIPTION,     Directive (..),-    TypeUpdater,     ConsD (..),     TypeCategory,     DataInputUnion,     VariableContent (..),     TypeLib,     initTypeLib,-    defineType,-    isFieldNullable,     kindOf,-    toNullableField,+    toNullable,     toListField,     isObject,     isInput,@@ -91,19 +87,14 @@     isWeaker,     isSubscription,     isOutputObject,-    sysTypes,-    isSystemTypeName,+    isNotSystemTypeName,     isEntNode,-    createField,-    createArgument,-    createEnumType,+    mkEnumContent,     createScalarType,-    createType,-    createUnionType,-    createAlias,-    createInputUnionFields,+    mkUnionContent,+    mkTypeRef,+    mkInputUnionFields,     fieldVisibility,-    createEnumValue,     insertType,     lookupDeprecated,     lookupDeprecatedReason,@@ -113,9 +104,8 @@     -- LOCAL     GQLQuery (..),     Variables,-    isNullableWrapper,     unsafeFromFields,-    OrderedMap,+    OrdMap,     GQLError (..),     GQLErrors,     ObjectEntry (..),@@ -126,8 +116,10 @@     ANY,     IN,     OUT,-    FromAny (..),-    ToAny (..),+    OBJECT,+    IMPLEMENTABLE,+    fromAny,+    toAny,     TRUE,     FALSE,     TypeName (..),@@ -147,30 +139,59 @@     DirectiveLocation (..),     FieldContent (..),     fieldContentArgs,-    mkField,+    mkInputValue,+    mkType,     TypeNameTH (..),     isOutput,     mkObjectField,     UnionMember (..),     mkUnionMember,+    RawTypeDefinition (..),+    RootOperationTypeDefinition (..),+    UnionSelection,+    SchemaDefinition (..),+    buildSchema,+    InternalError (..),+    ValidationError (..),+    msgInternal,+    getOperationDataType,+    Typed (Typed),+    typed,+    untyped,+    msgValidation,+    withPosition,+    ValidationErrors,+    toGQLError,+    ELEM,+    LEAF,+    REQURE_IMPLEMENTABLE,+    ToCategory (..),+    FromCategory (..),+    possibleTypes,+    possibleInterfaceTypes,   ) where  import Data.HashMap.Lazy (HashMap) -- Morpheus+ import Data.Morpheus.Types.Internal.AST.Base import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..))-import Data.Morpheus.Types.Internal.AST.OrderedMap+import Data.Morpheus.Types.Internal.AST.Fields+import Data.Morpheus.Types.Internal.AST.OrdMap import Data.Morpheus.Types.Internal.AST.Selection+import Data.Morpheus.Types.Internal.AST.Stage import Data.Morpheus.Types.Internal.AST.TH+import Data.Morpheus.Types.Internal.AST.TypeCategory import Data.Morpheus.Types.Internal.AST.TypeSystem import Data.Morpheus.Types.Internal.AST.Value import Language.Haskell.TH.Syntax (Lift)+import Prelude (Show)  type Variables = HashMap FieldName ResolvedValue  data GQLQuery = GQLQuery-  { fragments :: Fragments,+  { fragments :: Fragments RAW,     operation :: Operation RAW,     inputVariables :: [(FieldName, ResolvedValue)]   }

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}@@ -8,6 +9,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST.Base   ( Ref (..),@@ -15,13 +18,8 @@     Message (..),     FieldName (..),     Description,-    VALID,-    RAW,     TypeWrapper (..),-    Stage (..),-    RESOLVED,     TypeRef (..),-    VALIDATION_MODE (..),     OperationType (..),     QUERY,     MUTATION,@@ -33,15 +31,13 @@     anonymousRef,     toHSWrappers,     toGQLWrapper,-    sysTypes,-    isNullable,+    Nullable (..),     isWeaker,     isSubscription,     isOutputObject,-    isSystemTypeName,+    isNotSystemTypeName,     isObject,     isInput,-    isNullableWrapper,     sysFields,     hsTypeName,     toOperationType,@@ -60,6 +56,14 @@     convertToJSONName,     convertToHaskellName,     isOutput,+    mkTypeRef,+    InternalError (..),+    msgInternal,+    ValidationError (..),+    msgValidation,+    ValidationErrors,+    withPosition,+    toGQLError,   ) where @@ -70,16 +74,43 @@     encode,   ) import Data.ByteString.Lazy.Char8 (ByteString, unpack)+import Data.Char (toLower) import Data.Hashable (Hashable)+import Data.Maybe (Maybe (..), maybeToList) import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..)) import Data.Semigroup (Semigroup (..))-import Data.String (IsString)+import Data.String (IsString (..)) import Data.Text (Text, intercalate, pack) import qualified Data.Text as T import GHC.Generics (Generic)--- import Instances.TH.Lift ()-import Language.Haskell.TH (stringE)-import Language.Haskell.TH.Syntax (Lift (..))+import Language.Haskell.TH+  ( ExpQ,+    stringE,+  )+import Language.Haskell.TH.Syntax+  ( Lift (..),+    Q,+    TExp,+    unsafeTExpCoerce,+  )+import Prelude+  ( ($),+    (&&),+    (.),+    Bool (..),+    Eq (..),+    Functor (..),+    Int,+    Ord (..),+    Show (..),+    String,+    elem,+    fst,+    id,+    not,+    notElem,+    otherwise,+  )  type TRUE = 'True @@ -96,13 +127,65 @@     (Show, Eq, Ord, IsString, Semigroup, Hashable, FromJSON, ToJSON)  instance Lift Message where-  lift = stringE . T.unpack . readMessage+  lift = liftString . readMessage +#if MIN_VERSION_template_haskell(2,16,0)+  liftTyped = liftTypedString . readMessage+#endif++newtype InternalError = InternalError+  { readInternalError :: Text+  }+  deriving+    (Generic)+  deriving newtype+    (Show, Eq, Ord, IsString, Semigroup, Hashable, FromJSON, ToJSON)++data ValidationError = ValidationError+  { validationMessage :: Message,+    validationLocations :: [Position]+  }+  deriving (Show)++instance IsString ValidationError where+  fromString = (`ValidationError` []) . msg++instance Semigroup ValidationError where+  ValidationError m1 p1 <> ValidationError m2 p2 =+    ValidationError (m1 <> m2) (p1 <> p2)++withPosition :: Maybe Position -> ValidationError -> ValidationError+withPosition pos (ValidationError m ps) = ValidationError m (ps <> maybeToList pos)++type ValidationErrors = [ValidationError]++toGQLError :: ValidationError -> GQLError+toGQLError (ValidationError m p) = GQLError m p++-- instance Lift InternalError where+--   lift = liftString . readInternalError++-- #if MIN_VERSION_template_haskell(2,16,0)+--   liftTyped = liftTypedString . readInternalError+-- #endif++msgInternal :: (Msg a) => a -> InternalError+msgInternal = InternalError . readMessage . msg++msgValidation :: (Msg a) => a -> ValidationError+msgValidation = (`ValidationError` []) . msg+ class Msg a where   msg :: a -> Message   msgSepBy :: Text -> [a] -> Message-  msgSepBy t = Message . intercalate t . map (readMessage . msg)+  msgSepBy t = Message . intercalate t . fmap (readMessage . msg) +instance Msg Message where+  msg = id++instance Msg InternalError where+  msg = Message . ("Internal Error! " <>) . readInternalError+ instance Msg String where   msg = Message . pack @@ -115,6 +198,10 @@ instance Msg Value where   msg = msg . encode +class Nullable a where+  isNullable :: a -> Bool+  toNullable :: a -> a+ -- FieldName : lower case names newtype FieldName = FieldName {readName :: Text}   deriving@@ -123,8 +210,12 @@     (Show, Ord, Eq, IsString, Hashable, Semigroup, FromJSON, ToJSON)  instance Lift FieldName where-  lift = stringE . T.unpack . readName+  lift = liftString . readName +#if MIN_VERSION_template_haskell(2,16,0)+  liftTyped = liftTypedString . readName+#endif+ instance Msg FieldName where   msg FieldName {readName} = Message $ "\"" <> readName <> "\"" @@ -132,7 +223,7 @@   render = readName  intercalateName :: FieldName -> [FieldName] -> FieldName-intercalateName (FieldName x) = FieldName . intercalate x . map readName+intercalateName (FieldName x) = FieldName . intercalate x . fmap readName  toFieldName :: TypeName -> FieldName toFieldName = FieldName . readTypeName@@ -145,8 +236,18 @@     (Show, Ord, Eq, IsString, Hashable, Semigroup, FromJSON, ToJSON)  instance Lift TypeName where-  lift = stringE . T.unpack . readTypeName+  lift = liftString . readTypeName +#if MIN_VERSION_template_haskell(2,16,0)+  liftTyped = liftTypedString . readTypeName+#endif++liftTypedString :: IsString a => Token -> Q (TExp a)+liftTypedString = unsafeTExpCoerce . stringE . T.unpack++liftString :: Token -> ExpQ+liftString = stringE . T.unpack+ instance Msg TypeName where   msg TypeName {readTypeName} = Message $ "\"" <> readTypeName <> "\"" @@ -156,8 +257,6 @@ -- Description type Description = Text -data Stage = RAW | RESOLVED | VALID- data Position = Position   { line :: Int,     column :: Int@@ -177,17 +276,6 @@  type GQLErrors = [GQLError] -type RAW = 'RAW--type RESOLVED = 'RESOLVED--type VALID = 'VALID--data VALIDATION_MODE-  = WITHOUT_VARIABLES-  | FULL_VALIDATION-  deriving (Eq, Show)- data DataFingerprint = DataFingerprint TypeName [String] deriving (Show, Eq, Ord, Lift)  internalFingerprint :: TypeName -> [String] -> DataFingerprint@@ -197,8 +285,16 @@   = Query   | Subscription   | Mutation-  deriving (Show, Eq, Lift)+  deriving (Show, Eq, Lift, Generic, Hashable) +instance RenderGQL OperationType where+  render = pack . fmap toLower . show++instance Msg OperationType where+  msg Query = msg ("query" :: TypeName)+  msg Mutation = msg ("mutation" :: TypeName)+  msg Subscription = msg ("subscription" :: TypeName)+ type QUERY = 'Query  type MUTATION = 'Mutation@@ -236,9 +332,14 @@   }   deriving (Show, Eq, Lift) -isNullable :: TypeRef -> Bool-isNullable TypeRef {typeWrappers = typeWrappers} = isNullableWrapper typeWrappers+mkTypeRef :: TypeName -> TypeRef+mkTypeRef typeConName =+  TypeRef {typeConName, typeWrappers = [], typeArgs = Nothing} +instance Nullable TypeRef where+  isNullable = isNullable . typeWrappers+  toNullable TypeRef {..} = TypeRef {typeWrappers = toNullable typeWrappers, ..}+ instance RenderGQL TypeRef where   render TypeRef {typeConName, typeWrappers} = renderWrapped typeConName typeWrappers @@ -259,6 +360,17 @@   | KindInterface   deriving (Eq, Show, Lift) +instance RenderGQL TypeKind where+  render KindScalar = "SCALAR"+  render KindObject {} = "OBJECT"+  render KindUnion = "UNION"+  render KindInputUnion = "INPUT_OBJECT"+  render KindEnum = "ENUM"+  render KindInputObject = "INPUT_OBJECT"+  render KindList = "LIST"+  render KindNonNull = "NON_NULL"+  render KindInterface = "INTERFACE"+ isSubscription :: TypeKind -> Bool isSubscription (KindObject (Just Subscription)) = True isSubscription _ = False@@ -296,9 +408,11 @@   | NonNullType   deriving (Show, Lift) -isNullableWrapper :: [TypeWrapper] -> Bool-isNullableWrapper (TypeMaybe : _) = True-isNullableWrapper _ = False+instance Nullable [TypeWrapper] where+  isNullable (TypeMaybe : _) = True+  isNullable _ = False+  toNullable (TypeMaybe : xs) = TypeMaybe : xs+  toNullable xs = TypeMaybe : xs  isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool isWeaker (TypeMaybe : xs1) (TypeMaybe : xs2) = isWeaker xs1 xs2@@ -328,25 +442,24 @@     showGQLWrapper (ListType : xs) = "[" <> showGQLWrapper xs <> "]"     showGQLWrapper (NonNullType : xs) = showGQLWrapper xs <> "!" -isSystemTypeName :: TypeName -> Bool-isSystemTypeName = (`elem` sysTypes)--sysTypes :: [TypeName]-sysTypes =-  [ "__Schema",-    "__Type",-    "__Directive",-    "__TypeKind",-    "__Field",-    "__DirectiveLocation",-    "__InputValue",-    "__EnumValue",-    "String",-    "Float",-    "Int",-    "Boolean",-    "ID"-  ]+isNotSystemTypeName :: TypeName -> Bool+isNotSystemTypeName =+  ( `notElem`+      [ "__Schema",+        "__Type",+        "__Directive",+        "__TypeKind",+        "__Field",+        "__DirectiveLocation",+        "__InputValue",+        "__EnumValue",+        "String",+        "Float",+        "Int",+        "Boolean",+        "ID"+      ]+  )  sysFields :: [FieldName] sysFields = ["__typename", "__schema", "__type"]

@@ -1,9 +1,14 @@ {-# LANGUAGE DeriveLift #-}+{-# LANGUAGE NoImplicitPrelude #-} -module Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..)) where+module Data.Morpheus.Types.Internal.AST.DirectiveLocation+  ( DirectiveLocation (..),+  )+where  import Data.Morpheus.Types.Internal.AST.Base (Msg (..)) import Language.Haskell.TH.Syntax (Lift)+import Prelude ((.), Eq, Show (..))  data DirectiveLocation   = QUERY

@@ -0,0 +1,368 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.Internal.AST.Fields+  ( Arguments,+    Argument (..),+    ArgumentDefinition,+    ArgumentsDefinition (..),+    FieldDefinition (..),+    FieldsDefinition,+    Fields (..),+    FieldContent (..),+    InputFieldsDefinition,+    DirectiveDefinitions,+    DirectiveDefinition (..),+    Directives,+    Directive (..),+    fieldVisibility,+    toListField,+    lookupDeprecated,+    lookupDeprecatedReason,+    unsafeFromFields,+    fieldsToArguments,+    fieldContentArgs,+    mkInputValue,+    mkObjectField,+  )+where++-- MORPHEUS++import Data.Foldable (Foldable)+import Data.Functor ((<$>), Functor (..))+import Data.List (find)+import Data.Maybe (Maybe (..))+import Data.Morpheus.Error.NameCollision+  ( NameCollision (..),+  )+import Data.Morpheus.Internal.Utils+  ( Collection (..),+    KeyOf (..),+    Listable (..),+    Merge (..),+    Selectable (..),+    elems,+  )+import Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+    renderArguments,+    renderEntry,+    renderObject,+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( Description,+    FieldName,+    FieldName (..),+    Msg (..),+    Nullable (..),+    Position,+    TRUE,+    TypeName,+    TypeRef (..),+    TypeWrapper (..),+    ValidationError (..),+    msgValidation,+    sysFields,+  )+import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation)+import Data.Morpheus.Types.Internal.AST.OrdMap+  ( OrdMap,+    unsafeFromValues,+  )+import Data.Morpheus.Types.Internal.AST.Stage+  ( Stage,+  )+import Data.Morpheus.Types.Internal.AST.TypeCategory+  ( ANY,+    ELEM,+    IN,+    OUT,+    ToCategory (..),+    TypeCategory,+    toAny,+  )+import Data.Morpheus.Types.Internal.AST.Value+  ( ScalarValue (..),+    Value (..),+  )+import Data.Semigroup (Semigroup ((<>)))+import Data.Traversable (Traversable)+import Instances.TH.Lift ()+import Language.Haskell.TH.Syntax (Lift (..))+import Prelude+  ( ($),+    (.),+    Bool (..),+    Eq,+    Show,+    filter,+    notElem,+  )++-- scalar+------------------------------------------------------------------+data Argument (valid :: Stage) = Argument+  { argumentName :: FieldName,+    argumentPosition :: Position,+    argumentValue :: Value valid+  }+  deriving (Show, Eq, Lift)++instance KeyOf FieldName (Argument stage) where+  keyOf = argumentName++instance RenderGQL (Argument s) where+  render Argument {argumentName, argumentValue} =+    renderEntry argumentName argumentValue++instance NameCollision (Argument s) where+  nameCollision Argument {argumentName, argumentPosition} =+    ValidationError+      { validationMessage = "There can Be only One Argument Named " <> msg argumentName,+        validationLocations = [argumentPosition]+      }++type Arguments (s :: Stage) = OrdMap FieldName (Argument s)++-- directive+------------------------------------------------------------------+data Directive (s :: Stage) = Directive+  { directiveName :: FieldName,+    directivePosition :: Position,+    directiveArgs :: Arguments s+  }+  deriving (Show, Lift, Eq)++instance KeyOf FieldName (Directive s) where+  keyOf = directiveName++type Directives s = [Directive s]++data DirectiveDefinition s = DirectiveDefinition+  { directiveDefinitionName :: FieldName,+    directiveDefinitionDescription :: Maybe Description,+    directiveDefinitionLocations :: [DirectiveLocation],+    directiveDefinitionArgs :: ArgumentsDefinition s+  }+  deriving (Show, Lift)++type DirectiveDefinitions s = [DirectiveDefinition s]++instance KeyOf FieldName (DirectiveDefinition s) where+  keyOf = directiveDefinitionName++instance Selectable FieldName (ArgumentDefinition s) (DirectiveDefinition s) where+  selectOr fb f key DirectiveDefinition {directiveDefinitionArgs} =+    selectOr fb f key directiveDefinitionArgs++lookupDeprecated :: [Directive s] -> Maybe (Directive s)+lookupDeprecated = find isDeprecation+  where+    isDeprecation Directive {directiveName = "deprecated"} = True+    isDeprecation _ = False++lookupDeprecatedReason :: Directive s -> Maybe Description+lookupDeprecatedReason Directive {directiveArgs} =+  selectOr+    Nothing+    argumentStringValue+    ("reason" :: FieldName)+    directiveArgs++argumentStringValue :: Argument s -> Maybe Description+argumentStringValue Argument {argumentValue = Null} = Nothing+argumentStringValue Argument {argumentValue = (Scalar (String x))} = Just x+argumentStringValue _ = Just "can't read deprecated Reason Value"++instance ToCategory FieldDefinition a ANY where+  toCategory FieldDefinition {fieldContent, ..} = FieldDefinition {fieldContent = toAny <$> fieldContent, ..}++instance ToCategory (FieldContent TRUE) a ANY where+  toCategory (FieldArgs x) = FieldArgs x+  toCategory (DefaultInputValue x) = DefaultInputValue x++newtype Fields def = Fields+  {unFields :: OrdMap FieldName def}+  deriving+    ( Show,+      Lift,+      Functor,+      Foldable,+      Traversable+    )++deriving instance (KeyOf FieldName def) => Collection def (Fields def)++instance Merge (FieldsDefinition cat s) where+  merge path (Fields x) (Fields y) = Fields <$> merge path x y++instance Selectable FieldName (FieldDefinition cat s) (Fields (FieldDefinition cat s)) where+  selectOr fb f name (Fields lib) = selectOr fb f name lib++unsafeFromFields :: [FieldDefinition cat s] -> FieldsDefinition cat s+unsafeFromFields = Fields . unsafeFromValues++fieldsToArguments :: FieldsDefinition IN s -> ArgumentsDefinition s+fieldsToArguments = ArgumentsDefinition Nothing . unFields++instance (KeyOf FieldName def, NameCollision def) => Listable def (Fields def) where+  fromElems = fmap Fields . fromElems+  elems = elems . unFields++-- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects+------------------------------------------------------------------------------+--  ObjectTypeDefinition:+--    Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt)+--+--  ImplementsInterfaces+--    implements &(opt) NamedType+--    ImplementsInterfaces & NamedType+--+--  FieldsDefinition+--    { FieldDefinition(list) }+--+type FieldsDefinition cat s = Fields (FieldDefinition cat s)++--  FieldDefinition+--    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)+--+-- InputValueDefinition+--   Description(opt) Name: Type DefaultValue(opt) Directives[Const](opt)++data FieldDefinition (cat :: TypeCategory) (s :: Stage) = FieldDefinition+  { fieldName :: FieldName,+    fieldDescription :: Maybe Description,+    fieldType :: TypeRef,+    fieldDirectives :: [Directive s],+    fieldContent :: Maybe (FieldContent TRUE cat s)+  }+  deriving (Show, Lift)++data FieldContent (bool :: Bool) (cat :: TypeCategory) (s :: Stage) where+  DefaultInputValue ::+    { defaultInputValue :: Value s+    } ->+    FieldContent (ELEM IN cat) cat s+  FieldArgs ::+    { fieldArgsDef :: ArgumentsDefinition s+    } ->+    FieldContent (ELEM OUT cat) cat s++fieldContentArgs :: FieldContent b cat s -> ArgumentsDefinition s+fieldContentArgs (FieldArgs args) = args+fieldContentArgs _ = empty++deriving instance Show (FieldContent bool cat s)++deriving instance Lift (FieldContent bool cat s)++instance KeyOf FieldName (FieldDefinition cat s) where+  keyOf = fieldName++instance Selectable FieldName (ArgumentDefinition s) (FieldDefinition OUT s) where+  selectOr fb f key FieldDefinition {fieldContent = Just (FieldArgs args)} = selectOr fb f key args+  selectOr fb _ _ _ = fb++instance NameCollision (FieldDefinition cat s) where+  nameCollision FieldDefinition {fieldName} =+    "There can Be only One field Named " <> msgValidation fieldName++instance RenderGQL (FieldDefinition cat s) where+  render FieldDefinition {fieldName = FieldName name, fieldType, fieldContent = Just (FieldArgs args)} =+    name <> render args <> ": " <> render fieldType+  render FieldDefinition {fieldName, fieldType} =+    renderEntry fieldName fieldType++instance RenderGQL (FieldsDefinition cat s) where+  render = renderObject . filter fieldVisibility . elems++instance Nullable (FieldDefinition cat s) where+  isNullable = isNullable . fieldType+  toNullable field = field {fieldType = toNullable (fieldType field)}++fieldVisibility :: FieldDefinition cat s -> Bool+fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields++createField ::+  Maybe (FieldContent TRUE cat s) ->+  FieldName ->+  [TypeWrapper] ->+  TypeName ->+  FieldDefinition cat s+createField fieldContent fieldName typeWrappers typeConName =+  FieldDefinition+    { fieldName,+      fieldContent,+      fieldDescription = Nothing,+      fieldType = TypeRef {typeConName, typeWrappers, typeArgs = Nothing},+      fieldDirectives = []+    }++mkInputValue :: FieldName -> [TypeWrapper] -> TypeName -> FieldDefinition cat s+mkInputValue = createField Nothing++mkObjectField ::+  ArgumentsDefinition s ->+  FieldName ->+  [TypeWrapper] ->+  TypeName ->+  FieldDefinition OUT s+mkObjectField args = createField (Just $ FieldArgs args)++toListField :: FieldDefinition cat s -> FieldDefinition cat s+toListField dataField = dataField {fieldType = listW (fieldType dataField)}+  where+    listW alias@TypeRef {typeWrappers} =+      alias {typeWrappers = TypeList : typeWrappers}++-- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects+---------------------------------------------------------------------------+--- InputFieldsDefinition+-- { InputValueDefinition(list) }++type InputFieldsDefinition s = Fields (InputValueDefinition s)++type InputValueDefinition = FieldDefinition IN++-- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments+-----------------------------------------------------------------------------------------------+-- ArgumentsDefinition:+--   (InputValueDefinition(list))++data ArgumentsDefinition s = ArgumentsDefinition+  { argumentsTypename :: Maybe TypeName,+    arguments :: OrdMap FieldName (ArgumentDefinition s)+  }+  deriving (Show, Lift)++instance RenderGQL (ArgumentsDefinition s) where+  render ArgumentsDefinition {arguments} = renderArguments (elems arguments)++type ArgumentDefinition = FieldDefinition IN++instance Selectable FieldName (ArgumentDefinition s) (ArgumentsDefinition s) where+  selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args++instance Collection (ArgumentDefinition s) (ArgumentsDefinition s) where+  empty = ArgumentsDefinition Nothing empty+  singleton = ArgumentsDefinition Nothing . singleton++instance Listable (ArgumentDefinition s) (ArgumentsDefinition s) where+  elems (ArgumentsDefinition _ args) = elems args+  fromElems args = ArgumentsDefinition Nothing <$> fromElems args

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}@@ -9,19 +8,24 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST.MergeSet   ( MergeSet,-    toOrderedMap,+    toOrdMap,     concatTraverse,     join,   ) where -import Data.List ((\\), find)-import Data.Maybe (maybe) -- MORPHEUS +import Control.Applicative (Applicative (..))+import Control.Monad (Monad (..))+import Data.Foldable (Foldable (..))+import Data.Functor ((<$>), Functor (..))+import Data.List ((\\), find)+import Data.Maybe (maybe) import Data.Morpheus.Internal.Utils   ( (<:>),     Collection (..),@@ -33,19 +37,29 @@     elems,   ) import Data.Morpheus.Types.Internal.AST.Base-  ( FieldName,-    GQLErrors,-    RAW,-    Ref,+  ( Ref,+    ValidationErrors,+  )+import Data.Morpheus.Types.Internal.AST.OrdMap+  ( OrdMap (..),+  )+import qualified Data.Morpheus.Types.Internal.AST.OrdMap as OM+import Data.Morpheus.Types.Internal.AST.Stage+  ( RAW,     Stage,     VALID,   )-import Data.Morpheus.Types.Internal.AST.OrderedMap-  ( OrderedMap (..),-  )-import qualified Data.Morpheus.Types.Internal.AST.OrderedMap as OM-import Data.Semigroup ((<>))+import Data.Semigroup (Semigroup (..))+import Data.Traversable (Traversable (..)) import Language.Haskell.TH.Syntax (Lift (..))+import Prelude+  ( ($),+    (.),+    Eq (..),+    Show,+    flip,+    otherwise,+  )  -- set with mergeable components newtype MergeSet (dups :: Stage) a = MergeSet@@ -66,9 +80,9 @@     Eq b,     Merge a,     Merge b,-    KeyOf b,+    KeyOf k b,     Monad m,-    Failure GQLErrors m+    Failure ValidationErrors m   ) =>   (a -> m (MergeSet VALID b)) ->   MergeSet RAW a ->@@ -79,10 +93,10 @@  join ::   ( Eq a,-    KeyOf a,+    KeyOf k a,     Merge a,     Monad m,-    Failure GQLErrors m,+    Failure ValidationErrors m,     Listable a (MergeSet opt a),     Merge (MergeSet opt a)   ) =>@@ -93,16 +107,16 @@     __join acc [] = pure acc     __join acc (x : xs) = acc <:> x >>= (`__join` xs) -toOrderedMap :: (KEY a ~ FieldName, KeyOf a) => MergeSet opt a -> OrderedMap FieldName a-toOrderedMap = OM.unsafeFromValues . unpack+toOrdMap :: (KeyOf k a) => MergeSet opt a -> OrdMap k a+toOrdMap = OM.unsafeFromValues . unpack -instance (KeyOf a, k ~ KEY a) => Selectable (MergeSet opt a) a where+instance (KeyOf k a) => Selectable k a (MergeSet opt a) where   selectOr fb f key (MergeSet ls) = maybe fb f (find ((key ==) . keyOf) ls)  -- must merge files on collision  instance-  ( KeyOf a,+  ( KeyOf k a,     Listable a (MergeSet VALID a),     Merge a,     Eq a@@ -113,7 +127,7 @@  instance   ( Listable a (MergeSet VALID a),-    KeyOf a,+    KeyOf k a,     Merge a,     Eq a   ) =>@@ -129,17 +143,17 @@   fromElems = pure . MergeSet   elems = unpack -safeFromList :: (Monad m, KeyOf a, Eq a, Merge a, Failure GQLErrors m) => [a] -> m (MergeSet opt a)+safeFromList :: (Monad m, Eq a, KeyOf k a, Merge a, Failure ValidationErrors m) => [a] -> m (MergeSet opt a) safeFromList = insertList [] empty -safeJoin :: (Monad m, KeyOf a, Eq a, Listable a (MergeSet opt a), Merge a, Failure GQLErrors m) => [Ref] -> MergeSet opt a -> MergeSet opt a -> m (MergeSet opt a)+safeJoin :: (Monad m, KeyOf k a, Eq a, Listable a (MergeSet opt a), Merge a, Failure ValidationErrors m) => [Ref] -> MergeSet opt a -> MergeSet opt a -> m (MergeSet opt a) safeJoin path hm1 hm2 = insertList path hm1 (elems hm2) -insertList :: (Monad m, Eq a, KeyOf a, Merge a, Failure GQLErrors m) => [Ref] -> MergeSet opt a -> [a] -> m (MergeSet opt a)+insertList :: (Monad m, Eq a, KeyOf k a, Merge a, Failure ValidationErrors m) => [Ref] -> MergeSet opt a -> [a] -> m (MergeSet opt a) insertList _ smap [] = pure smap insertList path smap (x : xs) = insert path smap x >>= flip (insertList path) xs -insert :: (Monad m, Eq a, KeyOf a, Merge a, Failure GQLErrors m) => [Ref] -> MergeSet opt a -> a -> m (MergeSet opt a)+insert :: (Monad m, Eq a, KeyOf k a, Merge a, Failure ValidationErrors m) => [Ref] -> MergeSet opt a -> a -> m (MergeSet opt a) insert path mSet@(MergeSet ls) currentValue = MergeSet <$> __insert   where     __insert =

@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.Internal.AST.OrdMap+  ( OrdMap (..),+    unsafeFromValues,+  )+where++-- MORPHEUS+import Data.Foldable (Foldable (..))+import Data.Functor ((<$>), Functor (..))+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HM+import Data.Hashable (Hashable)+import Data.Maybe (fromMaybe, maybe)+import Data.Morpheus.Error.NameCollision (NameCollision (..))+import Data.Morpheus.Internal.Utils+  ( Collection (..),+    KeyOf (..),+    Listable (..),+    Merge (..),+    Selectable (..),+    toPair,+  )+import Data.Semigroup ((<>))+import Data.Traversable (Traversable (..))+import Language.Haskell.TH.Syntax (Lift (..))+import Prelude+  ( ($),+    (.),+    Eq,+    Show,+    error,+  )++-- OrdMap+data OrdMap k a = OrdMap+  { mapKeys :: [k],+    mapEntries :: HashMap k a+  }+  deriving+    ( Show,+      Eq,+      Functor+    )++instance (Lift a, Lift k, Eq k, Hashable k) => Lift (OrdMap k a) where+  lift (OrdMap names x) = [|OrdMap names (HM.fromList ls)|]+    where+      ls = HM.toList x++#if MIN_VERSION_template_haskell(2,16,0)+  liftTyped (OrdMap names x) = [||OrdMap names (HM.fromList ls)||]+    where+      ls = HM.toList x+#endif++instance (Eq k, Hashable k) => Foldable (OrdMap k) where+  foldMap f = foldMap f . getElements++getElements :: (Eq k, Hashable k) => OrdMap k b -> [b]+getElements OrdMap {mapKeys, mapEntries} = fmap takeValue mapKeys+  where+    takeValue key = fromMaybe (error "TODO: invalid Ordered Map") (key `HM.lookup` mapEntries)++instance (Eq k, Hashable k) => Traversable (OrdMap k) where+  traverse f (OrdMap names values) = OrdMap names <$> traverse f values++instance (KeyOf k a, Hashable k) => Collection a (OrdMap k a) where+  empty = OrdMap [] HM.empty+  singleton x = OrdMap [keyOf x] $ HM.singleton (keyOf x) x++instance (Eq k, Hashable k) => Selectable k a (OrdMap k a) where+  selectOr fb f key OrdMap {mapEntries} = maybe fb f (HM.lookup key mapEntries)++instance (NameCollision a, KeyOf k a) => Merge (OrdMap k a) where+  merge ref (OrdMap k1 x) (OrdMap k2 y) = OrdMap (k1 <> k2) <$> merge ref x y++instance (NameCollision a, KeyOf k a, Hashable k) => Listable a (OrdMap k a) where+  fromElems values = OrdMap (fmap keyOf values) <$> fromElems values+  elems = getElements++unsafeFromValues ::+  ( KeyOf k a,+    Hashable k+  ) =>+  [a] ->+  OrdMap k a+unsafeFromValues x = OrdMap (fmap keyOf x) $ HM.fromList $ fmap toPair x

@@ -1,122 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Types.Internal.AST.OrderedMap-  ( OrderedMap (..),-    unsafeFromValues,-  )-where--import Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HM-import Data.Hashable (Hashable)-import Data.Maybe (fromMaybe, isJust)--- MORPHEUS-import Data.Morpheus.Error.NameCollision (NameCollision (..))-import Data.Morpheus.Internal.Utils-  ( Collection (..),-    Failure (..),-    KeyOf (..),-    Listable (..),-    Merge (..),-    Selectable (..),-    toPair,-  )-import Data.Morpheus.Types.Internal.AST.Base-  ( GQLErrors,-  )-import Data.Semigroup ((<>))-import Language.Haskell.TH.Syntax (Lift (..))---- OrderedMap-data OrderedMap k a = OrderedMap-  { mapKeys :: [k],-    mapEntries :: HashMap k a-  }-  deriving (Show, Eq, Functor)--instance (Lift a, Lift k) => Lift (OrderedMap k a) where-  lift (OrderedMap names x) = [|OrderedMap names (HM.fromList ls)|]-    where-      ls = HM.toList x--instance (Eq k, Hashable k) => Foldable (OrderedMap k) where-  foldMap f = foldMap f . getElements--getElements :: (Eq k, Hashable k) => OrderedMap k b -> [b]-getElements OrderedMap {mapKeys, mapEntries} = map takeValue mapKeys-  where-    takeValue key = fromMaybe (error "TODO: invalid Ordered Map") (key `HM.lookup` mapEntries)--instance (Eq k, Hashable k) => Traversable (OrderedMap k) where-  traverse f (OrderedMap names values) = OrderedMap names <$> traverse f values--instance (KeyOf a, Hashable k, KEY a ~ k) => Collection a (OrderedMap k a) where-  empty = OrderedMap [] HM.empty-  singleton x = OrderedMap [keyOf x] $ HM.singleton (keyOf x) x--instance (Eq k, Hashable k, k ~ KEY a) => Selectable (OrderedMap k a) a where-  selectOr fb f key OrderedMap {mapEntries} = maybe fb f (HM.lookup key mapEntries)--instance (NameCollision a, Eq k, Hashable k, k ~ KEY a) => Merge (OrderedMap k a) where-  merge _ (OrderedMap k1 x) (OrderedMap k2 y) = OrderedMap (k1 <> k2) <$> safeJoin x y--instance (NameCollision a, Eq k, Hashable k, k ~ KEY a) => Listable a (OrderedMap k a) where-  fromElems = safeFromList-  elems = getElements--safeFromList ::-  ( Failure GQLErrors m,-    Applicative m,-    NameCollision a,-    Eq (KEY a),-    Hashable (KEY a),-    KeyOf a-  ) =>-  [a] ->-  m (OrderedMap (KEY a) a)-safeFromList values = OrderedMap (map keyOf values) <$> safeUnionWith HM.empty (map toPair values)--unsafeFromValues ::-  ( KeyOf a,-    Eq (KEY a),-    Hashable (KEY a)-  ) =>-  [a] ->-  OrderedMap (KEY a) a-unsafeFromValues x = OrderedMap (map keyOf x) $ HM.fromList $ fmap toPair x--safeJoin :: (Failure GQLErrors m, Eq k, Hashable k, KEY a ~ k, Applicative m, NameCollision a) => HashMap k a -> HashMap k a -> m (HashMap k a)-safeJoin hm newls = safeUnionWith hm (HM.toList newls)--safeUnionWith ::-  ( Failure GQLErrors m,-    Applicative m,-    Eq k,-    Hashable k,-    NameCollision a,-    KEY a ~ k-  ) =>-  HashMap k a ->-  [(k, a)] ->-  m (HashMap k a)-safeUnionWith hm names = case insertNoDups (hm, []) names of-  (res, dupps)-    | null dupps -> pure res-    | otherwise -> failure $ map (uncurry nameCollision) dupps--type NoDupHashMap k a = (HashMap k a, [(k, a)])--insertNoDups :: (Eq k, Hashable k) => NoDupHashMap k a -> [(k, a)] -> NoDupHashMap k a-insertNoDups collected [] = collected-insertNoDups (coll, errors) (pair@(name, value) : xs)-  | isJust (name `HM.lookup` coll) = insertNoDups (coll, errors <> [pair]) xs-  | otherwise = insertNoDups (HM.insert name value coll, errors) xs

@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.Internal.AST.SafeHashMap+  ( SafeHashMap,+    insert,+  )+where++-- MORPHEUS+import Control.Monad (Monad)+import Data.Foldable (Foldable (..))+import Data.Functor ((<$>), Functor (..))+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HM+import Data.Hashable (Hashable)+import Data.Morpheus.Error.NameCollision (NameCollision (..))+import Data.Morpheus.Internal.Utils+  ( (<:>),+    Collection (..),+    Failure (..),+    KeyOf (..),+    Listable (..),+    Merge (..),+    Selectable (..),+  )+import Data.Morpheus.Types.Internal.AST.Base (ValidationErrors)+import Data.Traversable (Traversable (..))+import Language.Haskell.TH.Syntax (Lift (..))+import Prelude+  ( (.),+    Eq,+    Show,+  )++newtype SafeHashMap k a = SafeHashMap+  { unpackSafeHashMap :: HashMap k a+  }+  deriving+    ( Show,+      Eq,+      Functor,+      Foldable,+      Traversable+    )+  deriving newtype+    ( Collection a,+      Selectable k a+    )++instance (Lift a, Lift k, Eq k, Hashable k) => Lift (SafeHashMap k a) where+  lift (SafeHashMap x) = let ls = HM.toList x in [|SafeHashMap (HM.fromList ls)|]++#if MIN_VERSION_template_haskell(2,16,0)+  liftTyped (SafeHashMap x) = let ls = HM.toList x in [||SafeHashMap (HM.fromList ls)||]+#endif++instance (NameCollision a, KeyOf k a) => Merge (SafeHashMap k a) where+  merge ref (SafeHashMap x) (SafeHashMap y) = SafeHashMap <$> merge ref x y++instance (NameCollision a, KeyOf k a, Hashable k) => Listable a (SafeHashMap k a) where+  fromElems = fmap SafeHashMap . fromElems+  elems = elems . unpackSafeHashMap++insert ::+  ( NameCollision a,+    KeyOf k a,+    Monad m,+    Failure ValidationErrors m+  ) =>+  a ->+  SafeHashMap k a ->+  m (SafeHashMap k a)+insert x = (<:> singleton x)

@@ -3,12 +3,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST.Selection   ( Selection (..),@@ -27,9 +29,10 @@   ) where -import Data.Maybe (fromMaybe, isJust)--- MORPHEUS-+import Control.Applicative (pure)+import Data.Foldable (all, foldr)+import Data.Functor ((<$>), fmap)+import Data.Maybe (Maybe (..), fromMaybe, isJust, maybe) import Data.Morpheus.Error.NameCollision   ( NameCollision (..),   )@@ -41,34 +44,50 @@   ( Failure (..),     KeyOf (..),     Merge (..),+    elems,   )+import Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+    Rendering,+    renderArguments,+    renderObject,+    space,+  ) import Data.Morpheus.Types.Internal.AST.Base   ( FieldName,-    GQLError (..),-    GQLErrors,     Message,+    Msg (..),     OperationType (..),     Position,-    RAW,     Ref (..),-    Stage,     TypeName (..),-    VALID,+    ValidationError (..),+    ValidationErrors,     intercalateName,     msg,+    msgValidation,     readName,   )+import Data.Morpheus.Types.Internal.AST.Fields+  ( Arguments,+    Directives,+  ) import Data.Morpheus.Types.Internal.AST.MergeSet   ( MergeSet,   )-import Data.Morpheus.Types.Internal.AST.OrderedMap-  ( OrderedMap,+import Data.Morpheus.Types.Internal.AST.OrdMap+  ( OrdMap,   )+import Data.Morpheus.Types.Internal.AST.Stage+  ( RAW,+    Stage,+    VALID,+  )+import Data.Morpheus.Types.Internal.AST.TypeCategory+  ( OBJECT,+  ) import Data.Morpheus.Types.Internal.AST.TypeSystem-  ( Arguments,-    Directives,-    OUT,-    Schema (..),+  ( Schema (..),     TypeDefinition (..),   ) import Data.Morpheus.Types.Internal.AST.Value@@ -78,34 +97,48 @@   ) import Data.Semigroup ((<>)) import Language.Haskell.TH.Syntax (Lift (..))+import Prelude+  ( ($),+    (.),+    Eq (..),+    Show (..),+    otherwise,+  ) -data Fragment = Fragment+data Fragment (stage :: Stage) = Fragment   { fragmentName :: FieldName,     fragmentType :: TypeName,     fragmentPosition :: Position,-    fragmentSelection :: SelectionSet RAW,-    fragmentDirectives :: Directives RAW+    fragmentSelection :: SelectionSet stage,+    fragmentDirectives :: Directives stage   }   deriving (Show, Eq, Lift)  -- ERRORs-instance NameCollision Fragment where-  nameCollision _ Fragment {fragmentName, fragmentPosition} =-    GQLError-      { message = "There can be only one fragment named " <> msg fragmentName <> ".",-        locations = [fragmentPosition]-      }+instance NameCollision (Fragment s) where+  nameCollision Fragment {fragmentName, fragmentPosition} =+    ValidationError+      ("There can be only one fragment named " <> msg fragmentName <> ".")+      [fragmentPosition] -instance KeyOf Fragment where+instance KeyOf FieldName (Fragment s) where   keyOf = fragmentName -type Fragments = OrderedMap FieldName Fragment+type Fragments (s :: Stage) = OrdMap FieldName (Fragment s)  data SelectionContent (s :: Stage) where   SelectionField :: SelectionContent s   SelectionSet :: SelectionSet s -> SelectionContent s   UnionSelection :: UnionSelection VALID -> SelectionContent VALID +renderSelectionSet :: SelectionSet VALID -> Rendering+renderSelectionSet = renderObject . elems++instance RenderGQL (SelectionContent VALID) where+  render SelectionField = ""+  render (SelectionSet selSet) = renderSelectionSet selSet+  render (UnionSelection unionSets) = renderObject (elems unionSets)+ instance   Merge (SelectionSet s) =>   Merge (SelectionContent s)@@ -116,9 +149,9 @@     | oldC == currC = pure oldC     | otherwise =       failure-        [ GQLError-            { message = msg (intercalateName "." $ map refName path),-              locations = map refPosition path+        [ ValidationError+            { validationMessage = msg (intercalateName "." $ fmap refName path),+              validationLocations = fmap refPosition path             }         ] @@ -134,12 +167,22 @@   }   deriving (Show, Eq, Lift) -mergeConflict :: [Ref] -> GQLError -> GQLErrors+instance KeyOf TypeName UnionTag where+  keyOf = unionTagName++instance RenderGQL UnionTag where+  render UnionTag {unionTagName, unionTagSelection} =+    "... on "+      <> render unionTagName+      <> space+      <> renderSelectionSet unionTagSelection++mergeConflict :: [Ref] -> ValidationError -> ValidationErrors mergeConflict [] err = [err] mergeConflict refs@(rootField : xs) err =-  [ GQLError-      { message = renderSubfields <> message err,-        locations = map refPosition refs <> locations err+  [ ValidationError+      { validationMessage = renderSubfields <> validationMessage err,+        validationLocations = fmap refPosition refs <> validationLocations err       }   ]   where@@ -156,10 +199,6 @@   merge path (UnionTag oldTag oldSel) (UnionTag _ currentSel) =     UnionTag oldTag <$> merge path oldSel currentSel -instance KeyOf UnionTag where-  type KEY UnionTag = TypeName-  keyOf = unionTagName- type UnionSelection (s :: Stage) = MergeSet s UnionTag  type SelectionSet (s :: Stage) = MergeSet s (Selection s)@@ -174,10 +213,19 @@       selectionDirectives :: Directives s     } ->     Selection s-  InlineFragment :: Fragment -> Selection RAW+  InlineFragment :: Fragment RAW -> Selection RAW   Spread :: Directives RAW -> Ref -> Selection RAW -instance KeyOf (Selection s) where+instance RenderGQL (Selection VALID) where+  render+    Selection+      { ..+      } =+      render (fromMaybe selectionName selectionAlias)+        <> renderArguments (elems selectionArguments)+        <> render selectionContent++instance KeyOf FieldName (Selection s) where   keyOf     Selection       { selectionName,@@ -223,12 +271,12 @@           | selectionName old == selectionName current = pure $ selectionName current           | otherwise =             failure $ mergeConflict path $-              GQLError-                { message =+              ValidationError+                { validationMessage =                     "" <> msg (selectionName old) <> " and " <> msg (selectionName current)                       <> " are different fields. "                       <> useDufferentAliases,-                  locations = [pos1, pos2]+                  validationLocations = [pos1, pos2]                 }         ---------------------         -- allias name is relevant only if they collide by allias like:@@ -243,16 +291,15 @@           | selectionArguments old == selectionArguments current = pure $ selectionArguments current           | otherwise =             failure $ mergeConflict currentPath $-              GQLError-                { message = "they have differing arguments. " <> useDufferentAliases,-                  locations = [pos1, pos2]+              ValidationError+                { validationMessage = "they have differing arguments. " <> useDufferentAliases,+                  validationLocations = [pos1, pos2]                 }   merge path _ _ =-    failure $ mergeConflict path $-      GQLError-        { message = "INTERNAL: can't merge. " <> useDufferentAliases,-          locations = []-        }+    failure $+      mergeConflict+        path+        ("INTERNAL: can't merge. " <> msgValidation useDufferentAliases :: ValidationError)  deriving instance Show (Selection a) @@ -272,16 +319,25 @@   }   deriving (Show, Lift) +instance RenderGQL (Operation VALID) where+  render+    Operation+      { operationName,+        operationType,+        operationSelection+      } =+      render operationType+        <> space+        <> render operationName+        <> space+        <> renderSelectionSet operationSelection+ getOperationName :: Maybe FieldName -> TypeName getOperationName = maybe "AnonymousOperation" (TypeName . readName) -getOperationDataType :: Failure GQLErrors m => Operation a -> Schema -> m (TypeDefinition OUT)+getOperationDataType :: Failure ValidationError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID) getOperationDataType Operation {operationType = Query} lib = pure (query lib) getOperationDataType Operation {operationType = Mutation, operationPosition} lib =-  case mutation lib of-    Just x -> pure x-    Nothing -> failure $ mutationIsNotDefined operationPosition+  maybe (failure $ mutationIsNotDefined operationPosition) pure (mutation lib) getOperationDataType Operation {operationType = Subscription, operationPosition} lib =-  case subscription lib of-    Just x -> pure x-    Nothing -> failure $ subscriptionIsNotDefined operationPosition+  maybe (failure $ subscriptionIsNotDefined operationPosition) pure (subscription lib)

@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.Internal.AST.Stage+  ( CONST,+    VALID,+    RAW,+    Stage (..),+    CONST_OR_VALID,+  )+where++type CONST = 'CONST++type VALID = 'VALID++type RAW = 'RAW++data Stage+  = RAW+  | CONST+  | VALID++type family CONST_OR_VALID (a :: Stage) :: Stage++type instance CONST_OR_VALID RAW = CONST++type instance CONST_OR_VALID CONST = CONST++type instance CONST_OR_VALID VALID = VALID

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST.TH   ( ConsD (..),@@ -17,13 +18,23 @@     TypeRef (..),     hsTypeName,   )+import Data.Morpheus.Types.Internal.AST.Fields+  ( FieldDefinition (..),+    FieldsDefinition,+  ) import Data.Morpheus.Types.Internal.AST.TypeSystem   ( DataEnumValue (..),-    FieldDefinition (..),-    FieldsDefinition,   )+import Prelude+  ( (.),+    Bool (..),+    Show,+    all,+    fmap,+    null,+  ) -toHSFieldDefinition :: FieldDefinition cat -> FieldDefinition cat+toHSFieldDefinition :: FieldDefinition cat s -> FieldDefinition cat s toHSFieldDefinition field@FieldDefinition {fieldType = tyRef@TypeRef {typeConName}} =   field     { fieldType = tyRef {typeConName = hsTypeName typeConName}@@ -37,21 +48,21 @@  -- Template Haskell Types -data ConsD cat = ConsD+data ConsD cat s = ConsD   { cName :: TypeName,-    cFields :: [FieldDefinition cat]+    cFields :: [FieldDefinition cat s]   }   deriving (Show) -mkCons :: TypeName -> FieldsDefinition cat -> ConsD cat+mkCons :: TypeName -> FieldsDefinition cat s -> ConsD cat s mkCons typename fields =   ConsD     { cName = hsTypeName typename,-      cFields = map toHSFieldDefinition (elems fields)+      cFields = fmap toHSFieldDefinition (elems fields)     } -isEnum :: [ConsD cat] -> Bool+isEnum :: [ConsD cat s] -> Bool isEnum = all (null . cFields) -mkConsEnum :: DataEnumValue -> ConsD cat+mkConsEnum :: DataEnumValue s -> ConsD cat s mkConsEnum DataEnumValue {enumName} = ConsD {cName = hsTypeName enumName, cFields = []}

@@ -0,0 +1,133 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.Internal.AST.TypeCategory+  ( TypeCategory,+    ELEM,+    OUT,+    IN,+    ANY,+    LEAF,+    OBJECT,+    IMPLEMENTABLE,+    fromAny,+    toAny,+    REQURE_IMPLEMENTABLE,+    ToCategory (..),+    FromCategory (..),+  )+where++import Data.Maybe (Maybe (..))+import Data.Morpheus.Types.Internal.AST.Base+  ( FALSE,+    TRUE,+  )+import Data.Morpheus.Types.Internal.AST.Stage (Stage)+import Prelude (Bool (..))++data TypeCategory+  = IN+  | OUT+  | ANY+  | LEAF+  | OBJECT+  | IMPLEMENTABLE++type IN = 'IN++type OUT = 'OUT++type ANY = 'ANY++type OBJECT = 'OBJECT++type IMPLEMENTABLE = 'IMPLEMENTABLE++type LEAF = 'LEAF++toAny ::+  (ToCategory a k ANY) =>+  a (k :: TypeCategory) (s :: Stage) ->+  a ANY s+toAny = toCategory++fromAny ::+  (FromCategory a ANY k) =>+  a ANY (s :: Stage) ->+  Maybe (a k s)+fromAny = fromCategory++class ToCategory a (k :: TypeCategory) (k' :: TypeCategory) where+  toCategory :: a k (s :: Stage) -> a k' s++class FromCategory a (k :: TypeCategory) (k' :: TypeCategory) where+  fromCategory :: a k (s :: Stage) -> Maybe (a k' s)++type family+  ELEM+    (elemKind :: TypeCategory)+    (setOfKind :: TypeCategory) ::+    Bool++type REQURE_IMPLEMENTABLE cat = ELEM cat IMPLEMENTABLE ~ TRUE++-- ANY+type instance ELEM ANY a = TRUE++type instance ELEM a ANY = TRUE++-- LEAF+type instance ELEM LEAF LEAF = TRUE++type instance ELEM LEAF IN = TRUE++type instance ELEM LEAF OUT = TRUE++type instance ELEM LEAF OBJECT = FALSE++type instance ELEM LEAF IMPLEMENTABLE = FALSE++-- IN+type instance ELEM IN IN = TRUE++type instance ELEM IN OUT = FALSE++type instance ELEM IN OBJECT = FALSE++type instance ELEM IN IMPLEMENTABLE = FALSE++-- OUT+type instance ELEM OUT OUT = TRUE++type instance ELEM OUT IN = FALSE++type instance ELEM OUT OBJECT = FALSE++type instance ELEM OUT IMPLEMENTABLE = FALSE++-- IMPLEMENTABLE+type instance ELEM IMPLEMENTABLE IMPLEMENTABLE = TRUE++type instance ELEM IMPLEMENTABLE OUT = TRUE++type instance ELEM IMPLEMENTABLE IN = FALSE++type instance ELEM IMPLEMENTABLE LEAF = FALSE++type instance ELEM IMPLEMENTABLE OBJECT = FALSE++-- OUTPUT_OBJECT+type instance ELEM OBJECT OBJECT = TRUE++type instance ELEM OBJECT IMPLEMENTABLE = TRUE++type instance ELEM OBJECT OUT = TRUE++type instance ELEM OBJECT IN = FALSE++type instance ELEM OBJECT LEAF = FALSE

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DeriveTraversable #-}@@ -16,164 +17,195 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST.TypeSystem-  ( Arguments,-    ScalarDefinition (..),+  ( ScalarDefinition (..),     DataEnum,-    FieldsDefinition,-    ArgumentDefinition,     DataUnion,-    ArgumentsDefinition (..),-    FieldDefinition (..),-    InputFieldsDefinition,     TypeContent (..),     TypeDefinition (..),     Schema (..),     DataEnumValue (..),     TypeLib,-    Directive (..),-    TypeUpdater,     TypeCategory,     DataInputUnion,-    Argument (..),-    Fields (..),-    createField,-    createArgument,-    createEnumType,+    mkEnumContent,+    mkUnionContent,+    mkType,     createScalarType,-    createType,-    createUnionType,-    createAlias,-    createInputUnionFields,-    createEnumValue,-    defineType,-    isTypeDefined,+    mkInputUnionFields,     initTypeLib,-    isFieldNullable,     insertType,-    fieldVisibility,     kindOf,-    toNullableField,-    toListField,     isEntNode,-    lookupDeprecated,-    lookupDeprecatedReason,     lookupWith,-    unsafeFromFields,     __inputname,     updateSchema,-    OUT,-    IN,-    ANY,-    FromAny (..),-    ToAny (..),-    DirectiveDefinitions,-    DirectiveDefinition (..),-    Directives,-    fieldsToArguments,-    FieldContent (..),-    fieldContentArgs,-    mkField,-    mkObjectField,     UnionMember (..),     mkUnionMember,+    RawTypeDefinition (..),+    RootOperationTypeDefinition (..),+    SchemaDefinition (..),+    buildSchema,+    Typed (Typed),+    untyped,+    typed,+    possibleTypes,+    possibleInterfaceTypes,   ) where -import Data.HashMap.Lazy-  ( HashMap,-    union,-  )-import qualified Data.HashMap.Lazy as HM-import Data.List (find) -- MORPHEUS -import Data.Morpheus.Error (globalErrorMessage)+import Control.Applicative ((<|>), Applicative (..))+import Control.Monad (Monad (..), foldM)+import Data.Either (Either (..))+import Data.Foldable (concatMap)+import Data.Functor ((<$>), fmap)+import Data.List (elem, filter, find, notElem)+import Data.Maybe (Maybe (..), catMaybes, mapMaybe, maybe) import Data.Morpheus.Error.NameCollision   ( NameCollision (..),   ) import Data.Morpheus.Error.Schema (nameCollisionError) import Data.Morpheus.Internal.Utils-  ( Collection (..),+  ( (<:>),+    Collection (..),+    Failure (..),     KeyOf (..),     Listable (..),     Merge (..),     Selectable (..),+    UpdateT (..),+    concatUpdates,     elems,+    resolveUpdates,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),-    renderIndent,+    newline,+    renderMembers,     renderObject,   ) import Data.Morpheus.Types.Internal.AST.Base   ( DataFingerprint (..),     Description,-    FALSE,     FieldName,     FieldName (..),-    GQLError (..),     Msg (..),-    Position,-    RESOLVED,-    Stage,+    OperationType (..),     TRUE,     Token,     TypeKind (..),     TypeName,     TypeRef (..),     TypeWrapper (..),-    VALID,-    isNullable,-    isSystemTypeName,+    ValidationError,+    ValidationErrors,+    isNotSystemTypeName,+    mkTypeRef,     msg,-    sysFields,+    msgValidation,     toFieldName,     toOperationType,   )-import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation)-import Data.Morpheus.Types.Internal.AST.OrderedMap-  ( OrderedMap,-    unsafeFromValues,+import Data.Morpheus.Types.Internal.AST.Fields+  ( Directive,+    DirectiveDefinition (..),+    Directives,+    FieldDefinition (..),+    FieldsDefinition,+    unsafeFromFields,   )-import Data.Morpheus.Types.Internal.AST.Value-  ( ScalarValue (..),-    ValidValue,-    Value (..),+import Data.Morpheus.Types.Internal.AST.OrdMap+  ( OrdMap,   )-import Data.Morpheus.Types.Internal.Resolving.Core-  ( Failure (..),-    LibUpdater,-    resolveUpdates,+import Data.Morpheus.Types.Internal.AST.SafeHashMap+  ( SafeHashMap,+    insert,   )+import Data.Morpheus.Types.Internal.AST.Stage+  ( CONST,+    Stage,+    VALID,+  )+import Data.Morpheus.Types.Internal.AST.TypeCategory+  ( ANY,+    ELEM,+    FromCategory (..),+    IMPLEMENTABLE,+    IN,+    LEAF,+    OBJECT,+    OUT,+    ToCategory (..),+    TypeCategory,+    fromAny,+    toAny,+  )+import Data.Morpheus.Types.Internal.AST.Value+  ( Value (..),+  ) import Data.Semigroup (Semigroup (..)) import Data.Text (intercalate) import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift (..))+import Prelude+  ( ($),+    (.),+    Bool (..),+    Eq (..),+    Show (..),+    const,+    flip,+    otherwise,+  ) -type DataEnum = [DataEnumValue]+type DataEnum s = [DataEnumValue s] -mkUnionMember :: TypeName -> UnionMember cat+-- used for perserving type information from untyped values+-- e.g+-- unionType :: UnionMember IN VALID -> Typed IN VALID TypeName+-- unionType = typed memberName+typed :: (a c s -> b) -> a c s -> Typed c s b+typed f = Typed . f++untyped :: (a -> b) -> Typed c s a -> b+untyped f = f . _untyped++-- | used for perserving type information from untyped values+-- see function typed+newtype Typed (cat :: TypeCategory) (s :: Stage) a = Typed+  { _untyped :: a+  }++mkUnionMember :: TypeName -> UnionMember cat s mkUnionMember name = UnionMember name True -data UnionMember (cat :: TypeCategory) = UnionMember+data UnionMember (cat :: TypeCategory) (s :: Stage) = UnionMember   { memberName :: TypeName,     visibility :: Bool   }   deriving (Show, Lift, Eq) -type DataUnion = [UnionMember OUT]+type DataUnion s = [UnionMember OUT s] -type DataInputUnion = [UnionMember IN]+type DataInputUnion s = [UnionMember IN s] -instance RenderGQL (UnionMember cat) where+instance RenderGQL (UnionMember cat s) where   render = render . memberName +instance Msg (UnionMember cat s) where+  msg = msg . memberName++instance KeyOf TypeName (UnionMember cat s) where+  keyOf = memberName+ -- scalar ------------------------------------------------------------------ newtype ScalarDefinition = ScalarDefinition-  {validateValue :: ValidValue -> Either Token ValidValue}+  {validateValue :: Value VALID -> Either Token (Value VALID)}  instance Show ScalarDefinition where   show _ = "ScalarDefinition"@@ -181,79 +213,19 @@ instance Lift ScalarDefinition where   lift _ = [|ScalarDefinition pure|] -data Argument (valid :: Stage) = Argument-  { argumentName :: FieldName,-    argumentValue :: Value valid,-    argumentPosition :: Position-  }-  deriving (Show, Eq, Lift)--instance KeyOf (Argument stage) where-  keyOf = argumentName--instance NameCollision (Argument s) where-  nameCollision _ Argument {argumentName, argumentPosition} =-    GQLError-      { message = "There can Be only One Argument Named " <> msg argumentName,-        locations = [argumentPosition]-      }--type Arguments s = OrderedMap FieldName (Argument s)---- directive--------------------------------------------------------------------data Directive (s :: Stage) = Directive-  { directiveName :: FieldName,-    directivePosition :: Position,-    directiveArgs :: Arguments s-  }-  deriving (Show, Lift, Eq)--instance KeyOf (Directive s) where-  keyOf = directiveName--type Directives s = [Directive s]--data DirectiveDefinition = DirectiveDefinition-  { directiveDefinitionName :: FieldName,-    directiveDefinitionDescription :: Maybe Description,-    directiveDefinitionLocations :: [DirectiveLocation],-    directiveDefinitionArgs :: ArgumentsDefinition-  }-  deriving (Show, Lift)--type DirectiveDefinitions = [DirectiveDefinition]--instance KeyOf DirectiveDefinition where-  keyOf = directiveDefinitionName--instance Selectable DirectiveDefinition ArgumentDefinition where-  selectOr fb f key DirectiveDefinition {directiveDefinitionArgs} =-    selectOr fb f key directiveDefinitionArgs--lookupDeprecated :: [Directive VALID] -> Maybe (Directive VALID)-lookupDeprecated = find isDeprecation-  where-    isDeprecation Directive {directiveName = "deprecated"} = True-    isDeprecation _ = False--lookupDeprecatedReason :: Directive VALID -> Maybe Description-lookupDeprecatedReason Directive {directiveArgs} =-  selectOr Nothing (Just . maybeString) "reason" directiveArgs-  where-    maybeString :: Argument VALID -> Description-    maybeString Argument {argumentValue = (Scalar (String x))} = x-    maybeString _ = "can't read deprecated Reason Value"+#if MIN_VERSION_template_haskell(2,16,0)+  liftTyped _ = [||ScalarDefinition pure||]+#endif  -- ENUM VALUE-data DataEnumValue = DataEnumValue+data DataEnumValue s = DataEnumValue   { enumName :: TypeName,     enumDescription :: Maybe Description,-    enumDirectives :: [Directive VALID]+    enumDirectives :: [Directive s]   }   deriving (Show, Lift) -instance RenderGQL DataEnumValue where+instance RenderGQL (DataEnumValue s) where   render DataEnumValue {enumName} = render enumName  -- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema@@ -264,47 +236,195 @@ -- RootOperationTypeDefinition : --    OperationType: NamedType -data Schema = Schema-  { types :: TypeLib,-    query :: TypeDefinition 'Out,-    mutation :: Maybe (TypeDefinition 'Out),-    subscription :: Maybe (TypeDefinition 'Out)+data Schema (s :: Stage) = Schema+  { types :: TypeLib s,+    query :: TypeDefinition OBJECT s,+    mutation :: Maybe (TypeDefinition OBJECT s),+    subscription :: Maybe (TypeDefinition OBJECT s),+    directiveDefinitions :: [DirectiveDefinition s]   }+  deriving (Show, Lift)++instance Merge (Schema s) where+  merge _ s1 s2 =+    Schema+      <$> (types s1 <:> types s2)+      <*> mergeOperation (query s1) (query s2)+      <*> mergeOptional (mutation s1) (mutation s2)+      <*> mergeOptional (subscription s1) (subscription s2)+      <*> pure (directiveDefinitions s1 <> directiveDefinitions s2)++mergeOptional ::+  (Monad m, Failure ValidationErrors m) =>+  Maybe (TypeDefinition OBJECT s) ->+  Maybe (TypeDefinition OBJECT s) ->+  m (Maybe (TypeDefinition OBJECT s))+mergeOptional Nothing y = pure y+mergeOptional (Just x) Nothing = pure (Just x)+mergeOptional (Just x) (Just y) = Just <$> mergeOperation x y++mergeOperation ::+  (Monad m, Failure ValidationErrors m) =>+  TypeDefinition OBJECT s ->+  TypeDefinition OBJECT s ->+  m (TypeDefinition OBJECT s)+mergeOperation+  TypeDefinition {typeContent = DataObject i1 fields1}+  TypeDefinition {typeContent = DataObject i2 fields2, ..} =+    do+      fields <- fields1 <:> fields2+      pure $ TypeDefinition {typeContent = DataObject (i1 <> i2) fields, ..}++data SchemaDefinition = SchemaDefinition+  { schemaDirectives :: Directives CONST,+    unSchemaDefinition :: OrdMap OperationType RootOperationTypeDefinition+  }   deriving (Show) -type TypeLib = HashMap TypeName (TypeDefinition ANY)+instance Selectable OperationType RootOperationTypeDefinition SchemaDefinition where+  selectOr fallback f key SchemaDefinition {unSchemaDefinition} =+    selectOr fallback f key unSchemaDefinition -instance Selectable Schema (TypeDefinition ANY) where+instance NameCollision SchemaDefinition where+  nameCollision _ = "There can Be only One SchemaDefinition."++instance KeyOf TypeName SchemaDefinition where+  keyOf _ = "schema"++data RawTypeDefinition+  = RawSchemaDefinition SchemaDefinition+  | RawTypeDefinition (TypeDefinition ANY CONST)+  | RawDirectiveDefinition (DirectiveDefinition CONST)+  deriving (Show)++data RootOperationTypeDefinition = RootOperationTypeDefinition+  { rootOperationType :: OperationType,+    rootOperationTypeDefinitionName :: TypeName+  }+  deriving (Show, Eq)++instance NameCollision RootOperationTypeDefinition where+  nameCollision RootOperationTypeDefinition {rootOperationType} =+    "There can Be only One TypeDefinition for schema." <> msgValidation rootOperationType++instance KeyOf OperationType RootOperationTypeDefinition where+  keyOf = rootOperationType++type TypeLib s = SafeHashMap TypeName (TypeDefinition ANY s)++instance Selectable TypeName (TypeDefinition ANY s) (Schema s) where   selectOr fb f name lib = maybe fb f (lookupDataType name lib) -instance Listable (TypeDefinition ANY) Schema where-  elems = HM.elems . typeRegister-  fromElems types = case popByKey "Query" types of-    (Nothing, _) -> failure (globalErrorMessage "INTERNAL: Query Not Defined")-    (Just query, lib1) -> do-      let (mutation, lib2) = popByKey "Mutation" lib1-      let (subscription, lib3) = popByKey "Subscription" lib2-      pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription}+instance Listable (TypeDefinition ANY s) (Schema s) where+  elems Schema {..} =+    elems types+      <> concatMap fromOperation [Just query, mutation, subscription]+  fromElems types =+    traverse3+      (popByKey types)+      ( RootOperationTypeDefinition Query "Query",+        RootOperationTypeDefinition Mutation "Mutation",+        RootOperationTypeDefinition Subscription "Subscription"+      )+      >>= buildWith types -initTypeLib :: TypeDefinition 'Out -> Schema+buildWith ::+  ( Monad f,+    Failure ValidationErrors f+  ) =>+  [TypeDefinition cat s] ->+  ( Maybe (TypeDefinition OBJECT s),+    Maybe (TypeDefinition OBJECT s),+    Maybe (TypeDefinition OBJECT s)+  ) ->+  f (Schema s)+buildWith otypes (Just query, mutation, subscription) = do+  let types = excludeTypes [Just query, mutation, subscription] otypes+  let schema = (initTypeLib query) {mutation, subscription}+  foldM (flip safeDefineType) schema types+buildWith _ (Nothing, _, _) = failure ["Query root type must be provided." :: ValidationError]++excludeTypes :: [Maybe (TypeDefinition c1 s)] -> [TypeDefinition c2 s] -> [TypeDefinition c2 s]+excludeTypes excusionTypes = filter ((`notElem` blacklist) . typeName)+  where+    blacklist :: [TypeName]+    blacklist = fmap typeName (catMaybes excusionTypes)++withDirectives ::+  [DirectiveDefinition s] ->+  Schema s ->+  Schema s+withDirectives dirs Schema {..} =+  Schema+    { directiveDefinitions = directiveDefinitions <> dirs,+      ..+    }++buildSchema ::+  (Monad m, Failure ValidationErrors m) =>+  ( Maybe SchemaDefinition,+    [TypeDefinition ANY s],+    [DirectiveDefinition s]+  ) ->+  m (Schema s)+buildSchema (Nothing, types, dirs) = withDirectives dirs <$> fromElems types+buildSchema (Just schemaDef, types, dirs) =+  withDirectives+    dirs+    <$> ( traverse3 selectOp (Query, Mutation, Subscription)+            >>= buildWith types+        )+  where+    selectOp op = selectOperation schemaDef op types++traverse3 :: Applicative t => (a -> t b) -> (a, a, a) -> t (b, b, b)+traverse3 f (a1, a2, a3) = (,,) <$> f a1 <*> f a2 <*> f a3++typeReference ::+  (Monad m, Failure ValidationErrors m) =>+  [TypeDefinition ANY s] ->+  RootOperationTypeDefinition ->+  m (Maybe (TypeDefinition OBJECT s))+typeReference types rootOperation =+  popByKey types rootOperation+    >>= maybe+      (failure ["Unknown type " <> msgValidation (rootOperationTypeDefinitionName rootOperation) <> "."])+      (pure . Just)++selectOperation ::+  ( Monad f,+    Failure ValidationErrors f+  ) =>+  SchemaDefinition ->+  OperationType ->+  [TypeDefinition ANY s] ->+  f (Maybe (TypeDefinition OBJECT s))+selectOperation schemaDef operationType lib =+  selectOr (pure Nothing) (typeReference lib) operationType schemaDef++initTypeLib :: TypeDefinition OBJECT s -> Schema s initTypeLib query =   Schema     { types = empty,       query = query,       mutation = Nothing,-      subscription = Nothing+      subscription = Nothing,+      directiveDefinitions = empty     } -typeRegister :: Schema -> TypeLib-typeRegister Schema {types, query, mutation, subscription} =-  types-    `union` HM.fromList-      (concatMap fromOperation [Just query, mutation, subscription])+isType :: TypeName -> TypeDefinition OBJECT s -> Maybe (TypeDefinition ANY s)+isType name x+  | name == typeName x = Just (toAny x)+  | otherwise = Nothing -lookupDataType :: TypeName -> Schema -> Maybe (TypeDefinition ANY)-lookupDataType name = HM.lookup name . typeRegister+lookupDataType :: TypeName -> Schema s -> Maybe (TypeDefinition ANY s)+lookupDataType name Schema {types, query, mutation, subscription} =+  isType name query+    <|> (mutation >>= isType name)+    <|> (subscription >>= isType name)+    <|> selectOr Nothing Just name types -isTypeDefined :: TypeName -> Schema -> Maybe DataFingerprint+isTypeDefined :: TypeName -> Schema s -> Maybe DataFingerprint isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib  -- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types@@ -317,123 +437,142 @@ --   EnumTypeDefinition --   InputObjectTypeDefinition -data TypeDefinition (a :: TypeCategory) = TypeDefinition+data TypeDefinition (a :: TypeCategory) (s :: Stage) = TypeDefinition   { typeName :: TypeName,     typeFingerprint :: DataFingerprint,     typeDescription :: Maybe Description,-    typeDirectives :: Directives VALID,-    typeContent :: TypeContent TRUE a+    typeDirectives :: Directives s,+    typeContent :: TypeContent TRUE a s   }   deriving (Show, Lift) -instance KeyOf (TypeDefinition a) where-  type KEY (TypeDefinition a) = TypeName+instance KeyOf TypeName (TypeDefinition a s) where   keyOf = typeName -data TypeCategory = In | Out | Any--type IN = 'In--type OUT = 'Out--type ANY = 'Any--class ToAny a where-  toAny :: a (k :: TypeCategory) -> a ANY--instance ToAny TypeDefinition where-  toAny TypeDefinition {typeContent, ..} = TypeDefinition {typeContent = toAny typeContent, ..}+instance NameCollision (TypeDefinition cat s) where+  nameCollision x = "There can Be only One TypeDefinition Named " <> msgValidation (typeName x) <> "." -instance ToAny (TypeContent TRUE) where-  toAny DataScalar {..} = DataScalar {..}-  toAny DataEnum {..} = DataEnum {..}-  toAny DataInputObject {..} = DataInputObject {..}-  toAny DataInputUnion {..} = DataInputUnion {..}-  toAny DataObject {..} = DataObject {..}-  toAny DataUnion {..} = DataUnion {..}-  toAny DataInterface {..} = DataInterface {..}+instance+  ToCategory (TypeContent TRUE) cat cat' =>+  ToCategory TypeDefinition cat cat'+  where+  toCategory TypeDefinition {typeContent, ..} =+    TypeDefinition+      { typeContent = toCategory typeContent,+        ..+      } -instance ToAny FieldDefinition where-  toAny FieldDefinition {fieldContent, ..} = FieldDefinition {fieldContent = toAny <$> fieldContent, ..}+possibleTypes :: TypeDefinition a s -> Schema s' -> [TypeName]+possibleTypes+  TypeDefinition+    { typeName,+      typeContent = DataObject {objectImplements}+    }+  _ = typeName : objectImplements+possibleTypes TypeDefinition {typeName = name, typeContent = DataInterface {}} schema =+  name : fmap typeName (possibleInterfaceTypes name schema)+possibleTypes TypeDefinition {typeName} _ = [typeName] -instance ToAny (FieldContent TRUE) where-  toAny (FieldArgs x) = FieldArgs x-  toAny (DefaultInputValue x) = DefaultInputValue x+possibleInterfaceTypes ::+  TypeName ->+  Schema s ->+  [TypeDefinition ANY s]+possibleInterfaceTypes name schema = mapMaybe (isPosibleInterfaceType name) (elems schema) -class FromAny a (k :: TypeCategory) where-  fromAny :: a ANY -> Maybe (a k)+isPosibleInterfaceType ::+  TypeName ->+  TypeDefinition c s ->+  Maybe (TypeDefinition c s)+isPosibleInterfaceType name typeDef@TypeDefinition {typeName, typeContent = DataObject {objectImplements}}+  | name `elem` (typeName : objectImplements) = Just typeDef+isPosibleInterfaceType _ _ = Nothing -instance (FromAny (TypeContent TRUE) a) => FromAny TypeDefinition a where-  fromAny TypeDefinition {typeContent, ..} = bla <$> fromAny typeContent+instance+  (FromCategory (TypeContent TRUE) cat cat') =>+  FromCategory TypeDefinition cat cat'+  where+  fromCategory TypeDefinition {typeContent, ..} = bla <$> fromCategory typeContent     where       bla x = TypeDefinition {typeContent = x, ..} -instance FromAny (TypeContent TRUE) IN where-  fromAny DataScalar {..} = Just DataScalar {..}-  fromAny DataEnum {..} = Just DataEnum {..}-  fromAny DataInputObject {..} = Just DataInputObject {..}-  fromAny DataInputUnion {..} = Just DataInputUnion {..}-  fromAny _ = Nothing--instance FromAny (TypeContent TRUE) OUT where-  fromAny DataScalar {..} = Just DataScalar {..}-  fromAny DataEnum {..} = Just DataEnum {..}-  fromAny DataObject {..} = Just DataObject {..}-  fromAny DataUnion {..} = Just DataUnion {..}-  fromAny DataInterface {..} = Just DataInterface {..}-  fromAny _ = Nothing--type family IsSelected (c :: TypeCategory) (a :: TypeCategory) :: Bool--type instance IsSelected ANY a = TRUE--type instance IsSelected OUT OUT = TRUE--type instance IsSelected IN IN = TRUE--type instance IsSelected IN OUT = FALSE--type instance IsSelected OUT IN = FALSE--type instance IsSelected a ANY = TRUE--data TypeContent (b :: Bool) (a :: TypeCategory) where+data+  TypeContent+    (b :: Bool)+    (a :: TypeCategory)+    (s :: Stage)+  where   DataScalar ::     { dataScalar :: ScalarDefinition     } ->-    TypeContent TRUE a+    TypeContent (ELEM LEAF a) a s   DataEnum ::-    { enumMembers :: DataEnum+    { enumMembers :: DataEnum s     } ->-    TypeContent TRUE a+    TypeContent (ELEM LEAF a) a s   DataInputObject ::-    { inputObjectFields :: FieldsDefinition IN+    { inputObjectFields :: FieldsDefinition IN s     } ->-    TypeContent (IsSelected a IN) a+    TypeContent (ELEM IN a) a s   DataInputUnion ::-    { inputUnionMembers :: DataInputUnion+    { inputUnionMembers :: DataInputUnion s     } ->-    TypeContent (IsSelected a IN) a+    TypeContent (ELEM IN a) a s   DataObject ::     { objectImplements :: [TypeName],-      objectFields :: FieldsDefinition OUT+      objectFields :: FieldsDefinition OUT s     } ->-    TypeContent (IsSelected a OUT) a+    TypeContent (ELEM OBJECT a) a s   DataUnion ::-    { unionMembers :: DataUnion+    { unionMembers :: DataUnion s     } ->-    TypeContent (IsSelected a OUT) a+    TypeContent (ELEM OUT a) a s   DataInterface ::-    { interfaceFields :: FieldsDefinition OUT+    { interfaceFields :: FieldsDefinition OUT s     } ->-    TypeContent (IsSelected a OUT) a+    TypeContent (ELEM IMPLEMENTABLE a) a s -deriving instance Show (TypeContent a b)+deriving instance Show (TypeContent a b s) -deriving instance Lift (TypeContent a b)+deriving instance Lift (TypeContent a b s) -createType :: TypeName -> TypeContent TRUE a -> TypeDefinition a-createType typeName typeContent =+instance ToCategory (TypeContent TRUE) a ANY where+  toCategory DataScalar {..} = DataScalar {..}+  toCategory DataEnum {..} = DataEnum {..}+  toCategory DataInputObject {..} = DataInputObject {..}+  toCategory DataInputUnion {..} = DataInputUnion {..}+  toCategory DataObject {..} = DataObject {..}+  toCategory DataUnion {..} = DataUnion {..}+  toCategory DataInterface {..} = DataInterface {..}++instance ToCategory (TypeContent TRUE) OBJECT IMPLEMENTABLE where+  toCategory DataObject {..} = DataObject {..}++instance FromCategory (TypeContent TRUE) ANY IN where+  fromCategory DataScalar {..} = Just DataScalar {..}+  fromCategory DataEnum {..} = Just DataEnum {..}+  fromCategory DataInputObject {..} = Just DataInputObject {..}+  fromCategory DataInputUnion {..} = Just DataInputUnion {..}+  fromCategory _ = Nothing++instance FromCategory (TypeContent TRUE) ANY OUT where+  fromCategory DataScalar {..} = Just DataScalar {..}+  fromCategory DataEnum {..} = Just DataEnum {..}+  fromCategory DataObject {..} = Just DataObject {..}+  fromCategory DataUnion {..} = Just DataUnion {..}+  fromCategory DataInterface {..} = Just DataInterface {..}+  fromCategory _ = Nothing++instance FromCategory (TypeContent TRUE) ANY OBJECT where+  fromCategory DataObject {..} = Just DataObject {..}+  fromCategory _ = Nothing++instance FromCategory (TypeContent TRUE) ANY IMPLEMENTABLE where+  fromCategory DataObject {..} = Just DataObject {..}+  fromCategory DataInterface {..} = Just DataInterface {..}+  fromCategory _ = Nothing++mkType :: TypeName -> TypeContent TRUE a s -> TypeDefinition a s+mkType typeName typeContent =   TypeDefinition     { typeName,       typeDescription = Nothing,@@ -442,31 +581,29 @@       typeContent     } -createScalarType :: TypeName -> TypeDefinition a-createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure)+createScalarType :: ELEM LEAF a ~ TRUE => TypeName -> TypeDefinition a s+createScalarType typeName = mkType typeName $ DataScalar (ScalarDefinition pure) -createEnumType :: TypeName -> [TypeName] -> TypeDefinition a-createEnumType typeName typeData = createType typeName (DataEnum enumValues)-  where-    enumValues = map createEnumValue typeData+mkEnumContent :: ELEM LEAF a ~ TRUE => [TypeName] -> TypeContent TRUE a s+mkEnumContent typeData = DataEnum (fmap mkEnumValue typeData) -createEnumValue :: TypeName -> DataEnumValue-createEnumValue enumName =+mkUnionContent :: [TypeName] -> TypeContent TRUE OUT s+mkUnionContent typeData = DataUnion $ fmap mkUnionMember typeData++mkEnumValue :: TypeName -> DataEnumValue s+mkEnumValue enumName =   DataEnumValue     { enumName,       enumDescription = Nothing,       enumDirectives = []     } -createUnionType :: TypeName -> [TypeName] -> TypeDefinition OUT-createUnionType typeName typeData = createType typeName (DataUnion $ map mkUnionMember typeData)--isEntNode :: TypeContent TRUE a -> Bool+isEntNode :: TypeContent TRUE a s -> Bool isEntNode DataScalar {} = True isEntNode DataEnum {} = True isEntNode _ = False -kindOf :: TypeDefinition a -> TypeKind+kindOf :: TypeDefinition a s -> TypeKind kindOf TypeDefinition {typeName, typeContent} = __kind typeContent   where     __kind DataScalar {} = KindScalar@@ -477,268 +614,95 @@     __kind DataInputUnion {} = KindInputUnion     __kind DataInterface {} = KindInterface -fromOperation :: Maybe (TypeDefinition OUT) -> [(TypeName, TypeDefinition ANY)]-fromOperation (Just datatype) = [(typeName datatype, toAny datatype)]+fromOperation :: Maybe (TypeDefinition OBJECT s) -> [TypeDefinition ANY s]+fromOperation (Just datatype) = [toAny datatype] fromOperation Nothing = [] -defineType :: TypeDefinition cat -> Schema -> Schema-defineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys, typeFingerprint} lib =-  lib {types = HM.insert name unionTags (HM.insert typeName (toAny dt) (types lib))}+safeDefineType ::+  ( Monad m,+    Failure ValidationErrors m+  ) =>+  TypeDefinition cat s ->+  Schema s ->+  m (Schema s)+safeDefineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys, typeFingerprint} lib = do+  types <- insert unionTags (types lib) >>= insert (toAny dt)+  pure lib {types}   where-    name = typeName <> "Tags"     unionTags =       TypeDefinition-        { typeName = name,+        { typeName = typeName <> "Tags",           typeFingerprint,           typeDescription = Nothing,           typeDirectives = [],-          typeContent = DataEnum $ map (createEnumValue . memberName) enumKeys+          typeContent = mkEnumContent (fmap memberName enumKeys)         }-defineType datatype lib =-  lib {types = HM.insert (typeName datatype) (toAny datatype) (types lib)}+safeDefineType datatype lib = do+  types <- insert (toAny datatype) (types lib)+  pure lib {types}  insertType ::-  TypeDefinition ANY ->-  TypeUpdater-insertType datatype@TypeDefinition {typeName} lib = case isTypeDefined typeName lib of-  Nothing -> resolveUpdates (defineType datatype lib) []-  Just fingerprint-    | fingerprint == typeFingerprint datatype -> return lib-    -- throw error if 2 different types has same name-    | otherwise -> failure $ nameCollisionError typeName+  (Monad m, Failure ValidationErrors m) =>+  TypeDefinition cat s ->+  UpdateT m (Schema s)+insertType datatype@TypeDefinition {typeName, typeFingerprint} =+  updateSchema typeName typeFingerprint [] (const datatype) ()  updateSchema ::+  (Monad m, Failure ValidationErrors m) =>   TypeName ->   DataFingerprint ->-  [TypeUpdater] ->-  (a -> TypeDefinition cat) ->+  [UpdateT m (Schema s)] ->+  (a -> TypeDefinition cat s) ->   a ->-  TypeUpdater-updateSchema name fingerprint stack f x lib =-  case isTypeDefined name lib of-    Nothing ->-      resolveUpdates-        (defineType (f x) lib)-        stack-    Just fingerprint' | fingerprint' == fingerprint -> return lib-    -- throw error if 2 different types has same name-    Just _ -> failure $ nameCollisionError name+  UpdateT m (Schema s)+updateSchema name fingerprint stack f x+  | isNotSystemTypeName name = UpdateT $ \lib ->+    case isTypeDefined name lib of+      Nothing -> do+        t <- safeDefineType (f x) lib+        resolveUpdates t stack+      Just fingerprint' | fingerprint' == fingerprint -> pure lib+      -- throw error if 2 different types has same name+      Just _ -> failure [nameCollisionError name]+  | otherwise = concatUpdates stack  lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a lookupWith f key = find ((== key) . f) --- lookups and removes TypeDefinition from hashmap-popByKey :: TypeName -> [TypeDefinition ANY] -> (Maybe (TypeDefinition OUT), [TypeDefinition ANY])-popByKey name types = case lookupWith typeName name types of+popByKey ::+  (Applicative m, Failure ValidationErrors m) =>+  [TypeDefinition ANY s] ->+  RootOperationTypeDefinition ->+  m (Maybe (TypeDefinition OBJECT s))+popByKey types (RootOperationTypeDefinition opType name) = case lookupWith typeName name types of   Just dt@TypeDefinition {typeContent = DataObject {}} ->-    (fromAny dt, filter ((/= name) . typeName) types)-  _ -> (Nothing, types)--newtype Fields def = Fields-  {unFields :: OrderedMap FieldName def}-  deriving-    ( Show,-      Lift,-      Functor,-      Foldable,-      Traversable-    )--deriving instance (KEY def ~ FieldName, KeyOf def) => Collection def (Fields def)--instance Merge (FieldsDefinition cat) where-  merge path (Fields x) (Fields y) = Fields <$> merge path x y--instance Selectable (Fields (FieldDefinition cat)) (FieldDefinition cat) where-  selectOr fb f name (Fields lib) = selectOr fb f name lib--unsafeFromFields :: [FieldDefinition cat] -> FieldsDefinition cat-unsafeFromFields = Fields . unsafeFromValues--fieldsToArguments :: FieldsDefinition IN -> ArgumentsDefinition-fieldsToArguments = ArgumentsDefinition Nothing . unFields--instance (KEY def ~ FieldName, KeyOf def, NameCollision def) => Listable def (Fields def) where-  fromElems = fmap Fields . fromElems-  elems = elems . unFields---- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects----------------------------------------------------------------------------------  ObjectTypeDefinition:---    Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt)------  ImplementsInterfaces---    implements &(opt) NamedType---    ImplementsInterfaces & NamedType------  FieldsDefinition---    { FieldDefinition(list) }----type FieldsDefinition cat = Fields (FieldDefinition cat)----  FieldDefinition---    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)------ https://spec.graphql.org/June2018/#InputValueDefinition--- InputValueDefinition---   Description(opt) Name: Type DefaultValue(opt) Directives[Const](opt)--data FieldDefinition (cat :: TypeCategory) = FieldDefinition-  { fieldName :: FieldName,-    fieldDescription :: Maybe Description,-    fieldType :: TypeRef,-    fieldContent :: Maybe (FieldContent TRUE cat),-    fieldDirectives :: [Directive VALID]-  }-  deriving (Show, Lift)--data FieldContent (bool :: Bool) (cat :: TypeCategory) where-  DefaultInputValue ::-    { defaultInputValue :: Value RESOLVED-    } ->-    FieldContent (IsSelected cat IN) cat-  FieldArgs ::-    { fieldArgsDef :: ArgumentsDefinition-    } ->-    FieldContent (IsSelected cat OUT) cat--fieldContentArgs :: FieldContent b cat -> OrderedMap FieldName ArgumentDefinition-fieldContentArgs (FieldArgs (ArgumentsDefinition _ argsD)) = argsD-fieldContentArgs _ = empty--deriving instance Show (FieldContent bool cat)--deriving instance Lift (FieldContent bool cat)--instance KeyOf (FieldDefinition cat) where-  keyOf = fieldName--instance Selectable (FieldDefinition OUT) ArgumentDefinition where-  selectOr fb f key FieldDefinition {fieldContent = Just (FieldArgs args)} = selectOr fb f key args-  selectOr fb _ _ _ = fb--instance NameCollision (FieldDefinition cat) where-  nameCollision name _ =-    GQLError-      { message = "There can Be only One field Named " <> msg name,-        locations = []-      }--instance RenderGQL (FieldDefinition cat) where-  render FieldDefinition {fieldName = FieldName name, fieldType, fieldContent = Just (FieldArgs args)} =-    name <> render args <> ": " <> render fieldType-  render FieldDefinition {fieldName = FieldName name, fieldType} =-    name <> ": " <> render fieldType--instance RenderGQL (FieldsDefinition OUT) where-  render = renderObject render . ignoreHidden . elems--instance RenderGQL (FieldsDefinition IN) where-  render = renderObject render . ignoreHidden . elems--fieldVisibility :: FieldDefinition cat -> Bool-fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields--isFieldNullable :: FieldDefinition cat -> Bool-isFieldNullable = isNullable . fieldType--createField :: Maybe (FieldContent TRUE cat) -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat-createField fieldContent fieldName (typeWrappers, typeConName) =-  FieldDefinition-    { fieldName,-      fieldContent,-      fieldDescription = Nothing,-      fieldType = TypeRef {typeConName, typeWrappers, typeArgs = Nothing},-      fieldDirectives = []-    }--mkField :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat-mkField = createField Nothing--mkObjectField :: ArgumentsDefinition -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition OUT-mkObjectField args = createField (Just $ FieldArgs args)--toNullableField :: FieldDefinition cat -> FieldDefinition cat-toNullableField dataField-  | isNullable (fieldType dataField) = dataField-  | otherwise = dataField {fieldType = nullable (fieldType dataField)}-  where-    nullable alias@TypeRef {typeWrappers} =-      alias {typeWrappers = TypeMaybe : typeWrappers}--toListField :: FieldDefinition cat -> FieldDefinition cat-toListField dataField = dataField {fieldType = listW (fieldType dataField)}-  where-    listW alias@TypeRef {typeWrappers} =-      alias {typeWrappers = TypeList : typeWrappers}---- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects------------------------------------------------------------------------------- InputObjectTypeDefinition--- Description(opt) input Name Directives(const,opt) InputFieldsDefinition(opt)------- InputFieldsDefinition--- { InputValueDefinition(list) }--type InputFieldsDefinition = Fields InputValueDefinition--type InputValueDefinition = FieldDefinition IN---- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments--------------------------------------------------------------------------------------------------- ArgumentsDefinition:---   (InputValueDefinition(list))--data ArgumentsDefinition = ArgumentsDefinition-  { argumentsTypename :: Maybe TypeName,-    arguments :: OrderedMap FieldName ArgumentDefinition-  }-  deriving (Show, Lift)--instance RenderGQL ArgumentsDefinition where-  render ArgumentsDefinition {arguments}-    | null arguments =-      ""-    | otherwise = "(" <> intercalate ", " (map render $ elems arguments) <> ")"--type ArgumentDefinition = FieldDefinition IN--instance Selectable ArgumentsDefinition ArgumentDefinition where-  selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args--instance Collection ArgumentDefinition ArgumentsDefinition where-  empty = ArgumentsDefinition Nothing empty-  singleton = ArgumentsDefinition Nothing . singleton--instance Listable ArgumentDefinition ArgumentsDefinition where-  elems (ArgumentsDefinition _ args) = elems args-  fromElems args = ArgumentsDefinition Nothing <$> fromElems args--createArgument :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition IN-createArgument = mkField---- https://spec.graphql.org/June2018/#InputValueDefinition--- InputValueDefinition---   Description(opt) Name: TypeDefaultValue(opt) Directives[Const](opt)--- TODO: implement inputValue+    pure (fromAny dt)+  Just {} ->+    failure+      [ msgValidation (show opType)+          <> " root type must be Object type if provided, it cannot be "+          <> msgValidation name+      ]+  _ -> pure Nothing  __inputname :: FieldName __inputname = "inputname" -createInputUnionFields :: TypeName -> [UnionMember IN] -> [FieldDefinition IN]-createInputUnionFields name members = fieldTag : map unionField members+mkInputUnionFields :: TypeName -> [UnionMember IN s] -> FieldsDefinition IN s+mkInputUnionFields name members = unsafeFromFields $ fieldTag : fmap mkUnionField members   where     fieldTag =       FieldDefinition         { fieldName = __inputname,           fieldDescription = Nothing,           fieldContent = Nothing,-          fieldType = createAlias (name <> "Tags"),+          fieldType = mkTypeRef (name <> "Tags"),           fieldDirectives = []         } -unionField :: UnionMember IN -> FieldDefinition IN-unionField UnionMember {memberName} =+mkUnionField :: UnionMember IN s -> FieldDefinition IN s+mkUnionField UnionMember {memberName} =   FieldDefinition     { fieldName = toFieldName memberName,       fieldDescription = Nothing,@@ -756,35 +720,24 @@ -- OTHER -------------------------------------------------------------------------------------------------- -createAlias :: TypeName -> TypeRef-createAlias typeConName =-  TypeRef {typeConName, typeWrappers = [], typeArgs = Nothing}--type TypeUpdater = LibUpdater Schema--instance RenderGQL Schema where-  render schema = intercalate "\n\n" $ map render visibleTypes+instance RenderGQL (Schema s) where+  render schema = intercalate newline (fmap render visibleTypes)     where-      visibleTypes = filter (not . isSystemTypeName . typeName) (elems schema)+      visibleTypes = filter (isNotSystemTypeName . typeName) (elems schema) -instance RenderGQL (TypeDefinition a) where-  render TypeDefinition {typeName, typeContent} = __render typeContent+instance RenderGQL (TypeDefinition a s) where+  render TypeDefinition {typeName, typeContent} = __render typeContent <> newline     where       __render DataInterface {interfaceFields} = "interface " <> render typeName <> render interfaceFields       __render DataScalar {} = "scalar " <> render typeName-      __render (DataEnum tags) = "enum " <> render typeName <> renderObject render tags+      __render (DataEnum tags) = "enum " <> render typeName <> renderObject tags       __render (DataUnion members) =         "union "           <> render typeName-          <> " =\n    "-          <> intercalate ("\n" <> renderIndent <> "| ") (map render members)+          <> " = "+          <> renderMembers members       __render (DataInputObject fields) = "input " <> render typeName <> render fields-      __render (DataInputUnion members) = "input " <> render typeName <> render fieldsDef+      __render (DataInputUnion members) = "input " <> render typeName <> render fields         where-          fieldsDef = unsafeFromFields fields-          fields :: [FieldDefinition IN]-          fields = createInputUnionFields typeName members+          fields = mkInputUnionFields typeName members       __render DataObject {objectFields} = "type " <> render typeName <> render objectFields--ignoreHidden :: [FieldDefinition cat] -> [FieldDefinition cat]-ignoreHidden = filter fieldVisibility