morpheus-graphql 0.7.1 → 0.8.0

raw patch · 120 files changed

+4408/−1538 lines, 120 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +85/−12
• changelog.md +175/−2
• morpheus-graphql.cabal +55/−3
• src/Data/Morpheus/Error/Fragment.hs +20/−19
• src/Data/Morpheus/Error/Input.hs +16/−7
• src/Data/Morpheus/Error/Internal.hs +8/−2
• src/Data/Morpheus/Execution/Client/Compile.hs +4/−3
• src/Data/Morpheus/Execution/Client/Selection.hs +84/−79
• src/Data/Morpheus/Execution/Document/Convert.hs +71/−69
• src/Data/Morpheus/Execution/Document/Declare.hs +1/−1
• src/Data/Morpheus/Execution/Document/Decode.hs +7/−7
• src/Data/Morpheus/Execution/Document/Encode.hs +8/−6
• src/Data/Morpheus/Execution/Document/GQLType.hs +6/−8
• src/Data/Morpheus/Execution/Document/Introspect.hs +39/−21
• src/Data/Morpheus/Execution/Internal/Declare.hs +7/−7
• src/Data/Morpheus/Execution/Internal/Decode.hs +19/−18
• src/Data/Morpheus/Execution/Server/Decode.hs +146/−69
• src/Data/Morpheus/Execution/Server/Encode.hs +172/−96
• src/Data/Morpheus/Execution/Server/Interpreter.hs +5/−4
• src/Data/Morpheus/Execution/Server/Introspect.hs +343/−100
• src/Data/Morpheus/Execution/Server/Resolve.hs +31/−21
• src/Data/Morpheus/Execution/Subscription/ClientRegister.hs +14/−12
• src/Data/Morpheus/Kind.hs +20/−16
• src/Data/Morpheus/Parsing/Document/TypeSystem.hs +37/−44
• src/Data/Morpheus/Parsing/Internal/Pattern.hs +17/−26
• src/Data/Morpheus/Parsing/Internal/Terms.hs +23/−11
• src/Data/Morpheus/Parsing/Internal/Value.hs +54/−30
• src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +3/−2
• src/Data/Morpheus/Parsing/Request/Arguments.hs +9/−24
• src/Data/Morpheus/Parsing/Request/Operation.hs +12/−13
• src/Data/Morpheus/Parsing/Request/Parser.hs +3/−3
• src/Data/Morpheus/Parsing/Request/Selection.hs +14/−13
• src/Data/Morpheus/Rendering/RenderGQL.hs +22/−29
• src/Data/Morpheus/Rendering/RenderIntrospection.hs +41/−36
• src/Data/Morpheus/Schema/SchemaAPI.hs +12/−9
• src/Data/Morpheus/Server.hs +28/−16
• src/Data/Morpheus/Types.hs +6/−0
• src/Data/Morpheus/Types/GQLScalar.hs +5/−2
• src/Data/Morpheus/Types/GQLType.hs +26/−5
• src/Data/Morpheus/Types/ID.hs +1/−1
• src/Data/Morpheus/Types/IO.hs +3/−3
• src/Data/Morpheus/Types/Internal/AST.hs +62/−15
• src/Data/Morpheus/Types/Internal/AST/Base.hs +27/−0
• src/Data/Morpheus/Types/Internal/AST/Data.hs +128/−144
• src/Data/Morpheus/Types/Internal/AST/Operation.hs +0/−88
• src/Data/Morpheus/Types/Internal/AST/Selection.hs +137/−53
• src/Data/Morpheus/Types/Internal/AST/Value.hs +112/−21
• src/Data/Morpheus/Types/Internal/Resolving.hs +4/−0
• src/Data/Morpheus/Types/Internal/Resolving/Core.hs +21/−15
• src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +82/−30
• src/Data/Morpheus/Validation/Document/Validation.hs +29/−18
• src/Data/Morpheus/Validation/Internal/Value.hs +144/−57
• src/Data/Morpheus/Validation/Query/Arguments.hs +83/−66
• src/Data/Morpheus/Validation/Query/Fragment.hs +21/−21
• src/Data/Morpheus/Validation/Query/Selection.hs +85/−75
• src/Data/Morpheus/Validation/Query/Validation.hs +3/−3
• src/Data/Morpheus/Validation/Query/Variable.hs +60/−27
• test/Feature/Holistic/API.hs +13/−1
• test/Feature/Holistic/cases.json +8/−0
• test/Feature/Holistic/failure/resolveFailure/query.gql +4/−0
• test/Feature/Holistic/failure/resolveFailure/response.json +12/−0
• test/Feature/Holistic/fragment/loopingFragment/response.json +1/−1
• test/Feature/Holistic/parsing/complex/response.json +4/−0
• test/Feature/Holistic/parsing/invalidFields/response.json +2/−7
• test/Feature/Holistic/parsing/numbers/query.gql +7/−0
• test/Feature/Holistic/parsing/numbers/response.json +24/−0
• test/Feature/Holistic/schema.gql +2/−0
• test/Feature/Input/Object/API.hs +55/−0
• test/Feature/Input/Object/cases.json +30/−0
• test/Feature/Input/Object/nullableUndefinedField/query.gql +3/−0
• test/Feature/Input/Object/nullableUndefinedField/response.json +5/−0
• test/Feature/Input/Object/resolveObject/query.gql +4/−0
• test/Feature/Input/Object/resolveObject/response.json +6/−0
• test/Feature/Input/Object/resolveVariable/query.gql +4/−0
• test/Feature/Input/Object/resolveVariable/response.json +6/−0
• test/Feature/Input/Object/resolveVariable/variables.json +4/−0
• test/Feature/Input/Object/undefinedField/query.gql +4/−0
• test/Feature/Input/Object/undefinedField/response.json +12/−0
• test/Feature/Input/Object/unexpectedValue/query.gql +6/−0
• test/Feature/Input/Object/unexpectedValue/response.json +20/−0
• test/Feature/Input/Object/unexpectedVariable/query.gql +4/−0
• test/Feature/Input/Object/unexpectedVariable/response.json +12/−0
• test/Feature/Input/Object/unknownField/query.gql +3/−0
• test/Feature/Input/Object/unknownField/response.json +8/−0
• test/Feature/Input/Scalar/API.hs +44/−0
• test/Feature/Input/Scalar/cases.json +10/−0
• test/Feature/Input/Scalar/decodeFloat/query.gql +7/−0
• test/Feature/Input/Scalar/decodeFloat/response.json +9/−0
• test/Feature/Input/Scalar/decodeInt/query.gql +7/−0
• test/Feature/Input/Scalar/decodeInt/response.json +9/−0
• test/Feature/TypeInference/API.hs +106/−0
• test/Feature/TypeInference/cases.json +50/−0
• test/Feature/TypeInference/introspection/complexInput/query.gql +79/−0
• test/Feature/TypeInference/introspection/complexInput/response.json +58/−0
• test/Feature/TypeInference/introspection/complexUnion/query.gql +76/−0
• test/Feature/TypeInference/introspection/complexUnion/response.json +22/−0
• test/Feature/TypeInference/introspection/complexUnionEnum/query.gql +79/−0
• test/Feature/TypeInference/introspection/complexUnionEnum/response.json +41/−0
• test/Feature/TypeInference/introspection/complexUnionIndexedTypes/query.gql +79/−0
• test/Feature/TypeInference/introspection/complexUnionIndexedTypes/response.json +57/−0
• test/Feature/TypeInference/introspection/complexUnionRecord/query.gql +82/−0
• test/Feature/TypeInference/introspection/complexUnionRecord/response.json +78/−0
• test/Feature/TypeInference/introspection/complexUnionScalar/query.gql +76/−0
• test/Feature/TypeInference/introspection/complexUnionScalar/response.json +25/−0
• test/Feature/TypeInference/introspection/enum/query.gql +76/−0
• test/Feature/TypeInference/introspection/enum/response.json +29/−0
• test/Feature/TypeInference/introspection/inputObject/query.gql +76/−0
• test/Feature/TypeInference/introspection/inputObject/response.json +32/−0
• test/Feature/TypeInference/introspection/object/query.gql +76/−0
• test/Feature/TypeInference/introspection/object/response.json +36/−0
• test/Feature/TypeInference/resolving/complexUnion/query.gql +45/−0
• test/Feature/TypeInference/resolving/complexUnion/response.json +18/−0
• test/Feature/TypeInference/resolving/input/query.gql +9/−0
• test/Feature/TypeInference/resolving/input/response.json +7/−0
• test/Feature/TypeInference/resolving/object/query.gql +6/−0
• test/Feature/TypeInference/resolving/object/response.json +1/−0
• test/Feature/UnionType/API.hs +31/−21
• test/Feature/UnionType/cannotBeSpreadOnType/response.json +11/−7
• test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json +1/−1
• test/Spec.hs +47/−18

@@ -29,7 +29,7 @@ resolver: lts-14.8  extra-deps:-  - morpheus-graphql-0.7.1+  - morpheus-graphql-0.8.0 ```  As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update`@@ -118,10 +118,7 @@ data Deity = Deity   { fullName :: Text         -- Non-Nullable Field   , power    :: Maybe Text   -- Nullable Field-  } deriving (Generic)--instance GQLType Deity where-  type  KIND Deity = OBJECT+  } deriving (Generic,GQLType)  data DeityArgs = DeityArgs   { name      :: Text        -- Required Argument@@ -152,8 +149,6 @@ askDB = ... ``` -Note that the type `a -> IORes b` is just Synonym for `a -> ExceptT String IO b`- To make this `Query` type available as an API, we define a `GQLRootResolver` and feed it to the Morpheus `interpreter`. A `GQLRootResolver` consists of `query`, `mutation` and `subscription` definitions, while we omit the latter for this example:  ```haskell@@ -236,14 +231,70 @@  ```haskell data Character-  = DEITY Deity-  | HUMAN Human-  deriving (Generic)+  = data Character  =+    CharacterDeity Deity -- Only <tyconName><conName> should generate direct link+  -- RECORDS+  | Creature { creatureName :: Text, creatureAge :: Int }+  --- Types+  | SomeDeity Deity+  | CharacterInt Int+  | SomeMutli Int Text+  --- ENUMS+  | Zeus+  | Cronus+  deriving (Generic, GQLType)+``` -instance GQLType Character where-  type KIND Character = UNION+where deity is and object++as you see there ar different kinds of unions. `morpheus` handles them all.++this type will be represented as++```gql+union Character =+    Deity # unwrapped union: becouse Character + Deity = CharacterDeity+  | Creature+  | SomeDeity # wrapped union: becouse Character + Deity != SomeDeity+  | CharacterInt+  | SomeMutli+  | CharacterEnumObject # object wrapped for enums++type Creature {+  creatureName: String!+  creatureAge: Int!+}++type SomeDeity {+  _0: Deity!+}++type CharacterInt {+  _0: Int!+}++type SomeMutli {+  _0: Int!+  _1: String!+}++# enum+type CharacterEnumObject {+  enum: CharacterEnum!+}++enum CharacterEnum {+  Zeus+  Cronus+} ``` +- namespaced Unions: `CharacterDeity` where `Character` is TypeConstructor and `Deity` referenced object (not scalar) type: will be generate regular graphql Union+  +- for for all other unions will be generated new object type. for types without record syntaxt, fields will be automatally indexed.++- all empty constructors in union will be summed in type `<tyConName>Enum` (e.g `CharacterEnum`), this enum will be wrapped in `CharacterEnumObject` and added to union members.+ ### Scalar types  To use custom scalar types, you need to provide implementations for `parseValue` and `serialize` respectively.@@ -285,6 +336,28 @@ ![alt text](https://morpheusgraphql.com/assets/img/introspection/spelling.png "spelling") ![alt text](https://morpheusgraphql.com/assets/img/introspection/autocomplete.png "autocomplete") ![alt text](https://morpheusgraphql.com/assets/img/introspection/type.png "type")++## Handling Errors++for errors you can use use either `liftEither` or `failRes`:+at the and they have same result.++with `liftEither`++```haskell+resolveDeity :: DeityArgs -> IORes e Deity+resolveDeity DeityArgs {} = liftEither $ dbDeity++dbDeity ::  IO Either Deity+dbDeity = pure $ Left "db error"+```++with `failRes`++```haskell+resolveDeity :: DeityArgs -> IORes e Deity+resolveDeity DeityArgs { } = failRes "db error"+```  ### Mutations 

@@ -1,14 +1,187 @@+## [0.8.0] - 15.12.2009++### Changed++- deprecated: `INPUT_OBJECT`, `OBJECT`, `UNION`,++  - use `INPUT` instead of `INPUT_OBJECT`+  - use `deriving(GQLType)` insead of `OBJECT` or `UNION`++- only namespaced Unions  generate regular graphql Union, other attempts will be wrapped inside an object with constructor name :++  e.g:+  +  ```hs+  data Character = +    CharacterDeity Deity+    SomeDeity Deity+    deriving (GQLType)+  ```++  where `Deity` is Object.+  will generate++  ```gql+    union CHaracter = Deity | SomeDeity++    type SomeDeity {+      _0: Deity+    }+  ```++### Added++- `failRes` for resolver failures+- added kind: INPUT , OUTPUT+- Automatic Type Inference (only for Object, Union and Enum)+- More general stateful resolvers which accept instances of MonadIO (Authored by Sebastian Pulido [sebashack])+- Utility to create web-socket applications with custom MonadIO instances (Authored by Sebastian Pulido [sebashack])++```hs++data Realm  =+    Sky+  | Sea+  | Underworld+    deriving (Generic, GQLType)++data Deity  = Deity{+    fullName:: Text,+    realm:: Realm+  } deriving (Generic, GQLType)++data Character  =+    CharacterDeity Deity -- Only <tyconName><conName> should generate direct link+  -- RECORDS+  | Creature { creatureName :: Text, creatureAge :: Int }+  --- Types+  | SomeDeity Deity+  | CharacterInt Int+  | SomeMutli Int Text+  --- ENUMS+  | Zeus+  | Cronus deriving (Generic, GQLType)+++```++will generate schema:++```gql+enum Realm {+  Sky+  Sea+  Underworld+}++type Deity {+  fullName: String!+  realm: Realm!+}++union Character =+    Deity+  | Creature+  | SomeDeity+  | CharacterInt+  | SomeMutli+  | CharacterEnumObject++type Creature {+  creatureName: String!+  creatureAge: Int!+}++type SomeDeity {+  _0: Deity!+}++type CharacterInt {+  _0: Int!+}++type SomeMutli {+  _0: Int!+  _1: String!+}++# enum+type CharacterEnumObject {+  enum: CharacterEnum!+}++enum CharacterEnum {+  Zeus+  Cronus+}+```++rules:++- haskell union type with only empty constructors (e.g `Realm`), will generate graphql `enum`+- haskell record without union (e.g `Deity`), will generate graphql `object`+- namespaced Unions: `CharacterDeity` where `Character` is TypeConstructor and `Deity` referenced object (not scalar) type: will be generate regular graphql Union++  ```gql+  union Character =+        Deity+      | ...+  ```++- for union recrods (`Creature { creatureName :: Text, creatureAge :: Int }`) will be referenced in union type, plus type `Creature`will be added in schema.++  e.g++  ```gql+    union Character =+      ...+      | Creature+      | ...++    type Creature {+      creatureName : String!+      creatureAge: Int!+    }++  ```++  - all empty constructors in union will be summed in type `<tyConName>Enum` (e.g `CharacterEnum`), this enum will be wrapped in `CharacterEnumObject` and this type will be added to union `Character`. as in example above++  - there is only types left with form `TypeName Type1 2Type ..`(e.g `SomeDeity Deity` ,`CharacterInt Int`, `SomeMutli Int Text`),++    morpheus will generate objet type from it:++    ```gql+    type TypeName {+      _0: Type1!+      _1: Type2!+      ...+    }+    ```++### Removed++- removed kind: INPUT_UNION++### Fixed++- on filed resolver was displayed. unexhausted case exception of graphql error+- support of signed numbers (e.g `-4`)+- support of round floats (e.g `1.000`) +- validation checks undefined fields on inputObject+- variables are supported inside input values+ ## [0.7.1] - 26.11.2019  - max bound icludes: support-megaparsec-8.0  ## [0.7.0] - 24.11.2019 -## Removed+### Removed  - `toMorpheusHaskellAPi` from `Data.Morpheus.Document` functionality will be migrated in `morpheus-graphql-cli` -## Changed+### Changed  - `liftM` to `MonadTrans` instance method `lift` 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: efbb028b66786193717210bd506961ab228d3150ecf66b7d6645e5f972aa3c95+-- hash: edc0f21d61026ad6d50de9239e2f190424c4f7c8968b0908c467f9c487bf4e5b  name:           morpheus-graphql-version:        0.7.1+version:        0.8.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -26,6 +26,7 @@     test/Feature/Holistic/arguments/nameConflict/query.gql     test/Feature/Holistic/arguments/undefinedArgument/query.gql     test/Feature/Holistic/arguments/unknownArguments/query.gql+    test/Feature/Holistic/failure/resolveFailure/query.gql     test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql     test/Feature/Holistic/fragment/inlineFragment/query.gql     test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql@@ -72,6 +73,7 @@     test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql     test/Feature/Holistic/parsing/missingCloseBrace/query.gql     test/Feature/Holistic/parsing/notNullSpacing/query.gql+    test/Feature/Holistic/parsing/numbers/query.gql     test/Feature/Holistic/parsing/singleLineComments/query.gql     test/Feature/Holistic/schema.gql     test/Feature/Holistic/selection/AliasNameConflict/query.gql@@ -91,6 +93,15 @@     test/Feature/Input/Enum/decodeMany/con4/query.gql     test/Feature/Input/Enum/decodeMany/con5/query.gql     test/Feature/Input/Enum/decodeMany/con6/query.gql+    test/Feature/Input/Object/nullableUndefinedField/query.gql+    test/Feature/Input/Object/resolveObject/query.gql+    test/Feature/Input/Object/resolveVariable/query.gql+    test/Feature/Input/Object/undefinedField/query.gql+    test/Feature/Input/Object/unexpectedValue/query.gql+    test/Feature/Input/Object/unexpectedVariable/query.gql+    test/Feature/Input/Object/unknownField/query.gql+    test/Feature/Input/Scalar/decodeFloat/query.gql+    test/Feature/Input/Scalar/decodeInt/query.gql     test/Feature/InputType/variables/incompatibleType/equalType/query.gql     test/Feature/InputType/variables/incompatibleType/stricterType/query.gql     test/Feature/InputType/variables/incompatibleType/weakerType1/query.gql@@ -112,6 +123,18 @@     test/Feature/InputType/variables/valueNotProvided/nonNullVariableWithDefaultValue/query.gql     test/Feature/InputType/variables/valueNotProvided/nullableVariable/query.gql     test/Feature/Schema/nameCollision/query.gql+    test/Feature/TypeInference/introspection/complexInput/query.gql+    test/Feature/TypeInference/introspection/complexUnion/query.gql+    test/Feature/TypeInference/introspection/complexUnionEnum/query.gql+    test/Feature/TypeInference/introspection/complexUnionIndexedTypes/query.gql+    test/Feature/TypeInference/introspection/complexUnionRecord/query.gql+    test/Feature/TypeInference/introspection/complexUnionScalar/query.gql+    test/Feature/TypeInference/introspection/enum/query.gql+    test/Feature/TypeInference/introspection/inputObject/query.gql+    test/Feature/TypeInference/introspection/object/query.gql+    test/Feature/TypeInference/resolving/complexUnion/query.gql+    test/Feature/TypeInference/resolving/input/query.gql+    test/Feature/TypeInference/resolving/object/query.gql     test/Feature/UnionType/cannotBeSpreadOnType/query.gql     test/Feature/UnionType/fragmentOnAAndB/query.gql     test/Feature/UnionType/fragmentOnlyOnA/query.gql@@ -127,6 +150,7 @@     test/Feature/Holistic/arguments/undefinedArgument/response.json     test/Feature/Holistic/arguments/unknownArguments/response.json     test/Feature/Holistic/cases.json+    test/Feature/Holistic/failure/resolveFailure/response.json     test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json     test/Feature/Holistic/fragment/inlineFragment/response.json     test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json@@ -174,6 +198,7 @@     test/Feature/Holistic/parsing/missingCloseBrace/response.json     test/Feature/Holistic/parsing/notNullSpacing/response.json     test/Feature/Holistic/parsing/notNullSpacing/variables.json+    test/Feature/Holistic/parsing/numbers/response.json     test/Feature/Holistic/parsing/singleLineComments/response.json     test/Feature/Holistic/selection/AliasNameConflict/response.json     test/Feature/Holistic/selection/AliasResolve/response.json@@ -193,6 +218,18 @@     test/Feature/Input/Enum/decodeMany/con4/response.json     test/Feature/Input/Enum/decodeMany/con5/response.json     test/Feature/Input/Enum/decodeMany/con6/response.json+    test/Feature/Input/Object/cases.json+    test/Feature/Input/Object/nullableUndefinedField/response.json+    test/Feature/Input/Object/resolveObject/response.json+    test/Feature/Input/Object/resolveVariable/response.json+    test/Feature/Input/Object/resolveVariable/variables.json+    test/Feature/Input/Object/undefinedField/response.json+    test/Feature/Input/Object/unexpectedValue/response.json+    test/Feature/Input/Object/unexpectedVariable/response.json+    test/Feature/Input/Object/unknownField/response.json+    test/Feature/Input/Scalar/cases.json+    test/Feature/Input/Scalar/decodeFloat/response.json+    test/Feature/Input/Scalar/decodeInt/response.json     test/Feature/InputType/cases.json     test/Feature/InputType/variables/incompatibleType/equalType/response.json     test/Feature/InputType/variables/incompatibleType/equalType/variables.json@@ -229,6 +266,19 @@     test/Feature/InputType/variables/valueNotProvided/nullableVariable/response.json     test/Feature/Schema/cases.json     test/Feature/Schema/nameCollision/response.json+    test/Feature/TypeInference/cases.json+    test/Feature/TypeInference/introspection/complexInput/response.json+    test/Feature/TypeInference/introspection/complexUnion/response.json+    test/Feature/TypeInference/introspection/complexUnionEnum/response.json+    test/Feature/TypeInference/introspection/complexUnionIndexedTypes/response.json+    test/Feature/TypeInference/introspection/complexUnionRecord/response.json+    test/Feature/TypeInference/introspection/complexUnionScalar/response.json+    test/Feature/TypeInference/introspection/enum/response.json+    test/Feature/TypeInference/introspection/inputObject/response.json+    test/Feature/TypeInference/introspection/object/response.json+    test/Feature/TypeInference/resolving/complexUnion/response.json+    test/Feature/TypeInference/resolving/input/response.json+    test/Feature/TypeInference/resolving/object/response.json     test/Feature/UnionType/cannotBeSpreadOnType/response.json     test/Feature/UnionType/cases.json     test/Feature/UnionType/fragmentOnAAndB/response.json@@ -313,7 +363,6 @@       Data.Morpheus.Types.ID       Data.Morpheus.Types.Internal.AST.Base       Data.Morpheus.Types.Internal.AST.Data-      Data.Morpheus.Types.Internal.AST.Operation       Data.Morpheus.Types.Internal.AST.Selection       Data.Morpheus.Types.Internal.AST.Value       Data.Morpheus.Types.Internal.Resolving@@ -359,9 +408,12 @@   other-modules:       Feature.Holistic.API       Feature.Input.Enum.API+      Feature.Input.Object.API+      Feature.Input.Scalar.API       Feature.InputType.API       Feature.Schema.A2       Feature.Schema.API+      Feature.TypeInference.API       Feature.UnionType.API       Feature.WrappedTypeName.API       Lib

@@ -11,7 +11,9 @@ where  import           Data.Semigroup                 ( (<>) )-import           Data.Text                      ( Text )+import           Data.Text                      ( Text+                                                , intercalate+                                                ) import qualified Data.Text                     as T  -- MORPHEUS@@ -40,7 +42,7 @@ fragmentNameCollision = map toError  where   toError Ref { refName, refPosition } = GQLError-    { message      = "There can be only one fragment named \"" <> refName <> "\"."+    { message   = "There can be only one fragment named \"" <> refName <> "\"."     , locations = [refPosition]     } @@ -48,7 +50,7 @@ unusedFragment = map toError  where   toError Ref { refName, refPosition } = GQLError-    { message      = "Fragment \"" <> refName <> "\" is never used."+    { message   = "Fragment \"" <> refName <> "\" is never used."     , locations = [refPosition]     } @@ -60,7 +62,7 @@     [ "Cannot spread fragment \""     , refName $ head fragments     , "\" within itself via "-    , T.intercalate "," (map refName fragments)+    , T.intercalate ", " (map refName fragments)     , "."     ] @@ -70,19 +72,18 @@   where text = T.concat ["Unknown Fragment \"", key', "\"."]  -- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."-cannotBeSpreadOnType :: Maybe Text -> Text -> Position -> Text -> GQLErrors-cannotBeSpreadOnType key' type' position' selectionType' = errorMessage-  position'-  text+cannotBeSpreadOnType :: Maybe Text -> Text -> Position -> [Text] -> GQLErrors+cannotBeSpreadOnType key fragmentType position typeMembers = errorMessage+  position+  message  where-  text = T.concat-    [ "Fragment"-    , getName key'-    , " cannot be spread here as objects of type \""-    , selectionType'-    , "\" can never be of type \""-    , type'-    , "\"."-    ]-  getName (Just x') = T.concat [" \"", x', "\""]-  getName Nothing   = ""+  message =+    "Fragment "+      <> getName key+      <> "cannot be spread here as objects of type \""+      <> intercalate ", " typeMembers+      <> "\" can never be of type \""+      <> fragmentType+      <> "\"."+  getName (Just x) = "\"" <> x <> "\" "+  getName Nothing  = ""

@@ -13,19 +13,25 @@ import           Data.Aeson                     ( encode ) import           Data.ByteString.Lazy.Char8     ( unpack ) import           Data.Morpheus.Types.Internal.AST.Value-                                                ( Value )+                                                ( ResolvedValue ) import           Data.Text                      ( Text ) import qualified Data.Text                     as T                                                 ( concat                                                 , intercalate                                                 , pack                                                 )+++import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( GQLErrors )+ type InputValidation a = Either InputError a  data InputError-  = UnexpectedType [Prop] Text Value (Maybe Text)+  = UnexpectedType [Prop] Text ResolvedValue (Maybe Text)   | UndefinedField [Prop] Text   | UnknownField [Prop] Text+  | GlobalInputError GQLErrors  data Prop =   Prop@@ -33,17 +39,20 @@     , propType :: Text     } -inputErrorMessage :: InputError -> Text+inputErrorMessage :: InputError -> Either GQLErrors Text inputErrorMessage (UnexpectedType path type' value errorMessage) =-  expectedTypeAFoundB path type' value errorMessage-inputErrorMessage (UndefinedField path' field') = undefinedField path' field'-inputErrorMessage (UnknownField   path' field') = unknownField path' field'+  Right $ expectedTypeAFoundB path type' value errorMessage+inputErrorMessage (UndefinedField path' field') =+  Right $ undefinedField path' field'+inputErrorMessage (UnknownField path' field') =+  Right $ unknownField path' field'+inputErrorMessage (GlobalInputError err) = Left err  pathToText :: [Prop] -> Text pathToText []    = "" pathToText path' = T.concat ["on ", T.intercalate "." $ fmap propKey path'] -expectedTypeAFoundB :: [Prop] -> Text -> Value -> Maybe Text -> Text+expectedTypeAFoundB :: [Prop] -> Text -> ResolvedValue -> Maybe Text -> Text expectedTypeAFoundB path' expected found Nothing = T.concat   [ pathToText path'   , " Expected type \""

@@ -5,6 +5,7 @@   , internalArgumentError   , internalUnknownTypeMessage   , internalError+  , internalResolvingError   ) where @@ -23,7 +24,7 @@                                                 , Failure(..)                                                 ) import           Data.Morpheus.Types.Internal.AST.Value-                                                ( Value(..) )+                                                ( ValidValue )   -- GQL:: if no mutation defined -> "Schema is not configured for mutations."@@ -32,6 +33,11 @@ internalError x = failure $ globalErrorMessage $ "INTERNAL ERROR: " <> x  -- if type did not not found, but was defined by Schema+internalResolvingError :: Text -> GQLErrors+internalResolvingError = globalErrorMessage . ("INTERNAL RESOLVING ERROR:" <>)+++-- if type did not not found, but was defined by Schema internalUnknownTypeMessage :: Text -> GQLErrors internalUnknownTypeMessage x = globalErrorMessage   $ T.concat ["type did not not found, but was defined by Schema", x]@@ -41,6 +47,6 @@ internalArgumentError x = internalError $ "Argument " <> x  -- if value is already validated but value has different type-internalTypeMismatch :: Text -> Value -> Validation b+internalTypeMismatch :: Text -> ValidValue -> Validation b internalTypeMismatch text jsType =   internalError $ "Type mismatch " <> text <> T.pack (show jsType)

@@ -58,7 +58,8 @@ validateWith :: DataTypeLib -> (GQLQuery, String) -> Validation ClientQuery validateWith schema (rawRequest@GQLQuery { operation }, queryText) = do   validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest-  (queryArgsType, queryTypes) <- operationTypes schema-                                                (O.operationArgs operation)-                                                validOperation+  (queryArgsType, queryTypes) <- operationTypes+    schema+    (O.operationArguments operation)+    validOperation   return ClientQuery { queryText, queryTypes, queryArgsType }

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs               #-} {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE OverloadedStrings   #-}@@ -23,25 +24,24 @@ import           Data.Morpheus.Execution.Internal.Utils                                                 ( nameSpaceType ) import           Data.Morpheus.Types.Internal.AST-                                                ( DefaultValue-                                                , Operation(..)+                                                ( Operation(..)                                                 , ValidOperation                                                 , Variable(..)                                                 , VariableDefinitions                                                 , getOperationName                                                 , getOperationDataType                                                 , Selection(..)-                                                , SelectionRec(..)-                                                , SelectionSet+                                                , SelectionContent(..)+                                                , ValidSelectionSet                                                 , ValidSelection-                                                , Ref(..) +                                                , Ref(..)                                                 , DataField(..)-                                                , DataTyCon(..)+                                                , DataTypeContent(..)                                                 , DataType(..)                                                 , DataTypeKind(..)                                                 , DataTypeLib(..)                                                 , Key-                                                , TypeAlias(..)+                                                , TypeRef(..)                                                 , DataEnumValue(..)                                                 , allDataTypes                                                 , lookupType@@ -50,6 +50,7 @@                                                 , TypeD(..)                                                 , lookupDeprecated                                                 , lookupDeprecatedReason+                                                , RAW                                                 ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( GQLErrors@@ -79,13 +80,13 @@ operationTypes lib variables = genOperation  where   genOperation operation@Operation { operationName, operationSelection } = do-    datatype            <- DataObject <$> getOperationDataType operation lib+    datatype            <- getOperationDataType operation lib     (queryTypes, enums) <- genRecordType []                                          (getOperationName operationName)                                          datatype                                          operationSelection     inputTypeRequests <- resolveUpdates []-      $ map (scanInputTypes lib . variableType . snd) variables+      $ map (scanInputTypes lib . typeConName . variableType . snd) variables     inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums)     pure       ( rootArguments (getOperationName operationName <> "Args")@@ -112,15 +113,12 @@       , tMeta      = Nothing       }      where-      fieldD :: (Text, Variable DefaultValue) -> DataField-      fieldD (key, Variable { variableType, variableTypeWrappers }) = DataField+      fieldD :: (Text, Variable RAW) -> DataField+      fieldD (key, Variable { variableType }) = DataField         { fieldName     = key         , fieldArgs     = []         , fieldArgsType = Nothing-        , fieldType     = TypeAlias { aliasWrappers = variableTypeWrappers-                                    , aliasTyCon    = variableType-                                    , aliasArgs     = Nothing-                                    }+        , fieldType     = variableType         , fieldMeta     = Nothing         }   ---------------------------------------------------------@@ -129,7 +127,7 @@     :: [Key]     -> Key     -> DataType-    -> SelectionSet+    -> ValidSelectionSet     -> Validation ([ClientType], [Text])   genRecordType path name dataType recordSelSet = do     (con, subTypes, requests) <- genConsD (unpack name) dataType recordSelSet@@ -150,7 +148,7 @@     genConsD       :: String       -> DataType-      -> SelectionSet+      -> ValidSelectionSet       -> Validation (ConsD, [ClientType], [Text])     genConsD cName datatype selSet = do       (cFields, subTypes, requests) <- unzip3 <$> traverse genField selSet@@ -184,13 +182,13 @@         ------------------------------------------         subTypesBySelection           :: DataType -> ValidSelection -> Validation ([ClientType], [Text])-        subTypesBySelection dType Selection { selectionRec = SelectionField } =-          leafType dType+        subTypesBySelection dType Selection { selectionContent = SelectionField }+          = leafType dType           --withLeaf buildLeaf dType-        subTypesBySelection dType Selection { selectionRec = SelectionSet selectionSet }+        subTypesBySelection dType Selection { selectionContent = SelectionSet selectionSet }           = genRecordType fieldPath (typeFrom [] dType) dType selectionSet           ---- UNION-        subTypesBySelection dType Selection { selectionRec = UnionSelection unionSelections }+        subTypesBySelection dType Selection { selectionContent = UnionSelection unionSelections }           = do             (tCons, subTypes, requests) <-               unzip3 <$> mapM getUnionType unionSelections@@ -213,55 +211,58 @@  scanInputTypes :: DataTypeLib -> Key -> LibUpdater [Key] scanInputTypes lib name collected | name `elem` collected = pure collected-                                  | otherwise = getType lib name >>= scanType+                                  | otherwise = getType lib name >>= scanInpType  where-  scanType (DataInputObject DataTyCon { typeData }) = resolveUpdates-    (name : collected)-    (map toInputTypeD typeData)+  scanInpType DataType { typeContent, typeName } = scanType typeContent    where-    toInputTypeD :: (Text, DataField) -> LibUpdater [Key]-    toInputTypeD (_, DataField { fieldType = TypeAlias { aliasTyCon } }) =-      scanInputTypes lib aliasTyCon-  scanType (DataEnum DataTyCon { typeName }) = pure (collected <> [typeName])-  scanType _ = pure collected+    scanType (DataInputObject fields) = resolveUpdates+      (name : collected)+      (map toInputTypeD fields)+     where+      toInputTypeD :: (Text, DataField) -> LibUpdater [Key]+      toInputTypeD (_, DataField { fieldType = TypeRef { typeConName } }) =+        scanInputTypes lib typeConName+    scanType (DataEnum _) = pure (collected <> [typeName])+    scanType _            = pure collected  buildInputType :: DataTypeLib -> Text -> Validation [ClientType]-buildInputType lib name = getType lib name >>= subTypes+buildInputType lib name = getType lib name >>= generateTypes  where-  subTypes (DataInputObject DataTyCon { typeName, typeData }) = do-    fields <- traverse toFieldD typeData-    pure+  generateTypes DataType { typeName, typeContent } = subTypes typeContent+   where+    subTypes (DataInputObject inputFields) = do+      fields <- traverse toFieldD inputFields+      pure+        [ ClientType+            { clientType =+              TypeD+                { tName      = unpack typeName+                , tNamespace = []+                , tCons = [ConsD { cName = unpack typeName, cFields = fields }]+                , tMeta      = Nothing+                }+            , clientKind = KindInputObject+            }+        ]+     where+      toFieldD :: (Text, DataField) -> Validation DataField+      toFieldD (_, field@DataField { fieldType }) = do+        typeConName <- typeFrom [] <$> getType lib (typeConName fieldType)+        pure $ field { fieldType = fieldType { typeConName } }+    subTypes (DataEnum enumTags) = pure       [ ClientType-          { clientType =-            TypeD-              { tName      = unpack typeName-              , tNamespace = []-              , tCons = [ConsD { cName = unpack typeName, cFields = fields }]-              , tMeta      = Nothing-              }-          , clientKind = KindInputObject+          { clientType = TypeD { tName      = unpack typeName+                               , tNamespace = []+                               , tCons      = map enumOption enumTags+                               , tMeta      = Nothing+                               }+          , clientKind = KindEnum           }       ]--   where-    toFieldD :: (Text, DataField) -> Validation DataField-    toFieldD (_, field@DataField { fieldType }) = do-      aliasTyCon <- typeFrom [] <$> getType lib (aliasTyCon fieldType)-      pure $ field { fieldType = fieldType { aliasTyCon } }-  subTypes (DataEnum DataTyCon { typeName, typeData }) = pure-    [ ClientType-        { clientType = TypeD { tName      = unpack typeName-                             , tNamespace = []-                             , tCons      = map enumOption typeData-                             , tMeta      = Nothing-                             }-        , clientKind = KindEnum-        }-    ]-   where-    enumOption DataEnumValue { enumName } =-      ConsD { cName = unpack enumName, cFields = [] }-  subTypes _ = pure []+     where+      enumOption DataEnumValue { enumName } =+        ConsD { cName = unpack enumName, cFields = [] }+    subTypes _ = pure []   lookupFieldType@@ -270,14 +271,14 @@   -> DataType   -> Position   -> Text-  -> Validation (DataType, TypeAlias)-lookupFieldType lib path (DataObject DataTyCon { typeData, typeName }) refPosition key-  = case lookup key typeData of-    Just DataField { fieldType = alias@TypeAlias { aliasTyCon }, fieldMeta } ->-      checkDeprecated >> (trans <$> getType lib aliasTyCon)+  -> Validation (DataType, TypeRef)+lookupFieldType lib path DataType { typeContent = DataObject typeContent, typeName } refPosition key+  = case lookup key typeContent of+    Just DataField { fieldType = alias@TypeRef { typeConName }, fieldMeta } ->+      checkDeprecated >> (trans <$> getType lib typeConName)      where       trans x =-        (x, alias { aliasTyCon = typeFrom path x, aliasArgs = Nothing })+        (x, alias { typeConName = typeFrom path x, typeArgs = Nothing })       ------------------------------------------------------------------       checkDeprecated :: Validation ()       checkDeprecated = case fieldMeta >>= lookupDeprecated of@@ -288,16 +289,20 @@                                      (lookupDeprecatedReason deprecation)         Nothing -> pure ()     -------------------    Nothing -> failure-      (compileError $ "cant find field \"" <> pack (show typeData) <> "\"")+    Nothing ->+      failure+        (compileError $ "cant find field \"" <> pack (show typeContent) <> "\"") lookupFieldType _ _ dt _ _ =   failure (compileError $ "Type should be output Object \"" <> pack (show dt))   leafType :: DataType -> Validation ([ClientType], [Text])-leafType (DataEnum DataTyCon { typeName }) = pure ([], [typeName])-leafType DataScalar{} = pure ([], [])-leafType _ = failure $ compileError "Invalid schema Expected scalar"+leafType DataType { typeName, typeContent } = fromKind typeContent+ where+  fromKind :: DataTypeContent -> Validation ([ClientType], [Text])+  fromKind DataEnum{} = pure ([], [typeName])+  fromKind DataScalar{} = pure ([], [])+  fromKind _ = failure $ compileError "Invalid schema Expected scalar"  getType :: DataTypeLib -> Text -> Validation DataType getType lib typename =@@ -312,9 +317,9 @@ typeFromScalar _         = "ScalarValue"  typeFrom :: [Key] -> DataType -> Text-typeFrom _ (DataScalar DataTyCon { typeName }) = typeFromScalar typeName-typeFrom _ (DataEnum x) = typeName x-typeFrom _ (DataInputObject x) = typeName x-typeFrom path (DataObject x) = pack $ nameSpaceType path $ typeName x-typeFrom path (DataUnion x) = pack $ nameSpaceType path $ typeName x-typeFrom _ (DataInputUnion x) = typeName x+typeFrom path DataType { typeName, typeContent } = __typeFrom typeContent+ where+  __typeFrom DataScalar{} = typeFromScalar typeName+  __typeFrom DataObject{} = pack $ nameSpaceType path typeName+  __typeFrom DataUnion{}  = pack $ nameSpaceType path typeName+  __typeFrom _            = typeName

@@ -23,12 +23,12 @@ import           Data.Morpheus.Types.Internal.AST                                                 ( ArgsType(..)                                                 , DataField(..)-                                                , DataTyCon(..)+                                                , DataTypeContent(..)                                                 , DataType(..)                                                 , DataTypeKind(..)                                                 , OperationType(..)                                                 , ResolverKind(..)-                                                , TypeAlias(..)+                                                , TypeRef(..)                                                 , DataEnumValue(..)                                                 , sysTypes                                                 , ConsD(..)@@ -42,7 +42,7 @@ renderTHTypes namespace lib = traverse renderTHType lib  where   renderTHType :: (Text, DataType) -> Validation GQLTypeD-  renderTHType (tyConName, x) = genType x+  renderTHType (tyConName, x) = generateType x    where     genArgsTypeName fieldName | namespace = sysName tyConName <> argTName                               | otherwise = argTName@@ -73,19 +73,19 @@     sysName = unpack . genTypeName     ---------------------------------------------------------------------------------------------     genField :: (Text, DataField) -> DataField-    genField (_, field@DataField { fieldType = alias@TypeAlias { aliasTyCon } })-      = field { fieldType = alias { aliasTyCon = genFieldTypeName aliasTyCon }+    genField (_, field@DataField { fieldType = alias@TypeRef { typeConName } })+      = field { fieldType = alias { typeConName = genFieldTypeName typeConName }               }     ---------------------------------------------------------------------------------------------     genResField :: (Text, DataField) -> DataField-    genResField (_, field@DataField { fieldName, fieldArgs, fieldType = alias@TypeAlias { aliasTyCon } })-      = field { fieldType     = alias { aliasTyCon = ftName, aliasArgs }+    genResField (_, field@DataField { fieldName, fieldArgs, fieldType = alias@TypeRef { typeConName } })+      = field { fieldType     = alias { typeConName = ftName, typeArgs }               , fieldArgsType               }      where-      ftName    = genFieldTypeName aliasTyCon+      ftName   = genFieldTypeName typeConName       ----------------------------------------      aliasArgs = case lookup aliasTyCon lib of+      typeArgs = case typeContent <$> lookup typeConName lib of         Just DataObject{} -> Just "m"         Just DataUnion{}  -> Just "m"         _                 -> Nothing@@ -96,37 +96,38 @@         argsTypeName | null fieldArgs = "()"                      | otherwise = pack $ genArgsTypeName $ unpack fieldName         ---------------------------------------        getFieldType key = case lookup key lib of+        getFieldType key = case typeContent <$> lookup key lib of           Nothing           -> ExternalResolver           Just DataObject{} -> TypeVarResolver           Just DataUnion{}  -> TypeVarResolver           Just _            -> PlainResolver     ---------------------------------------------    genType dt@(DataEnum DataTyCon { typeName, typeData, typeMeta }) = pure-      GQLTypeD+    generateType dt@DataType { typeName, typeContent, typeMeta } = genType+      typeContent+     where+      genType (DataEnum tags) = pure GQLTypeD         { typeD        = TypeD { tName      = sysName typeName                                , tNamespace = []-                               , tCons      = map enumOption typeData+                               , tCons      = map enumOption tags                                , tMeta      = typeMeta                                }         , typeKindD    = KindEnum         , typeArgD     = []         , typeOriginal = (typeName, dt)         }-     where-      enumOption DataEnumValue { enumName } =-        ConsD { cName = sysName enumName, cFields = [] }-    genType (DataScalar _) =-      internalError "Scalar Types should defined By Native Haskell Types"-    genType (DataInputUnion _) = internalError "Input Unions not Supported"-    genType dt@(DataInputObject DataTyCon { typeName, typeData, typeMeta }) =-      pure GQLTypeD+       where+        enumOption DataEnumValue { enumName } =+          ConsD { cName = sysName enumName, cFields = [] }+      genType (DataScalar _) =+        internalError "Scalar Types should defined By Native Haskell Types"+      genType (DataInputUnion _) = internalError "Input Unions not Supported"+      genType (DataInputObject fields) = pure GQLTypeD         { typeD        =           TypeD             { tName      = sysName typeName             , tNamespace = []             , tCons      = [ ConsD { cName   = sysName typeName-                                   , cFields = map genField typeData+                                   , cFields = map genField fields                                    }                            ]             , tMeta      = typeMeta@@ -135,51 +136,52 @@         , typeArgD     = []         , typeOriginal = (typeName, dt)         }-    genType dt@(DataObject DataTyCon { typeName, typeData, typeMeta }) = do-      typeArgD <- concat <$> traverse genArgumentType typeData-      pure GQLTypeD-        { typeD        = TypeD-                           { tName      = sysName typeName-                           , tNamespace = []-                           , tCons = [ ConsD { cName = sysName typeName-                                             , cFields = map genResField typeData-                                             }-                                     ]-                           , tMeta      = typeMeta-                           }-        , typeKindD    = if typeName == "Subscription"-                           then KindObject (Just Subscription)-                           else KindObject Nothing-        , typeArgD-        , typeOriginal = (typeName, dt)-        }-    genType dt@(DataUnion DataTyCon { typeName, typeData, typeMeta }) = do-      let tCons = map unionCon typeData-      pure GQLTypeD-        { typeD        = TypeD { tName      = unpack typeName-                               , tNamespace = []-                               , tCons-                               , tMeta      = typeMeta-                               }-        , typeKindD    = KindUnion-        , typeArgD     = []-        , typeOriginal = (typeName, dt)-        }-     where-      unionCon memberName = ConsD-        { cName-        , cFields = [ DataField-                        { fieldName     = pack $ "un" <> cName-                        , fieldType     = TypeAlias { aliasTyCon = pack utName-                                                    , aliasArgs = Just "m"-                                                    , aliasWrappers = []-                                                    }-                        , fieldMeta     = Nothing-                        , fieldArgs     = []-                        , fieldArgsType = Nothing-                        }-                    ]-        }+      genType (DataObject fields) = do+        typeArgD <- concat <$> traverse genArgumentType fields+        pure GQLTypeD+          { typeD        =+            TypeD+              { tName      = sysName typeName+              , tNamespace = []+              , tCons      = [ ConsD { cName   = sysName typeName+                                     , cFields = map genResField fields+                                     }+                             ]+              , tMeta      = typeMeta+              }+          , typeKindD    = if typeName == "Subscription"+                             then KindObject (Just Subscription)+                             else KindObject Nothing+          , typeArgD+          , typeOriginal = (typeName, dt)+          }+      genType (DataUnion members) = do+        let tCons = map unionCon members+        pure GQLTypeD+          { typeD        = TypeD { tName      = unpack typeName+                                 , tNamespace = []+                                 , tCons+                                 , tMeta      = typeMeta+                                 }+          , typeKindD    = KindUnion+          , typeArgD     = []+          , typeOriginal = (typeName, dt)+          }        where-        cName  = sysName typeName <> utName-        utName = sysName memberName+        unionCon memberName = ConsD+          { cName+          , cFields = [ DataField+                          { fieldName     = pack $ "un" <> cName+                          , fieldType     = TypeRef { typeConName = pack utName+                                                    , typeArgs = Just "m"+                                                    , typeWrappers = []+                                                    }+                          , fieldMeta     = Nothing+                          , fieldArgs     = []+                          , fieldArgsType = Nothing+                          }+                      ]+          }+         where+          cName  = sysName typeName <> utName+          utName = sysName memberName

@@ -47,7 +47,7 @@    where     gqlInstances       | isObject typeKindD && isInput typeKindD-      = [deriveObjectRep (typeD, Just typeKindD), deriveDecode typeD]+      = [deriveObjectRep (typeD, Nothing), deriveDecode typeD]       | isObject typeKindD       = [deriveObjectRep (typeD, Just typeKindD), deriveEncode gqlType]       | otherwise

@@ -18,30 +18,30 @@ import           Data.Morpheus.Execution.Internal.Decode                                                 ( decodeFieldWith                                                 , decodeObjectExpQ+                                                , withObject                                                 ) import           Data.Morpheus.Execution.Server.Decode                                                 ( Decode(..)-                                                , DecodeObject(..)+                                                , DecodeType(..)                                                 ) import           Data.Morpheus.Types.Internal.AST                                                 ( TypeD(..)-                                                , Object+                                                , ValidValue                                                 ) import           Data.Morpheus.Types.Internal.TH                                                 ( instanceHeadT ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( Validation ) --(.:) :: Decode a => Object -> Text -> Validation a-object .: selectorName = decodeFieldWith decode selectorName object+(.:) :: Decode a => ValidValue -> Text -> Validation a+value .: selectorName = withObject (decodeFieldWith decode selectorName) value  deriveDecode :: TypeD -> Q [Dec] deriveDecode TypeD { tName, tCons = [cons] } =   pure <$> instanceD (cxt []) appHead methods  where-  appHead = instanceHeadT ''DecodeObject tName []-  methods = [funD 'decodeObject [clause argsE (normalB body) []]]+  appHead = instanceHeadT ''DecodeType tName []+  methods = [funD 'decodeType [clause argsE (normalB body) []]]    where     argsE = map (varP . mkName) ["o"]     body  = decodeObjectExpQ [|(.:)|] cons

@@ -17,7 +17,7 @@ -- MORPHEUS import           Data.Morpheus.Execution.Server.Encode                                                 ( Encode(..)-                                                , ObjectResolvers(..)+                                                , ExploreResolvers(..)                                                 ) import           Data.Morpheus.Types.GQLType    ( TRUE ) import           Data.Morpheus.Types.Internal.AST@@ -34,6 +34,7 @@                                                 , MapStrategy(..)                                                 , LiftEither                                                 , ResolvingStrategy+                                                , DataResolver(..)                                                 ) import           Data.Morpheus.Types.Internal.TH                                                 ( applyT@@ -88,15 +89,16 @@          ]   -------------------------------------------------------------------   -- defines: instance <constraint> =>  ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where-  appHead =-    instanceHeadMultiT ''ObjectResolvers (conT ''TRUE) (mainType : instanceArgs)+  appHead = instanceHeadMultiT ''ExploreResolvers+                               (conT ''TRUE)+                               (mainType : instanceArgs)   ------------------------------------------------------------------   -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]-  methods = [funD 'objectResolvers [clause argsE (normalB body) []]]+  methods = [funD 'exploreResolvers [clause argsE (normalB body) []]]    where     argsE = [varP (mkName "_"), destructRecord tName varNames]-    body  = listE $ map decodeVar varNames-    decodeVar name = [|(name, encode $(varName))|]+    body  = appE (conE 'ObjectRes) (listE $ map decodeVar varNames)+    decodeVar name = [| (name, encode $(varName))|]       where varName = varE $ mkName name     varNames = map (unpack . fieldName) cFields deriveEncode _ = pure []

@@ -19,12 +19,10 @@ import           Data.Morpheus.Execution.Internal.Declare                                                 ( tyConArgs ) import           Data.Morpheus.Kind             ( ENUM-                                                , INPUT_OBJECT-                                                , INPUT_UNION-                                                , OBJECT                                                 , SCALAR-                                                , UNION                                                 , WRAPPER+                                                , INPUT+                                                , OUTPUT                                                 ) import           Data.Morpheus.Types.GQLType    ( GQLType(..)                                                 , TRUE@@ -84,9 +82,9 @@     ---------------------------------     toKIND KindScalar      = ''SCALAR     toKIND KindEnum        = ''ENUM-    toKIND (KindObject _)  = ''OBJECT-    toKIND KindUnion       = ''UNION-    toKIND KindInputObject = ''INPUT_OBJECT+    toKIND (KindObject _)  = ''OUTPUT+    toKIND KindUnion       = ''OUTPUT+    toKIND KindInputObject = ''INPUT     toKIND KindList        = ''WRAPPER     toKIND KindNonNull     = ''WRAPPER-    toKIND KindInputUnion  = ''INPUT_UNION+    toKIND KindInputUnion  = ''INPUT

@@ -9,15 +9,15 @@  import Data.Maybe(maybeToList) import           Data.Proxy                                (Proxy (..))-import           Data.Text                                 (unpack)+import           Data.Text                                 (unpack,Text) import           Data.Typeable                             (Typeable) import           Language.Haskell.TH    -- MORPHEUS import           Data.Morpheus.Execution.Internal.Declare  (tyConArgs)-import           Data.Morpheus.Execution.Server.Introspect (Introspect (..), ObjectFields (..))+import           Data.Morpheus.Execution.Server.Introspect (Introspect (..), objectFields, IntrospectRep (..),TypeScope(..)) import           Data.Morpheus.Types.GQLType               (GQLType (__typeName), TRUE)-import           Data.Morpheus.Types.Internal.AST          (ConsD (..), TypeD (..), ArgsType (..),Key, DataType(..), DataField (..),insertType,DataTypeKind(..), TypeAlias (..))+import           Data.Morpheus.Types.Internal.AST          (ConsD (..), TypeD (..), ArgsType (..),Key, DataType(..), DataTypeContent(..), DataField (..),insertType,DataTypeKind(..), TypeRef (..)) import           Data.Morpheus.Types.Internal.TH           (instanceFunD, instanceProxyFunD,instanceHeadT, instanceHeadMultiT, typeT)  @@ -25,14 +25,23 @@ -- FIXME: dirty fix for introspection instanceIntrospect ("__DirectiveLocation",_) = pure [] instanceIntrospect ("__TypeKind",_) = pure []-instanceIntrospect (name, DataEnum enumType) =-  pure <$> instanceD (cxt []) iHead [defineIntrospect]+instanceIntrospect (name, DataType {+      typeContent = DataEnum enumType,+      typeName+      , typeMeta+      , typeFingerprint+    }) = pure <$> instanceD (cxt []) iHead [defineIntrospect]   where     -----------------------------------------------     iHead = instanceHeadT ''Introspect  (unpack name) []     defineIntrospect = instanceProxyFunD ('introspect,body)       where-        body =[| insertType (name, DataEnum enumType) |]+        body =[| insertType (name,DataType {+          typeName+          ,typeMeta+          , typeFingerprint+          ,typeContent = DataEnum enumType+        }) |] instanceIntrospect _ = pure []  -- [((Text, DataField), TypeUpdater)]@@ -40,16 +49,20 @@ deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, tKind) =   pure <$> instanceD (cxt constrains) iHead methods   where+    mainTypeName = typeT (mkName tName) typeArgs     typeArgs = concatMap tyConArgs (maybeToList tKind)     constrains = map conTypeable typeArgs       where         conTypeable name = typeT ''Typeable [name]     ------------------------------------------------    iHead = instanceHeadMultiT ''ObjectFields (conT ''TRUE) [typeT (mkName tName) typeArgs]-    methods = [instanceFunD 'objectFields ["_proxy1", "_proxy2"] body]+    iHead = instanceHeadMultiT ''IntrospectRep (conT ''TRUE) [mainTypeName]+    methods = [instanceFunD 'introspectRep ["_proxy1", "_proxy2"] body]       where-        body = [|($(buildFields cFields), concat $(buildTypes cFields))|]+        body +          | tKind == Just KindInputObject || null tKind  = [| (DataInputObject  $(buildFields cFields), concat $(buildTypes cFields))|]+          | otherwise  =  [| (DataObject $(buildFields cFields), concat $(buildTypes cFields))|] deriveObjectRep _ = pure []+      buildTypes :: [DataField] -> ExpQ buildTypes = listE . concatMap introspectField@@ -58,30 +71,35 @@       [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgsType       where         inputTypes (Just ArgsType {argsTypeName})-          | argsTypeName /= "()" = [[|snd $ objectFields (Proxy :: Proxy TRUE) $(proxyT tAlias)|]]+          | argsTypeName /= "()" = [[|snd $ objectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]]           where-            tAlias = TypeAlias {aliasTyCon = argsTypeName, aliasWrappers = [], aliasArgs = Nothing}+            tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing}         inputTypes _ = [] -proxyT :: TypeAlias -> Q Exp-proxyT TypeAlias {aliasTyCon, aliasArgs} = [|(Proxy :: Proxy $(genSig aliasArgs))|]+conTX :: Text -> Q Type    +conTX =  conT . mkName . unpack++varTX :: Text -> Q Type    +varTX =  varT . mkName . unpack++proxyT :: TypeRef -> Q Exp+proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|]   where-    genSig (Just m) = appT (conT $ mkName $ unpack aliasTyCon) (varT $ mkName $ unpack m)-    genSig _        = conT $ mkName $ unpack aliasTyCon+    genSig (Just m) = appT (conTX typeConName) (varTX m)+    genSig _        = conTX typeConName  buildFields :: [DataField] -> ExpQ buildFields = listE . map buildField   where-    buildField DataField {fieldName, fieldArgs, fieldType = alias@TypeAlias {aliasArgs, aliasWrappers}, fieldMeta} =-      [|( fName+    buildField DataField {fieldName, fieldArgs, fieldType = alias@TypeRef {typeArgs, typeWrappers}, fieldMeta} =+      [|( fieldName         , DataField-            { fieldName = fName+            { fieldName             , fieldArgs = fArgs             , fieldArgsType = Nothing-            , fieldType = TypeAlias {aliasTyCon = __typeName $(proxyT alias), aliasArgs = aArgs, aliasWrappers}+            , fieldType = TypeRef {typeConName = __typeName $(proxyT alias), typeArgs = aArgs, typeWrappers}             , fieldMeta             })|]       where-        fName = unpack fieldName         fArgs = map (\(k, v) -> (unpack k, v)) fieldArgs-        aArgs = unpack <$> aliasArgs+        aArgs = unpack <$> typeArgs

@@ -30,7 +30,7 @@                                                 , DataField(..)                                                 , DataTypeKind(..)                                                 , DataTypeKind(..)-                                                , TypeAlias(..)+                                                , TypeRef(..)                                                 , TypeWrapper(..)                                                 , isOutputObject                                                 , isSubscription@@ -42,16 +42,16 @@  type Arrow = (->) -declareTypeAlias :: Bool -> TypeAlias -> Type-declareTypeAlias isSub TypeAlias { aliasTyCon, aliasWrappers, aliasArgs } =-  wrappedT aliasWrappers+declareTypeRef :: Bool -> TypeRef -> Type+declareTypeRef isSub TypeRef { typeConName, typeWrappers, typeArgs } =+  wrappedT typeWrappers  where   wrappedT :: [TypeWrapper] -> Type   wrappedT (TypeList  : xs) = AppT (ConT ''[]) $ wrappedT xs   wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs-  wrappedT []               = decType aliasArgs+  wrappedT []               = decType typeArgs   -------------------------------------------------------  typeName = ConT (mkName $ unpack aliasTyCon)+  typeName = ConT (mkName $ unpack typeConName)   --------------------------------------------   decType _ | isSub =     AppT typeName (AppT (ConT ''UnSubResolver) (VarT $ mkName "m"))@@ -98,4 +98,4 @@           | isResolver                       = AppT monadVar result           | otherwise                        = result         -------------------------------------------------        result = declareTypeAlias (maybe False isSubscription kindD) fieldType+        result = declareTypeRef (maybe False isSubscription kindD) fieldType

@@ -13,7 +13,6 @@   ) where -import           Data.Semigroup                 ( (<>) ) import           Data.Text                      ( unpack ) import           Language.Haskell.TH            ( ExpQ                                                 , conE@@ -23,17 +22,20 @@                                                 )  -- MORPHEUS-import           Data.Morpheus.Error.Internal   ( internalArgumentError-                                                , internalTypeMismatch+import           Data.Morpheus.Error.Internal   ( +                                                internalTypeMismatch                                                 ) import           Data.Morpheus.Types.Internal.AST                                                 ( DataField(..)                                                 , Key                                                 , ConsD(..) -                                                , Object-                                                , Value(..))+                                                , ValidObject+                                                , Value(..)+                                                , ValidValue+                                                , Message+                                                ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation )+                                                ( Validation, Failure(..) )   decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ@@ -52,32 +54,31 @@                                                [|fName|]       where fName = unpack fieldName -withObject :: (Object -> Validation a) -> Value -> Validation a+withObject :: (ValidObject -> Validation a) -> ValidValue -> Validation a withObject f (Object object) = f object withObject _ isType          = internalTypeMismatch "Object" isType -withMaybe :: Monad m => (Value -> m a) -> Value -> m (Maybe a)+withMaybe :: Monad m => (ValidValue -> m a) -> ValidValue -> m (Maybe a) withMaybe _      Null = pure Nothing withMaybe decode x    = Just <$> decode x -withList :: (Value -> Validation a) -> Value -> Validation [a]+withList :: (ValidValue -> Validation a) -> ValidValue -> Validation [a] withList decode (List li) = mapM decode li withList _      isType    = internalTypeMismatch "List" isType -withEnum :: (Key -> Validation a) -> Value -> Validation a+withEnum :: (Key -> Validation a) -> ValidValue -> Validation a withEnum decode (Enum value) = decode value withEnum _      isType       = internalTypeMismatch "Enum" isType -withUnion :: (Key -> Object -> Object -> Validation a) -> Object -> Validation a-withUnion decoder unions = case lookup "tag" unions of+withUnion :: (Key -> ValidObject -> ValidObject -> Validation a) -> ValidObject -> Validation a+withUnion decoder unions = case lookup "__typename" unions of   Just (Enum key) -> case lookup key unions of-    Nothing -> internalArgumentError-      ("type \"" <> key <> "\" was not provided on object")+    Nothing -> withObject (decoder key unions) (Object [])     Just value -> withObject (decoder key unions) value-  Just _  -> internalArgumentError "tag must be Enum"-  Nothing -> internalArgumentError "tag not found on Input Union"+  Just _  -> failure ("__typename must be Enum" :: Message)+  Nothing -> failure ("__typename not found on Input Union" :: Message) -decodeFieldWith :: (Value -> Validation a) -> Key -> Object -> Validation a+decodeFieldWith :: (ValidValue -> Validation a) -> Key -> ValidObject -> Validation a decodeFieldWith decoder name object = case lookup name object of-  Nothing    -> internalArgumentError ("Missing Field: \"" <> name <> "\"")+  Nothing    -> decoder Null   Just value -> decoder value

@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-}@@ -9,57 +10,67 @@ {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE TupleSections         #-}  module Data.Morpheus.Execution.Server.Decode   ( decodeArguments   , Decode(..)-  , DecodeObject(..)+  , DecodeType(..)   ) where  import           Data.Proxy                     ( Proxy(..) )-import           Data.Semigroup                 ( (<>) )+import           Data.Semigroup                 ( Semigroup(..) ) import           Data.Text                      ( pack ) import           GHC.Generics  -- MORPHEUS-import           Data.Morpheus.Error.Internal   ( internalArgumentError-                                                , internalTypeMismatch+import           Data.Morpheus.Error.Internal   ( internalTypeMismatch+                                                , internalError                                                 ) import           Data.Morpheus.Execution.Internal.Decode                                                 ( decodeFieldWith-                                                , withEnum                                                 , withList                                                 , withMaybe                                                 , withObject                                                 , withUnion                                                 )-import           Data.Morpheus.Execution.Server.Generics.EnumRep-                                                ( EnumRep(..) ) import           Data.Morpheus.Kind             ( ENUM                                                 , GQL_KIND-                                                , INPUT_OBJECT-                                                , INPUT_UNION                                                 , SCALAR+                                                , OUTPUT+                                                , INPUT                                                 ) import           Data.Morpheus.Types.GQLScalar  ( GQLScalar(..)                                                 , toScalar                                                 ) import           Data.Morpheus.Types.GQLType    ( GQLType(KIND, __typeName) ) import           Data.Morpheus.Types.Internal.AST-                                                ( Key+                                                ( Name                                                 , Argument(..)-                                                , Arguments-                                                , Object+                                                , ValidArguments+                                                , ValidArgument+                                                , ValidObject                                                 , Value(..)+                                                , ValidValue                                                 ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation )+                                                ( Validation+                                                , Failure(..)+                                                )  +-- GENERIC+decodeArguments :: DecodeType a => ValidArguments -> Validation a+decodeArguments = decodeType . Object . map toObject+ where+  toObject :: (Name, ValidArgument) -> (Name, ValidValue)+  toObject (x, Argument { argumentValue }) = (x, argumentValue)++ -- | Decode GraphQL query arguments and input values class Decode a where-  decode :: Value -> Validation a+  decode :: ValidValue -> Validation a  instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where   decode = decodeKind (Proxy @(KIND a))@@ -72,7 +83,7 @@  -- | Decode GraphQL type with Specific Kind class DecodeKind (kind :: GQL_KIND) a where-  decodeKind :: Proxy kind -> Value -> Validation a+  decodeKind :: Proxy kind -> ValidValue -> Validation a  -- SCALAR instance (GQLScalar a) => DecodeKind SCALAR a where@@ -81,74 +92,140 @@     Left  errorMessage -> internalTypeMismatch errorMessage value  -- ENUM-instance (Generic a, EnumRep (Rep a)) => DecodeKind ENUM a where-  decodeKind _ = withEnum (fmap to . decodeEnum)+instance DecodeType a => DecodeKind ENUM a where+  decodeKind _ = decodeType --- INPUT_OBJECT-instance DecodeObject a => DecodeKind INPUT_OBJECT a where-  decodeKind _ = withObject decodeObject+-- TODO: remove  +instance DecodeType a => DecodeKind OUTPUT a where+  decodeKind _ = decodeType --- INPUT_UNION-instance (Generic a, GDecode (Rep a)) => DecodeKind INPUT_UNION a where-  decodeKind _ = withObject (fmap to . decodeUnion)+-- INPUT_OBJECT and  INPUT_UNION+instance DecodeType a => DecodeKind INPUT a where+  decodeKind _ = decodeType --- GENERIC-decodeArguments :: DecodeObject p => Arguments -> Validation p-decodeArguments = decodeObject . fmap toObject-  where toObject (x, y) = (x, argumentValue y) -class DecodeObject a where-  decodeObject :: Object -> Validation a+class DecodeType a where+  decodeType :: ValidValue -> Validation a -instance {-# OVERLAPPABLE #-} (Generic a, GDecode (Rep a)) => DecodeObject a where-  decodeObject = fmap to . __decodeObject . Object+instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a))=> DecodeType a where+  decodeType = fmap to . decodeRep . (, Cont D_CONS "") +-- data Inpuz  =+--    InputHuman Human  -- direct link: { __typename: Human, Human: {field: ""} }+--   | InputRecord { name :: Text, age :: Int } -- { __typename: InputRecord, InputRecord: {field: ""} }+--   | IndexedType Int Text  -- { __typename: InputRecord, _0:2 , _1:""  }+--   | Zeus                 -- { __typename: Zeus }+--     deriving (Generic, GQLType)++decideUnion+  :: ([Name], value -> Validation (f1 a))+  -> ([Name], value -> Validation (f2 a))+  -> Name+  -> value+  -> Validation ((:+:) f1 f2 a)+decideUnion (left, f1) (right, f2) name value+  | name `elem` left+  = L1 <$> f1 value+  | name `elem` right+  = R1 <$> f2 value+  | otherwise+  = failure $ "Constructor \"" <> name <> "\" could not find in Union"++data Tag = D_CONS | D_UNION deriving (Eq ,Ord)++data Cont = Cont {+  contKind:: Tag,+  typeName :: Name+}++data Info = Info {+  kind :: Tag,+  tagName :: [Name]+}++instance Semigroup Info where+  Info D_UNION t1 <> Info _       t2 = Info D_UNION (t1 <> t2)+  Info _       t1 <> Info D_UNION t2 = Info D_UNION (t1 <> t2)+  Info D_CONS  t1 <> Info D_CONS  t2 = Info D_CONS (t1 <> t2)+ -- -- GENERICS ---class GDecode f where-  unionTags :: Proxy f -> [Key]-  decodeUnion :: Object -> Validation (f a)-  __decodeObject :: Value -> Validation (f a)+class DecodeRep f where+  tags :: Proxy f -> Name -> Info+  decodeRep :: (ValidValue,Cont) -> Validation (f a) -instance GDecode U1 where-  unionTags _ = []-  __decodeObject _ = pure U1-  decodeUnion _ = pure U1+instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where+  tags _ = tags (Proxy @f)+  decodeRep (x, y) = M1 <$> decodeRep+    (x, y { typeName = pack $ datatypeName (undefined :: (M1 D d f a)) }) --- Recursive Decoding: (Selector (Rec1 ))-instance (Selector s, GQLType a, Decode a) => GDecode (M1 S s (K1 i a)) where-  unionTags _ = [__typeName (Proxy @a)]-  decodeUnion    = fmap (M1 . K1) . decode . Object-  __decodeObject = fmap (M1 . K1) . decodeRec+getEnumTag :: ValidObject -> Validation Name+getEnumTag [("enum", Enum value)] = pure value+getEnumTag _                      = internalError "bad union enum object"++instance (DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where+  tags _ = tags (Proxy @a) <> tags (Proxy @b)+  decodeRep = __decode    where-    fieldName = pack $ selName (undefined :: M1 S s f a)-    decodeRec = withObject (decodeFieldWith decode fieldName) -instance (Datatype c, GDecode f) => GDecode (M1 D c f) where-  decodeUnion = fmap M1 . decodeUnion-  unionTags _ = unionTags (Proxy @f)-  __decodeObject = fmap M1 . __decodeObject+    __decode (Object obj, cont) = withUnion handleUnion obj+     where+      handleUnion name unions object+        | name == typeName cont <> "EnumObject"+        = getEnumTag object >>= __decode . (, ctx) . Enum+        | [name] == l1+        = L1 <$> decodeRep (Object object, ctx)+        | [name] == r1+        = R1 <$> decodeRep (Object object, ctx)+        | otherwise+        = decideUnion (l1, decodeRep) (r1, decodeRep) name (Object unions, ctx)+      l1  = tagName l1t+      r1  = tagName r1t+      l1t = tags (Proxy @a) (typeName cont)+      r1t = tags (Proxy @b) (typeName cont)+      ctx = cont { contKind = kind (l1t <> r1t) }+    __decode (Enum name, cxt) = decideUnion+      (tagName $ tags (Proxy @a) (typeName cxt), decodeRep)+      (tagName $ tags (Proxy @b) (typeName cxt), decodeRep)+      name+      (Enum name, cxt)+    __decode _ = internalError "lists and scalars are not allowed in Union" -instance (Constructor c, GDecode f) => GDecode (M1 C c f) where-  decodeUnion = fmap M1 . decodeUnion-  unionTags _ = unionTags (Proxy @f)-  __decodeObject = fmap M1 . __decodeObject+instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where+  decodeRep = fmap M1 . decodeFields+  tags _ baseName = getTag (refType (Proxy @a))+   where+    getTag (Just memberRef)+      | isUnionRef memberRef = Info { kind = D_UNION, tagName = [memberRef] }+      | otherwise            = Info { kind = D_CONS, tagName = [consName] }+    getTag Nothing = Info { kind = D_CONS, tagName = [consName] }+    --------+    consName = pack $ conName unsafeType+    ----------+    isUnionRef x = baseName <> x == consName+    --------------------------+    unsafeType :: (M1 C c U1 x)+    unsafeType = undefined -instance (GDecode f, GDecode g) => GDecode (f :*: g) where-  __decodeObject gql = (:*:) <$> __decodeObject gql <*> __decodeObject gql+class DecodeFields f where+  refType :: Proxy f -> Maybe Name+  decodeFields :: (ValidValue,Cont) -> Validation (f a) -instance (GDecode a, GDecode b) => GDecode (a :+: b) where-  decodeUnion = withUnion handleUnion+instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where+  refType _ = Nothing+  decodeFields gql = (:*:) <$> decodeFields gql <*> decodeFields gql++instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where+  refType _ = Just $ __typeName (Proxy @a)+  decodeFields (value, Cont { contKind })+    | contKind == D_UNION = M1 . K1 <$> decode value+    | otherwise           = __decode value    where-    handleUnion name unions object-      | [name] == l1Tags = L1 <$> decodeUnion object-      | [name] == r1Tags = R1 <$> decodeUnion object-      | name `elem` l1Tags = L1 <$> decodeUnion unions-      | name `elem` r1Tags = R1 <$> decodeUnion unions-      | otherwise = internalArgumentError-        ("type \"" <> name <> "\" could not find in union")-     where-      l1Tags = unionTags $ Proxy @a-      r1Tags = unionTags $ Proxy @b-  unionTags _ = unionTags (Proxy @a) ++ unionTags (Proxy @b)+    __decode  = fmap (M1 . K1) . decodeRec+    fieldName = pack $ selName (undefined :: M1 S s f a)+    decodeRec = withObject (decodeFieldWith decode fieldName)++instance DecodeFields U1 where+  refType _ = Nothing+  decodeFields _ = pure U1

@@ -13,12 +13,11 @@  module Data.Morpheus.Execution.Server.Encode   ( EncodeCon-  , GResolver(..)   , Encode(..)   , encodeQuery   , encodeSubscription   , encodeMutation-  , ObjectResolvers(..)+  , ExploreResolvers(..)   ) where @@ -35,45 +34,41 @@ import           GHC.Generics  -- MORPHEUS-import           Data.Morpheus.Error.Internal   ( internalUnknownTypeMessage )+import           Data.Morpheus.Error.Internal   ( internalResolvingError ) import           Data.Morpheus.Execution.Server.Decode-                                                ( DecodeObject+                                                ( DecodeType                                                 , decodeArguments                                                 ) import           Data.Morpheus.Execution.Server.Generics.EnumRep                                                 ( EnumRep(..) ) import           Data.Morpheus.Kind             ( ENUM                                                 , GQL_KIND-                                                , OBJECT                                                 , ResContext(..)                                                 , SCALAR-                                                , UNION+                                                , OUTPUT                                                 , VContext(..)                                                 )-import           Data.Morpheus.Types.Types     ( MapKind+import           Data.Morpheus.Types.Types      ( MapKind                                                 , Pair(..)                                                 , mapKindFromList                                                 ) import           Data.Morpheus.Types.GQLScalar  ( GQLScalar(..) )-import           Data.Morpheus.Types.GQLType    ( GQLType-                                                  ( CUSTOM-                                                  , KIND-                                                  , __typeName-                                                  )-                                                )+import           Data.Morpheus.Types.GQLType    ( GQLType(..) ) import           Data.Morpheus.Types.Internal.AST-                                                ( Operation(..)+                                                ( Name+                                                , Operation(..)                                                 , ValidOperation-                                                , Key,-                                                  MUTATION+                                                , Key+                                                , MUTATION                                                 , OperationType                                                 , QUERY                                                 , SUBSCRIPTION                                                 , Selection(..)-                                                , SelectionRec(..)+                                                , SelectionContent(..)                                                 , ValidSelection                                                 , GQLValue(..)-                                                , Value(..)+                                                , ValidValue+                                                , ValidSelectionSet                                                 ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( MapStrategy(..)@@ -82,14 +77,18 @@                                                 , resolving                                                 , toResolver                                                 , ResolvingStrategy(..)-                                                , resolveObject                                                 , withObject                                                 , Validation                                                 , failure+                                                , DataResolver(..)+                                                , resolveObject+                                                , resolve__typename+                                                , resolveEnum+                                                , FieldRes                                                 )  class Encode resolver o e (m :: * -> *) where-  encode :: resolver -> (Key, ValidSelection) -> ResolvingStrategy o e m Value+  encode :: resolver -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue  instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m , LiftEither o ResolvingStrategy) => Encode a o e m where   encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a)@@ -116,16 +115,19 @@   encode list query = gqlList <$> traverse (`encode` query) list  --  GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance (DecodeObject a, Monad m,LiftEither fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where+instance (DecodeType a,Generic a, Monad m,LiftEither fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where   encode resolver selection@(_, Selection { selectionArguments }) =     mapStrategy $ resolving encode (toResolver args resolver) selection    where     args :: Validation a     args = decodeArguments selectionArguments +++ -- ENCODE GQL KIND class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where-  encodeKind :: LiftEither o ResolvingStrategy =>  VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o e m Value+  encodeKind :: LiftEither o ResolvingStrategy =>  VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue  -- SCALAR instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where@@ -135,87 +137,83 @@ instance (Generic a, EnumRep (Rep a), Monad m) => EncodeKind ENUM a o e m where   encodeKind = pure . pure . gqlString . encodeRep . from . unVContext ---  OBJECT-instance (Monad m, EncodeCon o e m a, Monad m, GResolver OBJECT (Rep a) o e m) => EncodeKind OBJECT a o e m where-  encodeKind (VContext value) = withObject encodeK+instance (Monad m,Generic a, GQLType a,ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where+  encodeKind (VContext value) (key, sel@Selection { selectionContent }) =+    encodeNode (exploreResolvers (Proxy @(CUSTOM a)) value) selectionContent    where-    encodeK selection = resolveObject-      selection-      (__typenameResolver : objectResolvers (Proxy :: Proxy (CUSTOM a)) value)-    __typenameResolver =-      ("__typename", const $ pure $ gqlString $ __typeName (Proxy @a))+    encodeNode (ObjectRes fields) _ = withObject encodeObject (key, sel)+     where+      encodeObject selection =+        resolveObject selection+          $ ObjectRes+          $ resolve__typename (__typeName (Proxy @a))+          : fields+    encodeNode (EnumRes enum) _ =+      resolveEnum (__typeName (Proxy @a)) enum selectionContent+    -- Type References --------------------------------------------------------------+    encodeNode (UnionRef (fieldTypeName, fieldResolver)) (UnionSelection selections)+      = fieldResolver+        (key, sel { selectionContent = SelectionSet currentSelection })+      where currentSelection = pickSelection fieldTypeName selections+    -- RECORDS ----------------------------------------------------------------------------+    encodeNode (UnionRes (name, fields)) (UnionSelection selections) =+      resolveObject selection resolvers+     where+      selection = pickSelection name selections+      resolvers = ObjectRes (resolve__typename name : fields)+    encodeNode _ _ = failure $ internalResolvingError+      "union Resolver should only recieve UnionSelection" --- exploreKindChannels--- UNION-instance (Monad m, GQL_RES a, GResolver UNION (Rep a) o e m) => EncodeKind UNION a o e m where-  encodeKind (VContext value) (key, sel@Selection { selectionRec = UnionSelection selections })-    = resolver (key, sel { selectionRec = SelectionSet lookupSelection })++convertNode+  :: (Monad m, LiftEither o ResolvingStrategy)+  => ResNode o e m+  -> DataResolver o e m+convertNode ResNode { resKind = REP_OBJECT, resFields } =+  ObjectRes $ map toFieldRes resFields+convertNode ResNode { resDatatypeName, resKind = REP_UNION, resFields, resTypeName, isResRecord }+  = encodeUnion resFields+ where+  -- ENUM+  encodeUnion [] = EnumRes resTypeName+  -- Type References --------------------------------------------------------------+  encodeUnion [FieldNode { fieldTypeName, fieldResolver, isFieldObject }]+    | isFieldObject && resTypeName == resDatatypeName <> fieldTypeName+    = UnionRef (fieldTypeName, fieldResolver)+  -- RECORDS ----------------------------------------------------------------------------+  encodeUnion fields = UnionRes+    (resTypeName, resolve__typename resTypeName : map toFieldRes resolvers)    where-    lookupSelection      = fromMaybe [] $ lookup typeName selections-    (typeName, resolver) = unionResolver value-  encodeKind _ _ = failure $ internalUnknownTypeMessage-    "union Resolver only should recieve UnionSelection"+    resolvers | isResRecord = fields+              | otherwise   = setFieldNames fields  -- Types & Constrains ------------------------------------------------------- type GQL_RES a = (Generic a, GQLType a)  type EncodeOperator o e m a-  = a -> ValidOperation -> ResolvingStrategy o e m Value+  = a -> ValidOperation -> ResolvingStrategy o e m ValidValue -type EncodeCon o e m a = (GQL_RES a, ObjectResolvers (CUSTOM a) a o e m)+type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m) -type FieldRes o e m-  = (Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value) -type family GRes (kind :: GQL_KIND) value :: *+objectResolvers+  :: forall custom a o e m+   . ExploreResolvers custom a o e m+  => Proxy custom+  -> a+  -> DataResolver o e m+objectResolvers isCustom value = case exploreResolvers isCustom value of+  ObjectRes resFields -> ObjectRes resFields+  _                   -> InvalidRes "resolver must be an object" -type instance GRes OBJECT v = [(Key, (Key, ValidSelection) -> v)] -type instance GRes UNION v = (Key, (Key, ValidSelection) -> v)- --- GENERICS -------------------------------------------------class ObjectResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where-  objectResolvers :: Proxy custom -> a -> [(Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value)]--instance (Generic a, GResolver OBJECT (Rep a) o e m ) => ObjectResolvers 'False a o e m where-  objectResolvers _ =-    getResolvers (ResContext :: ResContext OBJECT o e m value) . from--unionResolver-  :: (Generic a, GResolver UNION (Rep a) o e m)-  => a-  -> (Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value)-unionResolver =-  getResolvers (ResContext :: ResContext UNION o e m value) . from---- | Derives resolvers for OBJECT and UNION-class GResolver (kind :: GQL_KIND) f o e (m :: * -> *) where-  getResolvers :: ResContext kind o e m value -> f a -> GRes kind (ResolvingStrategy o e m Value)--instance GResolver kind f o e m => GResolver kind (M1 D c f) o e m where-  getResolvers context (M1 src) = getResolvers context src--instance GResolver kind f o e m => GResolver kind (M1 C c f) o e m where-  getResolvers context (M1 src) = getResolvers context src---- OBJECT-instance GResolver OBJECT U1 o e m where-  getResolvers _ _ = []--instance (Selector s, GQLType a, Encode a o e m) => GResolver OBJECT (M1 S s (K1 s2 a)) o e m where-  getResolvers _ m@(M1 (K1 src)) = [(pack (selName m), encode src)]--instance (GResolver OBJECT f o e m, GResolver OBJECT g o e m) => GResolver OBJECT (f :*: g) o e m where-  getResolvers context (a :*: b) =-    getResolvers context a ++ getResolvers context b---- UNION-instance (Selector s, GQLType a, Encode a o e m ) => GResolver UNION (M1 S s (K1 s2 a)) o e m where-  getResolvers _ (M1 (K1 src)) = (__typeName (Proxy @a), encode src)+class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where+  exploreResolvers :: Proxy custom -> a -> DataResolver o e m -instance (GResolver UNION a o e m, GResolver UNION b o e m) => GResolver UNION (a :+: b) o e m where-  getResolvers context (L1 x) = getResolvers context x-  getResolvers context (R1 x) = getResolvers context x+instance (Generic a,Monad m,LiftEither o ResolvingStrategy,TypeRep (Rep a) o e m ) => ExploreResolvers 'False a o e m where+  exploreResolvers _ value = convertNode+    $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value)  ----- HELPERS ---------------------------- encodeQuery@@ -227,29 +225,107 @@   => schema (Resolver QUERY event m)   -> EncodeOperator QUERY event m query encodeQuery schema = encodeOperationWith-  (objectResolvers (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY event m))))-                   schema+  (Just $ objectResolvers+    (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY event m))))+    schema   )  encodeMutation   :: forall event m mut    . (Monad m, EncodeCon MUTATION event m mut)   => EncodeOperator MUTATION event m mut-encodeMutation = encodeOperationWith []+encodeMutation = encodeOperationWith Nothing  encodeSubscription   :: forall m event mut    . (Monad m, EncodeCon SUBSCRIPTION event m mut)   => EncodeOperator SUBSCRIPTION event m mut-encodeSubscription = encodeOperationWith []+encodeSubscription = encodeOperationWith Nothing  encodeOperationWith   :: forall o e m a    . (Monad m, EncodeCon o e m a, LiftEither o ResolvingStrategy)-  => [FieldRes o e m]+  => Maybe (DataResolver o e m)   -> EncodeOperator o e m a encodeOperationWith externalRes rootResolver Operation { operationSelection } =-  resolveObject operationSelection resolvers+  resolveObject operationSelection (rootDataRes <> extDataRes)  where-  resolvers =-    externalRes <> objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver+  rootDataRes = objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver+  extDataRes  = fromMaybe (ObjectRes []) externalRes++toFieldRes :: FieldNode o e m -> FieldRes o e m+toFieldRes FieldNode { fieldSelName, fieldResolver } =+  (fieldSelName, fieldResolver)+++-- NEW AUTOMATIC DERIVATION SYSTEM++pickSelection :: Name -> [(Name, ValidSelectionSet)] -> ValidSelectionSet+pickSelection name = fromMaybe [] . lookup name++data REP_KIND = REP_UNION | REP_OBJECT++data ResNode o e m = ResNode {+    resDatatypeName :: Name,+    resTypeName :: Name,+    resKind :: REP_KIND,+    resFields :: [FieldNode o e m],+    isResRecord :: Bool+  }++data FieldNode o e m = FieldNode {+    fieldTypeName :: Name,+    fieldSelName :: Name,+    fieldResolver  :: (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue,+    isFieldObject  :: Bool+  }++-- setFieldNames ::  Power Int Text -> Power { _1 :: Int, _2 :: Text }+setFieldNames :: [FieldNode o e m] -> [FieldNode o e m]+setFieldNames = zipWith setFieldName ([0 ..] :: [Int])+  where setFieldName i field = field { fieldSelName = "_" <> pack (show i) }++class TypeRep f o e (m :: * -> *) where+  typeResolvers :: ResContext OUTPUT o e m value -> f a -> ResNode o e m++instance (Datatype d,TypeRep  f o e m) => TypeRep (M1 D d f) o e m where+  typeResolvers context (M1 src) = (typeResolvers context src)+    { resDatatypeName = pack $ datatypeName (undefined :: M1 D d f a)+    }+++      --- UNION OR OBJECT +instance (TypeRep a o e m,TypeRep b o e m) => TypeRep (a :+: b) o e m where+  typeResolvers context (L1 x) =+    (typeResolvers context x) { resKind = REP_UNION }+  typeResolvers context (R1 x) =+    (typeResolvers context x) { resKind = REP_UNION }++instance (FieldRep f o e m,Constructor c) => TypeRep (M1 C c f) o e m where+  typeResolvers context (M1 src) = ResNode { resDatatypeName = ""+                                           , resTypeName = pack (conName proxy)+                                           , resKind = REP_OBJECT+                                           , resFields = fieldRep context src+                                           , isResRecord = conIsRecord proxy+                                           }+    where proxy = undefined :: (M1 C c U1 x)++      --- FIELDS      +class FieldRep f o e (m :: * -> *) where+        fieldRep :: ResContext OUTPUT o e m value -> f a -> [FieldNode o e m]++instance (FieldRep f o e m, FieldRep g o e m) => FieldRep  (f :*: g) o e m where+  fieldRep context (a :*: b) = fieldRep context a <> fieldRep context b++instance (Selector s, GQLType a, Encode a o e m) => FieldRep (M1 S s (K1 s2 a)) o e m where+  fieldRep _ m@(M1 (K1 src)) =+    [ FieldNode { fieldSelName  = pack (selName m)+                , fieldTypeName = __typeName (Proxy @a)+                , fieldResolver = encode src+                , isFieldObject = isObjectKind (Proxy @a)+                }+    ]++instance FieldRep U1 o e m where+  fieldRep _ _ = []+

@@ -24,6 +24,7 @@ import           Data.Text.Lazy.Encoding        ( decodeUtf8                                                 , encodeUtf8                                                 )+import           Control.Monad.IO.Class         ( MonadIO() )  -- MORPHEUS import           Data.Morpheus.Execution.Server.Resolve@@ -96,18 +97,18 @@ -} type WSPub m e a = GQLState m e -> a -> m a -instance Interpreter (WSPub IO e LB.ByteString) IO e where+instance MonadIO m => Interpreter (WSPub m e LB.ByteString) m e where   interpreter root state = statefulResolver state (coreResolver root) -instance Interpreter (WSPub IO e  LT.Text) IO e where+instance MonadIO m => Interpreter (WSPub m e  LT.Text) m e where   interpreter root state request =     decodeUtf8 <$> interpreter root state (encodeUtf8 request) -instance Interpreter (WSPub IO e  ByteString) IO e where+instance MonadIO m => Interpreter (WSPub m e  ByteString) m e where   interpreter root state request =     LB.toStrict <$> interpreter root state (LB.fromStrict request) -instance Interpreter (WSPub IO e  Text) IO e  where+instance MonadIO m => Interpreter (WSPub m e  Text) m e  where   interpreter root state request =     LT.toStrict <$> interpreter root state (LT.fromStrict request) 

@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE DefaultSignatures     #-}@@ -17,10 +18,12 @@ module Data.Morpheus.Execution.Server.Introspect   ( TypeUpdater   , Introspect(..)-  , ObjectFields(..)+  , IntrospectRep(..)   , IntroCon   , updateLib   , buildType+  , objectFields+  , TypeScope(..)   ) where @@ -31,21 +34,22 @@                                                 , pack                                                 ) import           GHC.Generics+import           Data.Semigroup                 ( (<>) )+import           Data.List                      ( partition )  -- MORPHEUS+import           Data.Morpheus.Error.Utils      ( globalErrorMessage ) import           Data.Morpheus.Error.Schema     ( nameCollisionError ) import           Data.Morpheus.Execution.Server.Generics.EnumRep                                                 ( EnumRep(..) ) import           Data.Morpheus.Kind             ( Context(..)                                                 , ENUM                                                 , GQL_KIND-                                                , INPUT_OBJECT-                                                , INPUT_UNION-                                                , OBJECT                                                 , SCALAR-                                                , UNION+                                                , OUTPUT+                                                , INPUT                                                 )-import           Data.Morpheus.Types.Types     ( MapKind+import           Data.Morpheus.Types.Types      ( MapKind                                                 , Pair                                                 ) import           Data.Morpheus.Types.GQLScalar  ( GQLScalar(..) )@@ -55,10 +59,11 @@                                                 , resolveUpdates                                                 ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataArguments+                                                ( Name+                                                , DataArguments                                                 , Meta(..)                                                 , DataField(..)-                                                , DataTyCon(..)+                                                , DataTypeContent(..)                                                 , DataType(..)                                                 , Key                                                 , createAlias@@ -68,13 +73,21 @@                                                 , toNullableField                                                 , createEnumValue                                                 , TypeUpdater+                                                , DataFingerprint(..)+                                                , DataUnion+                                                , DataObject+                                                , TypeRef(..)                                                 )  -type IntroCon a = (GQLType a, ObjectFields (CUSTOM a) a)+type IntroCon a = (GQLType a, IntrospectRep (CUSTOM a) a) + -- |  Generates internal GraphQL Schema for query validation and introspection rendering class Introspect a where+  isObject :: proxy a -> Bool+  default isObject :: GQLType a => proxy a -> Bool+  isObject _ = isObjectKind (Proxy @a)   field :: proxy a -> Text -> DataField   introspect :: proxy a -> TypeUpdater   -----------------------------------------------@@ -87,39 +100,50 @@  -- Maybe instance Introspect a => Introspect (Maybe a) where+  isObject _ = False   field _ = toNullableField . field (Proxy @a)   introspect _ = introspect (Proxy @a)  -- List instance Introspect a => Introspect [a] where+  isObject _ = False   field _ = toListField . field (Proxy @a)   introspect _ = introspect (Proxy @a)  -- Tuple instance Introspect (Pair k v) => Introspect (k, v) where+  isObject _ = True   field _ = field (Proxy @(Pair k v))   introspect _ = introspect (Proxy @(Pair k v))  -- Set instance Introspect [a] => Introspect (Set a) where+  isObject _ = False   field _ = field (Proxy @[a])   introspect _ = introspect (Proxy @[a])  -- Map instance Introspect (MapKind k v Maybe) => Introspect (Map k v) where+  isObject _ = True   field _ = field (Proxy @(MapKind k v Maybe))   introspect _ = introspect (Proxy @(MapKind k v Maybe))  -- Resolver : a -> Resolver b-instance (ObjectFields 'False a, Introspect b) => Introspect (a -> m b) where-  field _ name = (field (Proxy @b) name)-    { fieldArgs = fst $ objectFields (Proxy :: Proxy 'False) (Proxy @a)-    }+instance (GQLType b, IntrospectRep 'False a, Introspect b) => Introspect (a -> m b) where+  isObject _ = False+  field _ name = fieldObj { fieldArgs }+   where+    fieldObj  = field (Proxy @b) name+    fieldArgs = fst $ objectFields+      (Proxy :: Proxy 'False)+      (__typeName (Proxy @b), OutputType, Proxy @a)   introspect _ typeLib = resolveUpdates typeLib-                                        (introspect (Proxy @b) : argTypes)+                                        (introspect (Proxy @b) : inputs)    where-    argTypes :: [TypeUpdater]-    argTypes = snd $ objectFields (Proxy :: Proxy 'False) (Proxy @a)+    name = "Arguments for " <> __typeName (Proxy @b)+    inputs :: [TypeUpdater]+    inputs =+      snd $ objectFields (Proxy :: Proxy 'False) (name, InputType, Proxy @a)  -- | Introspect With specific Kind: 'kind': object, scalar, enum ... class IntrospectKind (kind :: GQL_KIND) a where@@ -128,102 +152,66 @@ -- SCALAR instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where   introspectKind _ = updateLib scalarType [] (Proxy @a)-    where scalarType = DataScalar . buildType (scalarValidator (Proxy @a))+    where scalarType = buildType $ DataScalar $ scalarValidator (Proxy @a)  -- ENUM instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where   introspectKind _ = updateLib enumType [] (Proxy @a)    where     enumType =-      DataEnum . buildType (map createEnumValue $ enumTags (Proxy @(Rep a)))---- INPUT_OBJECT-instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind INPUT_OBJECT a where-  introspectKind _ = updateLib (DataInputObject . buildType fields)-                               types-                               (Proxy @a)-    where (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a)---- OBJECTS-instance (GQL_TYPE a, ObjectFields (CUSTOM a) a) => IntrospectKind OBJECT a where-  introspectKind _ = updateLib (DataObject . buildType (__typename : fields))-                               types-                               (Proxy @a)-   where-    __typename =-      ( "__typename"-      , DataField { fieldName     = "__typename"-                  , fieldArgs     = []-                  , fieldArgsType = Nothing-                  , fieldType     = createAlias "String"-                  , fieldMeta     = Nothing-                  }-      )-    (fields, types) = objectFields (Proxy @(CUSTOM a)) (Proxy @a)+      buildType $ DataEnum $ map createEnumValue $ enumTags (Proxy @(Rep a)) --- UNION-instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind UNION a where-  introspectKind _ = updateLib (DataUnion . buildType memberTypes)-                               stack-                               (Proxy @a)-   where-    (memberTypes, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a))+instance (GQL_TYPE a, IntrospectRep (CUSTOM a) a) => IntrospectKind INPUT a where+  introspectKind _ = derivingData (Proxy @a) InputType --- INPUT_UNION-instance (GQL_TYPE a, GQLRep UNION (Rep a)) => IntrospectKind INPUT_UNION a where-  introspectKind _ = updateLib (DataInputUnion . buildType memberTypes)-                               stack-                               (Proxy @a)-   where-    (memberTypes, stack) = unzip $ gqlRep (Context :: Context UNION (Rep a))+instance (GQL_TYPE a, IntrospectRep (CUSTOM a) a) => IntrospectKind OUTPUT a where+  introspectKind _ = derivingData (Proxy @a) OutputType --- Types+derivingData+  :: forall a+   . (GQLType a, IntrospectRep (CUSTOM a) a)+  => Proxy a+  -> TypeScope+  -> TypeUpdater+derivingData _ scope = updateLib (buildType datatypeContent) updates (Proxy @a)+ where+  (datatypeContent, updates) = introspectRep+    (Proxy @(CUSTOM a))+    (Proxy @a, scope, baseName, baseFingerprint)+  baseName        = __typeName (Proxy @a)+  baseFingerprint = __typeFingerprint (Proxy @a)  type GQL_TYPE a = (Generic a, GQLType a) --- Object Fields-class ObjectFields (custom :: Bool) a where-  objectFields :: proxy1 custom -> proxy2 a -> ([(Text, DataField)], [TypeUpdater]) -instance GQLRep OBJECT (Rep a) => ObjectFields 'False a where-  objectFields _ _ = unzip $ gqlRep (Context :: Context OBJECT (Rep a))--type family GQLRepResult (a :: GQL_KIND) :: *--type instance GQLRepResult OBJECT = (Text, DataField)--type instance GQLRepResult UNION = Key----  GENERIC UNION-class GQLRep (kind :: GQL_KIND) f where-  gqlRep :: Context kind f -> [(GQLRepResult kind, TypeUpdater)]--instance GQLRep kind f => GQLRep kind (M1 D d f) where-  gqlRep _ = gqlRep (Context :: Context kind f)--instance GQLRep kind f => GQLRep kind (M1 C c f) where-  gqlRep _ = gqlRep (Context :: Context kind f)---- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION'-instance (GQLRep UNION a, GQLRep UNION b) => GQLRep UNION (a :+: b) where-  gqlRep _ =-    gqlRep (Context :: Context UNION a) ++ gqlRep (Context :: Context UNION b)--instance (GQL_TYPE a, Introspect a) => GQLRep UNION (M1 S s (Rec0 a)) where-  gqlRep _ = [(__typeName (Proxy @a), introspect (Proxy @a))]---- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'-instance (GQLRep OBJECT a, GQLRep OBJECT b) => GQLRep OBJECT (a :*: b) where-  gqlRep _ =-    gqlRep (Context :: Context OBJECT a) ++ gqlRep (Context :: Context OBJECT b)--instance (Selector s, Introspect a) => GQLRep OBJECT (M1 S s (Rec0 a)) where-  gqlRep _ = [((name, field (Proxy @a) name), introspect (Proxy @a))]-    where name = pack $ selName (undefined :: M1 S s (Rec0 ()) ())+objectFields+  :: IntrospectRep custom a+  => proxy1 (custom :: Bool)+  -> (Name, TypeScope, proxy2 a)+  -> ([(Name, DataField)], [TypeUpdater])+objectFields p1 (name, scope, proxy) = withObject+  (introspectRep p1 (proxy, scope, "", DataFingerprint "" []))+ where+  withObject (DataObject      x, ts) = (x, ts)+  withObject (DataInputObject x, ts) = (x, ts)+  withObject _ =+    ( []+    , [ const+          $  failure+          $  globalErrorMessage+          $  "invalid schema: "+          <> name+          <> " should have only one nonempty constructor"+      ]+    ) -instance GQLRep OBJECT U1 where-  gqlRep _ = []+-- Object Fields+class IntrospectRep (custom :: Bool) a where+  introspectRep :: proxy1 custom -> ( proxy2 a,TypeScope,Name,DataFingerprint) -> (DataTypeContent, [TypeUpdater]) +instance (TypeRep (Rep a) , Generic a) => IntrospectRep 'False a where+  introspectRep _ (_, scope, name, fing) =+    derivingDataContent (Proxy @a) (name, fing) scope  buildField :: GQLType a => Proxy a -> DataArguments -> Text -> DataField buildField proxy fieldArgs fieldName = DataField@@ -234,14 +222,14 @@   , fieldMeta     = Nothing   } -buildType :: GQLType a => t -> Proxy a -> DataTyCon t-buildType typeData proxy = DataTyCon+buildType :: GQLType a => DataTypeContent -> Proxy a -> DataType+buildType typeContent proxy = DataType   { typeName        = __typeName proxy   , typeFingerprint = __typeFingerprint proxy   , typeMeta        = Just Meta { metaDescription = description proxy                                 , metaDirectives  = []                                 }-  , typeData+  , typeContent   }  updateLib@@ -258,3 +246,258 @@     Just fingerprint' | fingerprint' == __typeFingerprint proxy -> return lib'     -- throw error if 2 different types has same name     Just _ -> failure $ nameCollisionError (__typeName proxy)+++-- NEW AUTOMATIC DERIVATION SYSTEM++data ConsRep =  ConsRep {+  consName :: Key,+  consIsRecord :: Bool,+  consFields :: [FieldRep]+}++data FieldRep = FieldRep {+  fieldTypeName :: Name,+  fieldData :: (Name, DataField),+  fieldTypeUpdater :: TypeUpdater,+  fieldIsObject :: Bool+}++data ResRep = ResRep {+  enumCons :: [Name],+  unionRef :: [Name],+  unionRecordRep :: [ConsRep]+}++isEmpty :: ConsRep -> Bool+isEmpty ConsRep { consFields = [] } = True+isEmpty _                           = False++isUnionRecord :: ConsRep -> Bool+isUnionRecord ConsRep { consIsRecord } = consIsRecord++isUnionRef :: Name -> ConsRep -> Bool+isUnionRef baseName ConsRep { consName, consFields = [FieldRep { fieldIsObject = True, fieldTypeName }] }+  = consName == baseName <> fieldTypeName+isUnionRef _ _ = False++setFieldNames :: ConsRep -> ConsRep+setFieldNames cons@ConsRep { consFields } = cons+  { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields+  }+ where+  setFieldName i fieldR@FieldRep { fieldData = (_, fieldD) } = fieldR+    { fieldData = (fieldName, fieldD { fieldName })+    }+    where fieldName = "_" <> pack (show i)++analyseRep :: Name -> [ConsRep] -> ResRep+analyseRep baseName cons = ResRep+  { enumCons       = map consName enumRep+  , unionRef       = map fieldTypeName $ concatMap consFields unionRefRep+  , unionRecordRep = unionRecordRep <> map setFieldNames anyonimousUnionRep+  }+ where+  (enumRep       , left1             ) = partition isEmpty cons+  (unionRefRep   , left2             ) = partition (isUnionRef baseName) left1+  (unionRecordRep, anyonimousUnionRep) = partition isUnionRecord left2++derivingDataContent+  :: forall a+   . (Generic a, TypeRep (Rep a))+  => Proxy a+  -> (Name, DataFingerprint)+  -> TypeScope+  -> (DataTypeContent, [TypeUpdater])+derivingDataContent _ (baseName, baseFingerprint) scope =+  builder $ typeRep $ Proxy @(Rep a)+ where+  builder [ConsRep { consFields }] = buildObject scope consFields+  builder cons                     = genericUnion scope cons+   where+    genericUnion InputType = buildInputUnion (baseName, baseFingerprint)+    genericUnion OutputType =+      buildUnionType (baseName, baseFingerprint) DataUnion DataObject+++buildInputUnion+  :: (Name, DataFingerprint) -> [ConsRep] -> (DataTypeContent, [TypeUpdater])+buildInputUnion (baseName, baseFingerprint) cons = datatype+  (analyseRep baseName cons)+ where+  datatype ResRep { unionRef = [], unionRecordRep = [], enumCons } =+    (DataEnum (map createEnumValue enumCons), types)+  datatype ResRep { unionRef, unionRecordRep, enumCons } =+    (DataInputUnion typeMembers, types <> unionTypes)+   where+    typeMembers =+      map (, True) (unionRef <> unionMembers) <> map (, False) enumCons+    (unionMembers, unionTypes) =+      buildUnions DataInputObject baseFingerprint unionRecordRep+  types = map fieldTypeUpdater $ concatMap consFields cons++buildUnionType+  :: (Name, DataFingerprint)+  -> (DataUnion -> DataTypeContent)+  -> (DataObject -> DataTypeContent)+  -> [ConsRep]+  -> (DataTypeContent, [TypeUpdater])+buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons = datatype+  (analyseRep baseName cons)+ where+  datatype ResRep { unionRef = [], unionRecordRep = [], enumCons } =+    (DataEnum (map createEnumValue enumCons), types)+  datatype ResRep { unionRef, unionRecordRep, enumCons } =+    (wrapUnion typeMembers, types <> enumTypes <> unionTypes)+   where+    typeMembers = unionRef <> enumMembers <> unionMembers+    (enumMembers, enumTypes) =+      buildUnionEnum wrapObject baseName baseFingerprint enumCons+    (unionMembers, unionTypes) =+      buildUnions wrapObject baseFingerprint unionRecordRep+  types = map fieldTypeUpdater $ concatMap consFields cons+++buildObject :: TypeScope -> [FieldRep] -> (DataTypeContent, [TypeUpdater])+buildObject isOutput consFields = (wrap fields, types)+ where+  (fields, types) = buildDataObject consFields+  wrap | isOutput == OutputType = DataObject+       | otherwise              = DataInputObject++buildDataObject :: [FieldRep] -> (DataObject, [TypeUpdater])+buildDataObject consFields = (fields, types)+ where+  fields = map fieldData consFields+  types  = map fieldTypeUpdater consFields++buildUnions+  :: (DataObject -> DataTypeContent)+  -> DataFingerprint+  -> [ConsRep]+  -> ([Name], [TypeUpdater])+buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons)+ where+  buildURecType consRep = pure . defineType+    (consName consRep, buildUnionRecord wrapObject baseFingerprint consRep)+  members = map consName cons++buildUnionRecord+  :: (DataObject -> DataTypeContent) -> DataFingerprint -> ConsRep -> DataType+buildUnionRecord wrapObject typeFingerprint ConsRep { consName, consFields } =+  DataType { typeName        = consName+           , typeFingerprint+           , typeMeta        = Nothing+           , typeContent     = wrapObject $ genFields consFields+           }++ where+  genFields [FieldRep { fieldData = ("", fData) }] =+    [("value", fData { fieldName = "value" })]+  genFields fields = map uRecField fields+  uRecField FieldRep { fieldData = (fName, fData) } = (fName, fData)+++buildUnionEnum+  :: (DataObject -> DataTypeContent)+  -> Name+  -> DataFingerprint+  -> [Name]+  -> ([Name], [TypeUpdater])+buildUnionEnum wrapObject baseName baseFingerprint enums = (members, updates)+ where+  members | null enums = []+          | otherwise  = [enumTypeWrapperName]+  enumTypeName        = baseName <> "Enum"+  enumTypeWrapperName = enumTypeName <> "Object"+  -------------------------+  updates :: [TypeUpdater]+  updates+    | null enums+    = []+    | otherwise+    = [ buildEnumObject wrapObject+                        enumTypeWrapperName+                        baseFingerprint+                        enumTypeName+      , buildEnum enumTypeName baseFingerprint enums+      ]++buildEnum :: Name -> DataFingerprint -> [Name] -> TypeUpdater+buildEnum typeName typeFingerprint tags = pure . defineType+  ( typeName+  , DataType { typeName+             , typeFingerprint+             , typeMeta        = Nothing+             , typeContent     = DataEnum $ map createEnumValue tags+             }+  )++buildEnumObject+  :: (DataObject -> DataTypeContent)+  -> Name+  -> DataFingerprint+  -> Name+  -> TypeUpdater+buildEnumObject wrapObject typeName typeFingerprint enumTypeName =+  pure . defineType+    ( typeName+    , DataType+      { typeName+      , typeFingerprint+      , typeMeta        = Nothing+      , typeContent     = wrapObject+                            [ ( "enum"+                              , DataField { fieldName     = "enum"+                                          , fieldArgs     = []+                                          , fieldArgsType = Nothing+                                          , fieldType = createAlias enumTypeName+                                          , fieldMeta     = Nothing+                                          }+                              )+                            ]+      }+    )++data TypeScope = InputType | OutputType deriving (Show,Eq,Ord)++--  GENERIC UNION+class TypeRep f where+  typeRep :: Proxy f -> [ConsRep]++instance TypeRep f => TypeRep (M1 D d f) where+  typeRep _ = typeRep (Proxy @f)++-- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'+instance (TypeRep a, TypeRep b) => TypeRep (a :+: b) where+  typeRep _ = typeRep (Proxy @a) <> typeRep (Proxy @b)++instance (ConRep f, Constructor c) => TypeRep (M1 C c f) where+  typeRep _ =+    [ ConsRep { consName     = pack $ conName (undefined :: (M1 C c f a))+              , consFields   = conRep (Proxy @f)+              , consIsRecord = conIsRecord (undefined :: (M1 C c f a))+              }+    ]++class ConRep f where+    conRep :: Proxy f -> [FieldRep]++-- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION'+instance (ConRep  a, ConRep  b) => ConRep  (a :*: b) where+  conRep _ = conRep (Proxy @a) <> conRep (Proxy @b)++instance (Selector s, Introspect a) => ConRep (M1 S s (Rec0 a)) where+  conRep _ =+    [ FieldRep { fieldTypeName    = typeConName $ fieldType fieldData+               , fieldData        = (name, fieldData)+               , fieldTypeUpdater = introspect (Proxy @a)+               , fieldIsObject    = isObject (Proxy @a)+               }+    ]+   where+    name      = pack $ selName (undefined :: M1 S s (Rec0 ()) ())+    fieldData = field (Proxy @a) name++instance ConRep U1 where+  conRep _ = []

@@ -39,7 +39,8 @@                                                 ) import           Data.Morpheus.Execution.Server.Introspect                                                 ( IntroCon-                                                , ObjectFields(..)+                                                , objectFields+                                                , TypeScope(..)                                                 ) import           Data.Morpheus.Execution.Subscription.ClientRegister                                                 ( GQLState@@ -57,14 +58,17 @@                                                 ( Operation(..)                                                 , ValidOperation                                                 , DataFingerprint(..)-                                                , DataTyCon(..)+                                                , DataTypeContent(..)                                                 , DataTypeLib(..)+                                                , DataType(..)                                                 , MUTATION                                                 , OperationType(..)                                                 , QUERY                                                 , SUBSCRIPTION                                                 , initTypeLib-                                                , Value+                                                , ValidValue+                                                , Name+                                                , DataField                                                 ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( GQLRootResolver(..)@@ -89,7 +93,7 @@ import           Data.Morpheus.Validation.Query.Validation                                                 ( validateRequest ) import           Data.Typeable                  ( Typeable )-+import           Control.Monad.IO.Class         ( MonadIO() )  type EventCon event   = (Eq (StreamChannel event), Typeable event, GQLChannel event)@@ -147,7 +151,7 @@    . (Monad m, RootResCon m event query mut sub)   => GQLRootResolver m event query mut sub   -> GQLRequest-  -> ResponseStream event m Value+  -> ResponseStream event m ValidValue coreResolver root@GQLRootResolver { queryResolver, mutationResolver, subscriptionResolver } request   = validRequest >>= execOperator  where@@ -169,11 +173,11 @@       toResponseRes (encodeSubscription subscriptionResolver operation)  statefulResolver-  :: EventCon event-  => GQLState IO event-  -> (GQLRequest -> ResponseStream event IO Value)+  :: (EventCon event, MonadIO m)+  => GQLState m event+  -> (GQLRequest -> ResponseStream event m ValidValue)   -> L.ByteString-  -> IO L.ByteString+  -> m L.ByteString statefulResolver state streamApi requestText = do   res <- runResultT (decodeNoDup requestText >>= streamApi)   mapM_ execute (unpackEvents res)@@ -182,7 +186,6 @@   execute (Publish updates) = publishUpdates state updates   execute Subscribe{}       = pure () - fullSchema   :: forall proxy m event query mutation subscription    . (IntrospectConstraint m event query mutation subscription)@@ -196,7 +199,7 @@    where     (fields, types) = objectFields       (Proxy @(CUSTOM (query (Resolver QUERY event m))))-      (Proxy @(query (Resolver QUERY event m)))+      ("type for query", OutputType, Proxy @(query (Resolver QUERY event m)))   ------------------------------   mutationSchema lib = resolveUpdates     (lib { mutation = maybeOperator fields "Mutation" })@@ -204,7 +207,10 @@    where     (fields, types) = objectFields       (Proxy @(CUSTOM (mutation (Resolver MUTATION event m))))-      (Proxy @(mutation (Resolver MUTATION event m)))+      ( "type for mutation"+      , OutputType+      , Proxy @(mutation (Resolver MUTATION event m))+      )   ------------------------------   subscriptionSchema lib = resolveUpdates     (lib { subscription = maybeOperator fields "Subscription" })@@ -212,16 +218,20 @@    where     (fields, types) = objectFields       (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m))))-      (Proxy @(subscription (Resolver SUBSCRIPTION event m)))-   -- maybeOperator :: [a] -> Text -> Maybe (Text, DataTyCon[a])+      ( "type for subscription"+      , OutputType+      , Proxy @(subscription (Resolver SUBSCRIPTION event m))+      )+  maybeOperator :: [(Name, DataField)] -> Name -> Maybe (Name, DataType)   maybeOperator []     = const Nothing   maybeOperator fields = Just . operatorType fields-  -- operatorType :: [a] -> Text -> (Text, DataTyCon[a])-  operatorType typeData typeName =+  -------------------------------------------------+  operatorType :: [(Name, DataField)] -> Name -> (Name, DataType)+  operatorType fields typeName =     ( typeName-    , DataTyCon { typeData-                , typeName-                , typeFingerprint = SystemFingerprint typeName-                , typeMeta        = Nothing-                }+    , DataType { typeContent     = DataObject fields+               , typeName+               , typeFingerprint = DataFingerprint typeName []+               , typeMeta        = Nothing+               }     )

@@ -13,6 +13,7 @@   ) where +import           Control.Monad.IO.Class         ( MonadIO(liftIO) ) import           Control.Concurrent             ( MVar                                                 , modifyMVar                                                 , modifyMVar_@@ -50,7 +51,7 @@ initGQLState :: IO (GQLState m e) initGQLState = newMVar [] -connectClient :: Connection -> GQLState m e -> IO (GQLClient m e)+connectClient :: MonadIO m => Connection -> GQLState m e -> IO (GQLClient m e) connectClient clientConnection varState' = do   client' <- newClient   modifyMVar_ varState' (addClient client')@@ -70,11 +71,12 @@   removeClient = filter ((/= clientID client) . fst)  updateClientByID-  :: ClientID+  :: MonadIO m =>+     ClientID   -> (GQLClient m e -> GQLClient m e)   -> MVar (ClientRegister m e)-  -> IO ()-updateClientByID id' updateFunc state = modifyMVar_+  -> m ()+updateClientByID id' updateFunc state = liftIO $ modifyMVar_   state   (return . map updateClient)  where@@ -82,9 +84,9 @@   updateClient state'                      = state'  publishUpdates-  :: (Eq (StreamChannel e), GQLChannel e) => GQLState IO e -> e -> IO ()+  :: (Eq (StreamChannel e), GQLChannel e, MonadIO m) => GQLState m e -> e -> m () publishUpdates state event = do-  state' <- readMVar state+  state' <- liftIO $ readMVar state   traverse_ sendMessage state'  where   sendMessage (_, GQLClient { clientSessions = [] }             ) = return ()@@ -92,10 +94,10 @@     __send     (filterByChannels clientSessions)    where-    __send ClientSession { sessionId, sessionSubscription = Event { content = subscriptionRes } }-      = subscriptionRes event-        >>= sendTextData clientConnection-        .   toApolloResponse sessionId+    __send ClientSession { sessionId, sessionSubscription = Event { content = subscriptionRes } } = do+      res <- subscriptionRes event+      let apolloRes = toApolloResponse sessionId res+      liftIO $ sendTextData clientConnection apolloRes     ---------------------------     filterByChannels = filter       ( not@@ -105,7 +107,7 @@       . sessionSubscription       ) -removeClientSubscription :: ClientID -> Text -> GQLState m e -> IO ()+removeClientSubscription :: MonadIO m => ClientID -> Text -> GQLState m e -> m () removeClientSubscription id' sid' = updateClientByID id' stopSubscription  where   stopSubscription client' = client'@@ -113,7 +115,7 @@     }  addClientSubscription-  :: ClientID -> SubEvent m e -> Text -> GQLState m e -> IO ()+  :: MonadIO m => ClientID -> SubEvent m e -> Text -> GQLState m e -> m () addClientSubscription id' sessionSubscription sessionId = updateClientByID   id'   startSubscription

@@ -11,11 +11,12 @@   , WRAPPER   , UNION   , INPUT_OBJECT-  , INPUT_UNION   , GQL_KIND   , Context(..)   , VContext(..)   , ResContext(..)+  , OUTPUT+  , INPUT   ) where @@ -24,14 +25,11 @@  data GQL_KIND   = SCALAR-  | OBJECT   | ENUM-  | INPUT_OBJECT-  | UNION-  | INPUT_UNION+  | INPUT+  | OUTPUT   | WRAPPER - data ResContext (kind :: GQL_KIND) (operation:: OperationType) event (m :: * -> * )  value = ResContext  --type ObjectConstraint a =@@ -48,20 +46,26 @@ -- | GraphQL Scalar: Int, Float, String, Boolean or any user defined custom Scalar type type SCALAR = 'SCALAR --- | GraphQL Object-type OBJECT = 'OBJECT- -- | GraphQL Enum type ENUM = 'ENUM +-- | GraphQL Arrays , Resolvers and NonNull fields+type WRAPPER = 'WRAPPER++-- | GraphQL Object and union+type OUTPUT = 'OUTPUT++-- | GraphQL input Object and input union+type INPUT = 'INPUT++{-# DEPRECATED INPUT_OBJECT "use more generalised kind: INPUT" #-} -- | GraphQL input Object-type INPUT_OBJECT = 'INPUT_OBJECT+type INPUT_OBJECT = 'INPUT +{-# DEPRECATED UNION "use: deriving(GQLType), INPORTANT: only types with <type constructor name><constructor name> will sustain their form, other union constructors will be wrapped inside an new object" #-} -- | GraphQL Union-type UNION = 'UNION---- | extension for graphQL-type INPUT_UNION = 'INPUT_UNION+type UNION = 'OUTPUT --- | GraphQL Arrays , Resolvers and NonNull fields-type WRAPPER = 'WRAPPER+{-# DEPRECATED OBJECT "use: deriving(GQLType), will be automatically inferred" #-}+-- | GraphQL Object+type OBJECT = 'OUTPUT

@@ -34,7 +34,7 @@ import           Data.Morpheus.Types.Internal.AST                                                 ( DataField                                                 , DataFingerprint(..)-                                                , DataTyCon(..)+                                                , DataTypeContent(..)                                                 , DataType(..)                                                 , DataValidator(..)                                                 , Key@@ -54,12 +54,11 @@   metaDirectives <- optionalDirectives   pure     ( typeName-    , DataScalar DataTyCon-      { typeName-      , typeMeta        = Just Meta { metaDescription, metaDirectives }-      , typeFingerprint = SystemFingerprint typeName-      , typeData        = DataValidator pure-      }+    , DataType { typeName+               , typeMeta        = Just Meta { metaDescription, metaDirectives }+               , typeFingerprint = DataFingerprint typeName []+               , typeContent     = DataScalar $ DataValidator pure+               }     )  -- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects@@ -79,18 +78,18 @@ -- objectTypeDefinition :: Maybe Text -> Parser (Text, RawDataType) objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do-  name           <- typDeclaration "type"-  interfaces     <- optionalImplementsInterfaces-  metaDirectives <- optionalDirectives-  fields         <- fieldsDefinition+  implementsName       <- typDeclaration "type"+  implementsInterfaces <- optionalImplementsInterfaces+  metaDirectives       <- optionalDirectives+  fields               <- fieldsDefinition   --------------------------   pure-    ( name-    , Implements interfaces $ DataTyCon-      { typeName        = name-      , typeMeta        = Just Meta { metaDescription, metaDirectives }-      , typeFingerprint = SystemFingerprint name-      , typeData        = fields+    ( implementsName+    , Implements+      { implementsName+      , implementsInterfaces+      , implementsMeta       = Just Meta { metaDescription, metaDirectives }+      , implementsContent    = fields       }     ) @@ -107,20 +106,17 @@ -- interfaceTypeDefinition :: Maybe Text -> Parser (Text, RawDataType) interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do-  typeName       <- typDeclaration "interface"+  interfaceName  <- typDeclaration "interface"   metaDirectives <- optionalDirectives   fields         <- fieldsDefinition   pure-    ( typeName-    , Interface DataTyCon-      { typeName-      , typeMeta        = Just Meta { metaDescription, metaDirectives }-      , typeFingerprint = SystemFingerprint typeName-      , typeData        = fields-      }+    ( interfaceName+    , Interface { interfaceName+                , interfaceMeta = Just Meta { metaDescription, metaDirectives }+                , interfaceContent = fields+                }     ) - -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions -- --  UnionTypeDefinition:@@ -137,12 +133,11 @@   memberTypes    <- unionMemberTypes   pure     ( typeName-    , DataUnion DataTyCon-      { typeName-      , typeMeta        = Just Meta { metaDescription, metaDirectives }-      , typeFingerprint = SystemFingerprint typeName-      , typeData        = memberTypes-      }+    , DataType { typeName+               , typeMeta        = Just Meta { metaDescription, metaDirectives }+               , typeFingerprint = DataFingerprint typeName []+               , typeContent     = DataUnion memberTypes+               }     )   where unionMemberTypes = operator '=' *> parseName `sepBy1` pipeLiteral @@ -164,12 +159,11 @@   enumValuesDefinitions <- setOf enumValueDefinition   pure     ( typeName-    , DataEnum DataTyCon-      { typeName-      , typeMeta        = Just Meta { metaDescription, metaDirectives }-      , typeFingerprint = SystemFingerprint typeName-      , typeData        = enumValuesDefinitions-      }+    , DataType { typeName+               , typeMeta        = Just Meta { metaDescription, metaDirectives }+               , typeFingerprint = DataFingerprint typeName []+               , typeContent     = DataEnum enumValuesDefinitions+               }     )  @@ -189,12 +183,11 @@     fields         <- inputFieldsDefinition     pure       ( typeName-      , DataInputObject DataTyCon-        { typeName-        , typeMeta        = Just Meta { metaDescription, metaDirectives }-        , typeFingerprint = SystemFingerprint typeName-        , typeData        = fields-        }+      , DataType { typeName+                 , typeMeta = Just Meta { metaDescription, metaDirectives }+                 , typeFingerprint = DataFingerprint typeName []+                 , typeContent     = DataInputObject fields+                 }       )  where   inputFieldsDefinition :: Parser [(Key, DataField)]

@@ -39,7 +39,6 @@                                                 , Meta(..)                                                 , DataEnumValue(..)                                                 , Name-                                                , TypeAlias(..)                                                 )  @@ -68,21 +67,17 @@     metaDescription <- optDescription     fieldName       <- parseName     litAssignment -- ':'-    (aliasWrappers, aliasTyCon) <- parseType-    _                           <- parseDefaultValue-    metaDirectives              <- optionalDirectives+    fieldType      <- parseType+    _              <- parseDefaultValue+    metaDirectives <- optionalDirectives     pure         ( fieldName-        , DataField-            { fieldArgs     = []-            , fieldArgsType = Nothing-            , fieldName-            , fieldType     = TypeAlias { aliasTyCon-                                        , aliasWrappers-                                        , aliasArgs     = Nothing-                                        }-            , fieldMeta     = Just Meta { metaDescription, metaDirectives }-            }+        , DataField { fieldArgs     = []+                    , fieldArgsType = Nothing+                    , fieldName+                    , fieldType+                    , fieldMeta = Just Meta { metaDescription, metaDirectives }+                    }         )  -- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments@@ -113,20 +108,16 @@     fieldName       <- parseName     fieldArgs       <- argumentsDefinition     litAssignment -- ':'-    (aliasWrappers, aliasTyCon) <- parseType-    metaDirectives              <- optionalDirectives+    fieldType      <- parseType+    metaDirectives <- optionalDirectives     pure         ( fieldName-        , DataField-            { fieldName-            , fieldArgs-            , fieldArgsType = Nothing-            , fieldType     = TypeAlias { aliasTyCon-                                        , aliasWrappers-                                        , aliasArgs     = Nothing-                                        }-            , fieldMeta     = Just Meta { metaDescription, metaDirectives }-            }+        , DataField { fieldName+                    , fieldArgs+                    , fieldArgsType = Nothing+                    , fieldType+                    , fieldMeta = Just Meta { metaDescription, metaDirectives }+                    }         )  -- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives

@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections     #-} @@ -26,6 +27,7 @@   , keyword   , operator   , optDescription+  , parseNegativeSign   ) where @@ -69,15 +71,21 @@                                                 , Key                                                 , Description                                                 , Name-                                                , TypeWrapper(..)                                                 , toHSWrappers-                                                , convertToHaskellName )+                                                , convertToHaskellName+                                                , Ref(..)+                                                , TypeRef(..)+                                                )   -- 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+ parseName :: Parser Name parseName = token @@ -121,12 +129,13 @@ -- -- Variable :  $Name ---variable :: Parser (Text, Position)+variable :: Parser Ref variable = label "variable" $ do-  position' <- getLocation-  _         <- char '$'-  varName'  <- token-  return (varName', position')+  refPosition <- getLocation+  _           <- char '$'+  refName     <- token+  spaceAndComments+  pure $ Ref { refName, refPosition }  spaceAndComments1 :: Parser () spaceAndComments1 = space1 *> spaceAndComments@@ -244,8 +253,11 @@   where alias = label "alias" $ token <* char ':' <* spaceAndComments  -parseType :: Parser ([TypeWrapper], Key)+parseType :: Parser TypeRef parseType = do-  (wrappers, fieldType) <- parseWrappedType-  nonNull               <- parseNonNull-  pure (toHSWrappers $ nonNull ++ wrappers, fieldType)+  (wrappers, typeConName) <- parseWrappedType+  nonNull                 <- parseNonNull+  pure TypeRef { typeConName+               , typeArgs     = Nothing+               , typeWrappers = toHSWrappers $ nonNull ++ wrappers+               }

@@ -5,6 +5,7 @@   ( parseValue   , enumValue   , parseDefaultValue+  , parseRawValue   ) where @@ -34,44 +35,38 @@                                                 , setOf                                                 , spaceAndComments                                                 , token+                                                , parseNegativeSign+                                                , variable                                                 ) import           Data.Morpheus.Types.Internal.AST                                                 ( ScalarValue(..)                                                 , Value(..)+                                                , RawValue+                                                , ValidValue                                                 , decodeScientific+                                                , Name+                                                , Value(..)+                                                , ResolvedValue                                                 ) -parseDefaultValue :: Parser (Maybe Value)-parseDefaultValue = optional $ do-  litEquals-  parseValue--parseValue :: Parser Value-parseValue = label "value" $ do-  value <--    valueNull-    <|> booleanValue-    <|> valueNumber-    <|> enumValue-    <|> stringValue-    <|> objectValue-    <|> listValue-  spaceAndComments-  return value--valueNull :: Parser Value+valueNull :: Parser (Value a) valueNull = string "null" $> Null -booleanValue :: Parser Value+booleanValue :: Parser (Value a) booleanValue = boolTrue <|> boolFalse  where   boolTrue  = string "true" $> Scalar (Boolean True)   boolFalse = string "false" $> Scalar (Boolean False) -valueNumber :: Parser Value-valueNumber = Scalar . decodeScientific <$> scientific+valueNumber :: Parser (Value a)+valueNumber = do+  isNegative <- parseNegativeSign+  Scalar . decodeScientific . signedNumber isNegative <$> scientific+ where+  signedNumber isNegative number | isNegative = -number+                                 | otherwise  = number -enumValue :: Parser Value+enumValue :: Parser (Value a) enumValue = do   enum <- Enum <$> token   spaceAndComments@@ -86,18 +81,47 @@   codes        = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']   escapeChar code replacement = char code >> return replacement -stringValue :: Parser Value+stringValue :: Parser (Value a) stringValue = label "stringValue" $ Scalar . String . pack <$> between   (char '"')   (char '"')   (many escaped) -listValue :: Parser Value-listValue = label "listValue" $ List <$> between++listValue :: Parser a -> Parser [a]+listValue parser = label "listValue" $ between   (char '[' *> spaceAndComments)   (char ']' *> spaceAndComments)-  (parseValue `sepBy` (char ',' *> spaceAndComments))+  (parser `sepBy` (char ',' *> spaceAndComments)) -objectValue :: Parser Value-objectValue = label "objectValue" $ Object <$> setOf entry-  where entry = parseAssignment token parseValue+objectValue :: Show a => Parser a -> Parser [(Name, a)]+objectValue parser = label "objectValue" $ setOf entry+  where entry = parseAssignment token parser++structValue :: Parser (Value a) -> Parser (Value a)+structValue parser =+  label "Value"+    $  (   parsePrimitives+       <|> (Object <$> objectValue parser)+       <|> (List <$> listValue parser)+       )+    <* spaceAndComments++parsePrimitives :: Parser (Value a)+parsePrimitives =+  valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue++parseDefaultValue :: Parser (Maybe ResolvedValue)+parseDefaultValue = optional $ do+  litEquals+  parseV+ where+  parseV :: Parser ResolvedValue+  parseV = structValue parseV+++parseValue :: Parser ValidValue+parseValue = structValue parseValue++parseRawValue :: Parser RawValue+parseRawValue = (VariableValue <$> variable) <|> structValue parseRawValue

@@ -24,6 +24,7 @@ import           Data.Morpheus.Types.Internal.AST                                                 ( DataField                                                 , DataType(..)+                                                , DataTypeContent(..)                                                 , DataTypeLib                                                 , DataTypeWrapper(..)                                                 , Key@@ -70,11 +71,11 @@   parse Type { name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields }     = do       fields <- traverse parse iFields-      pure [(typeName, DataInputObject $ createType typeName fields)]+      pure [(typeName, createType typeName $ DataInputObject fields)]   parse Type { name = Just typeName, kind = OBJECT, fields = Just oFields } =     do       fields <- traverse parse oFields-      pure [(typeName, DataObject $ createType typeName fields)]+      pure [(typeName, createType typeName $ DataObject  fields)]   parse _ = pure []  instance ParseJSONSchema Field (Key,DataField) where

@@ -5,9 +5,7 @@   ) where -import           Text.Megaparsec                ( label-                                                , (<|>)-                                                )+import           Text.Megaparsec                ( label)  -- MORPHEUS import           Data.Morpheus.Parsing.Internal.Internal@@ -18,18 +16,13 @@                                                 ( parseAssignment                                                 , parseMaybeTuple                                                 , token-                                                , variable                                                 ) import           Data.Morpheus.Parsing.Internal.Value-                                                ( enumValue-                                                , parseValue-                                                )+                                                ( parseRawValue ) import           Data.Morpheus.Types.Internal.AST-                                                ( ValueOrigin(..)-                                                , Argument(..)-                                                , RawArgument(..)+                                                ( Argument(..)+                                                , RawArgument                                                 , RawArguments-                                                , Ref(..)                                                 )  @@ -42,19 +35,11 @@ --  Name : Value[Const] -- TODO: move variable to Value valueArgument :: Parser RawArgument-valueArgument = label "valueArgument" $ do+valueArgument = label "Argument" $ do   argumentPosition <- getLocation-  argumentValue    <- parseValue <|> enumValue-  pure $ RawArgument $ Argument { argumentValue-                                , argumentOrigin   = INLINE-                                , argumentPosition-                                }--variableArgument :: Parser RawArgument-variableArgument = label "variableArgument" $ do-  (refName, refPosition) <- variable-  pure $ VariableRef $ Ref { refName, refPosition }+  argumentValue    <- parseRawValue+  pure $ Argument { argumentValue, argumentPosition }  maybeArguments :: Parser RawArguments-maybeArguments = label "maybeArguments" $ parseMaybeTuple argument-  where argument = parseAssignment token (valueArgument <|> variableArgument)+maybeArguments =+  label "Arguments" $ parseMaybeTuple (parseAssignment token valueArgument)

@@ -36,12 +36,13 @@ import           Data.Morpheus.Parsing.Request.Selection                                                 ( parseSelectionSet ) import           Data.Morpheus.Types.Internal.AST-                                                ( DefaultValue-                                                , Operation(..)+                                                ( Operation(..)                                                 , RawOperation                                                 , Variable(..)                                                 , OperationType(..)-                                                , isNullable+                                                , Ref(..)+                                                , VariableContent(..)+                                                , RAW                                                 )  @@ -50,19 +51,17 @@ --  VariableDefinition --    Variable : Type DefaultValue(opt) ---variableDefinition :: Parser (Text, Variable DefaultValue)+variableDefinition :: Parser (Text, Variable RAW) variableDefinition = label "VariableDefinition" $ do-  (name, variablePosition) <- variable+  (Ref name variablePosition) <- variable   operator ':'-  (variableTypeWrappers, variableType) <- parseType-  defaultValue                         <- parseDefaultValue+  variableType <- parseType+  defaultValue <- parseDefaultValue   pure     ( name     , Variable { variableType-               , isVariableRequired   = not (isNullable variableTypeWrappers)-               , variableTypeWrappers                , variablePosition-               , variableValue        = defaultValue+               , variableValue    = DefaultValue defaultValue                }     ) @@ -78,14 +77,14 @@   operationPosition  <- getLocation   operationType      <- parseOperationType   operationName      <- optional parseName-  operationArgs      <- parseMaybeTuple variableDefinition+  operationArguments <- parseMaybeTuple variableDefinition   -- TODO: handle directives   _directives        <- optionalDirectives   operationSelection <- parseSelectionSet   pure     (Operation { operationName                , operationType-               , operationArgs+               , operationArguments                , operationSelection                , operationPosition                }@@ -107,7 +106,7 @@   pure       (Operation { operationName      = Nothing                  , operationType      = Query-                 , operationArgs      = []+                 , operationArguments = []                  , operationSelection                  , operationPosition                  }

@@ -35,9 +35,9 @@                                                 , Failure(..)                                                 ) import           Data.Morpheus.Types.Internal.AST-                                                ( Value(..)-                                                , replaceValue+                                                ( replaceValue                                                 , GQLQuery(..)+                                                , ResolvedValue                                                 ) import           Data.Morpheus.Types.IO         ( GQLRequest(..) ) @@ -57,7 +57,7 @@   Right root       -> pure $ root { inputVariables = toVariableMap variables }   Left  parseError -> failure $ processErrorBundle parseError  where-  toVariableMap :: Maybe Aeson.Value -> [(Text, Value)]+  toVariableMap :: Maybe Aeson.Value -> [(Text, ResolvedValue)]   toVariableMap (Just (Aeson.Object x)) = map toMorpheusValue (toList x)     where toMorpheusValue (key, value) = (key, replaceValue value)   toVariableMap _ = []

@@ -34,11 +34,12 @@                                                 ( maybeArguments ) import           Data.Morpheus.Types.Internal.AST                                                 ( Selection(..)+                                                , SelectionContent(..)+                                                , Ref(..)                                                 , Fragment(..)                                                 , RawArguments-                                                , RawSelection(..)+                                                , RawSelection                                                 , RawSelectionSet-                                                , Ref(..)                                                 )  @@ -80,23 +81,23 @@  where     ----------------------------------------   buildField selectionAlias selectionArguments selectionPosition = pure-    (RawSelectionField $ Selection { selectionAlias-                                   , selectionArguments-                                   , selectionRec       = ()-                                   , selectionPosition-                                   }+    (Selection { selectionAlias+               , selectionArguments+               , selectionContent   = SelectionField+               , selectionPosition+               }     )   -----------------------------------------   selSet :: Maybe Text -> RawArguments -> Parser RawSelection   selSet selectionAlias selectionArguments = label "body" $ do     selectionPosition <- getLocation-    selectionRec      <- parseSelectionSet+    selectionSet      <- parseSelectionSet     return-      (RawSelectionSet $ Selection { selectionAlias-                                   , selectionArguments-                                   , selectionRec-                                   , selectionPosition-                                   }+      (Selection { selectionAlias+                 , selectionArguments+                 , selectionContent   = SelectionSet selectionSet+                 , selectionPosition+                 }       )  

@@ -21,12 +21,12 @@ -- MORPHEUS import           Data.Morpheus.Types.Internal.AST                                                 ( DataField(..)-                                                , DataTyCon(..)+                                                , DataTypeContent(..)                                                 , DataType(..)                                                 , DataTypeLib                                                 , DataTypeWrapper(..)                                                 , Key-                                                , TypeAlias(..)+                                                , TypeRef(..)                                                 , TypeWrapper(..)                                                 , allDataTypes                                                 , createInputUnionFields@@ -34,7 +34,8 @@                                                 , isDefaultTypeName                                                 , toGQLWrapper                                                 , DataEnumValue(..)-                                                , convertToJSONName )+                                                , convertToJSONName+                                                )   renderGraphQLDocument :: DataTypeLib -> ByteString@@ -53,42 +54,34 @@       showGQLWrapper (ListType:xs)    = "[" <> showGQLWrapper xs <> "]"       showGQLWrapper (NonNullType:xs) = showGQLWrapper xs <> "!" + instance RenderGQL Key where   render = id -instance RenderGQL TypeAlias where-  render TypeAlias { aliasTyCon, aliasWrappers } =-    renderWrapped aliasTyCon aliasWrappers+instance RenderGQL TypeRef where+  render TypeRef { typeConName, typeWrappers } =+    renderWrapped typeConName typeWrappers  instance RenderGQL DataType where-  render (DataScalar      x) = typeName x-  render (DataEnum        x) = typeName x-  render (DataUnion       x) = typeName x-  render (DataInputObject x) = typeName x-  render (DataInputUnion  x) = typeName x-  render (DataObject      x) = typeName x+  render = typeName  instance RenderGQL DataEnumValue where   render DataEnumValue { enumName } = enumName  instance RenderGQL (Key, DataType) where-  render (name, DataScalar{}) = "scalar " <> name-  render (name, DataEnum DataTyCon { typeData }) =-    "enum " <> name <> renderObject render typeData-  render (name, DataUnion DataTyCon { typeData }) =-    "union "-      <> name-      <> " =\n    "-      <> intercalate ("\n" <> renderIndent <> "| ") typeData-  render (name, DataInputObject DataTyCon { typeData }) =-    "input " <> name <> render typeData-  render (name, DataInputUnion DataTyCon { typeData }) =-    "input " <> name <> render fields-    where fields = createInputUnionFields name typeData-  render (name, DataObject DataTyCon { typeData }) =-    "type " <> name <> render typeData--+  render (name, DataType { typeContent }) = __render typeContent+   where+    __render DataScalar{}    = "scalar " <> name+    __render (DataEnum tags) = "enum " <> name <> renderObject render tags+    __render (DataUnion members) =+      "union "+        <> name+        <> " =\n    "+        <> intercalate ("\n" <> renderIndent <> "| ") members+    __render (DataInputObject fields ) = "input " <> name <> render fields+    __render (DataInputUnion  members) = "input " <> name <> render fields+      where fields = createInputUnionFields name (map fst members)+    __render (DataObject fields) = "type " <> name <> render fields  -- OBJECT instance RenderGQL [(Text, DataField)] where

@@ -19,15 +19,16 @@ import           Data.Morpheus.Schema.Schema import           Data.Morpheus.Schema.TypeKind  ( TypeKind(..) ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)-                                                , DataTyCon(..)+                                                ( DataInputUnion+                                                , DataField(..)+                                                , DataTypeContent(..)                                                 , DataType(..)                                                 , DataTypeKind(..)                                                 , DataTypeLib                                                 , DataTypeWrapper(..)                                                 , DataUnion                                                 , Meta(..)-                                                , TypeAlias(..)+                                                , TypeRef(..)                                                 , createInputUnionFields                                                 , fieldVisibility                                                 , kindOf@@ -35,8 +36,10 @@                                                 , toGQLWrapper                                                 , DataEnumValue(..)                                                 , lookupDeprecated+                                                , DataInputUnion                                                 , lookupDeprecatedReason-                                                , convertToJSONName )+                                                , convertToJSONName+                                                ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( Failure(..) ) @@ -49,24 +52,22 @@   render :: (Monad m, Failure Text m) => (Text, a) -> DataTypeLib -> m (b m)  instance RenderSchema DataType S__Type where-  render (key, DataScalar DataTyCon { typeMeta }) =-    constRes $ createLeafType SCALAR key typeMeta Nothing-  render (key, DataEnum DataTyCon { typeMeta, typeData }) =-    constRes-      $ createLeafType ENUM key typeMeta (Just $ map createEnumValue typeData)-  render (name, DataInputObject DataTyCon { typeData, typeMeta }) =-    renderInputObject-   where-    renderInputObject lib = do-      fields <- traverse (`renderinputValue` lib) typeData-      pure $ createInputObject name typeMeta fields-  render (name, DataObject object') = typeFromObject (name, object')+  render (name, DataType { typeMeta, typeContent }) = __render typeContent    where-    typeFromObject (key, DataTyCon { typeData, typeMeta }) lib =-      createObjectType key (typeMeta >>= metaDescription)-        <$> (Just <$> traverse (`render` lib) (filter fieldVisibility typeData))-  render (name, DataUnion union) = constRes $ typeFromUnion (name, union)-  render (name, DataInputUnion inpUnion') = renderInputUnion (name, inpUnion')+    __render DataScalar{} =+      constRes $ createLeafType SCALAR name typeMeta Nothing+    __render (DataEnum enums) = constRes+      $ createLeafType ENUM name typeMeta (Just $ map createEnumValue enums)+    __render (DataInputObject fields) = \lib ->+      createInputObject name typeMeta+        <$> traverse (`renderinputValue` lib) fields+    __render (DataObject fields) = \lib ->+      createObjectType name (typeMeta >>= metaDescription)+        <$> (Just <$> traverse (`render` lib) (filter fieldVisibility fields))+    __render (DataUnion union) =+      constRes $ typeFromUnion (name, typeMeta, union)+    __render (DataInputUnion members) =+      renderInputUnion (name, typeMeta, members)  createEnumValue :: Monad m => DataEnumValue -> S__EnumValue m createEnumValue DataEnumValue { enumName, enumMeta } = S__EnumValue@@ -79,16 +80,16 @@   where deprecated = enumMeta >>= lookupDeprecated  instance RenderSchema DataField S__Field where-  render (name, field@DataField { fieldType = TypeAlias { aliasTyCon }, fieldArgs, fieldMeta }) lib+  render (name, field@DataField { fieldType = TypeRef { typeConName }, fieldArgs, fieldMeta }) lib     = do-      kind <- renderTypeKind <$> lookupKind aliasTyCon lib+      kind <- renderTypeKind <$> lookupKind typeConName lib       args <- traverse (`renderinputValue` lib) fieldArgs       pure S__Field         { s__FieldName              = constRes (convertToJSONName name)         , s__FieldDescription       = constRes (fieldMeta >>= metaDescription)         , s__FieldArgs              = constRes args         , s__FieldType'             =-          constRes (wrap field $ createType kind aliasTyCon Nothing $ Just [])+          constRes (wrap field $ createType kind typeConName Nothing $ Just [])         , s__FieldIsDeprecated      = constRes (isJust deprecated)         , s__FieldDeprecationReason = constRes                                         (deprecated >>= lookupDeprecatedReason)@@ -106,8 +107,8 @@ renderTypeKind KindNonNull     = NON_NULL  wrap :: Monad m => DataField -> S__Type m -> S__Type m-wrap DataField { fieldType = TypeAlias { aliasWrappers } } typ =-  foldr wrapByTypeWrapper typ (toGQLWrapper aliasWrappers)+wrap DataField { fieldType = TypeRef { typeWrappers } } typ =+  foldr wrapByTypeWrapper typ (toGQLWrapper typeWrappers)  wrapByTypeWrapper :: Monad m => DataTypeWrapper -> S__Type m -> S__Type m wrapByTypeWrapper ListType    = wrapAs LIST@@ -128,17 +129,20 @@  createInputObjectType   :: (Monad m, Failure Text m) => DataField -> Result m (S__Type m)-createInputObjectType field@DataField { fieldType = TypeAlias { aliasTyCon } } lib+createInputObjectType field@DataField { fieldType = TypeRef { typeConName } } lib   = do-    kind <- renderTypeKind <$> lookupKind aliasTyCon lib-    pure $ wrap field $ createType kind aliasTyCon Nothing $ Just []+    kind <- renderTypeKind <$> lookupKind typeConName lib+    pure $ wrap field $ createType kind typeConName Nothing $ Just []   renderInputUnion-  :: (Monad m, Failure Text m) => (Text, DataUnion) -> Result m (S__Type m)-renderInputUnion (key, DataTyCon { typeData, typeMeta }) lib =-  createInputObject key typeMeta-    <$> traverse createField (createInputUnionFields key typeData)+  :: (Monad m, Failure Text m)+  => (Text, Maybe Meta, DataInputUnion)+  -> Result m (S__Type m)+renderInputUnion (key, meta, fields) lib =+  createInputObject key meta <$> traverse+    createField+    (createInputUnionFields key $ map fst $ filter snd fields)  where   createField (name, field) =     createInputValueWith name Nothing <$> createInputObjectType field lib@@ -162,8 +166,8 @@   , s__TypeInputFields   = constRes Nothing   } -typeFromUnion :: Monad m => (Text, DataUnion) -> S__Type m-typeFromUnion (name, DataTyCon { typeData, typeMeta }) = S__Type+typeFromUnion :: Monad m => (Text, Maybe Meta, DataUnion) -> S__Type m+typeFromUnion (name, typeMeta, typeContent) = S__Type   { s__TypeKind          = constRes UNION   , s__TypeName          = constRes $ Just name   , s__TypeDescription   = constRes (typeMeta >>= metaDescription)@@ -171,7 +175,8 @@   , s__TypeOfType        = constRes Nothing   , s__TypeInterfaces    = constRes Nothing   , s__TypePossibleTypes =-    constRes $ Just (map (\x -> createObjectType x Nothing $ Just []) typeData)+    constRes+      $ Just (map (\x -> createObjectType x Nothing $ Just []) typeContent)   , s__TypeEnumValues    = constRes Nothing   , s__TypeInputFields   = constRes Nothing   }

@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns   #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators    #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Schema.SchemaAPI   ( hiddenRootFields@@ -15,9 +16,10 @@  -- MORPHEUS import           Data.Morpheus.Execution.Server.Introspect-                                                ( ObjectFields(..)+                                                ( objectFields                                                 , TypeUpdater                                                 , introspect+                                                , TypeScope(..)                                                 ) import           Data.Morpheus.Rendering.RenderIntrospection                                                 ( createObjectType@@ -33,9 +35,9 @@ import           Data.Morpheus.Types.ID         ( ID ) import           Data.Morpheus.Types.Internal.AST                                                 ( DataField(..)-                                                , DataObject                                                 , DataTypeLib(..)                                                 , QUERY+                                                , DataType                                                 , allDataTypes                                                 , lookupDataType                                                 )@@ -50,7 +52,7 @@ convertTypes lib = traverse (`render` lib) (allDataTypes lib)  buildSchemaLinkType-  :: Monad m => (Text, DataObject) -> S__Type (Resolver QUERY e m)+  :: Monad m => (Text, DataType) -> S__Type (Resolver QUERY e m) buildSchemaLinkType (key', _) = createObjectType key' Nothing $ Just []  findType@@ -78,8 +80,9 @@   }  hiddenRootFields :: [(Text, DataField)]-hiddenRootFields = fst-  $ objectFields (Proxy :: Proxy (CUSTOM (Root Maybe))) (Proxy @(Root Maybe))+hiddenRootFields = fst $ objectFields+  (Proxy :: Proxy (CUSTOM (Root Maybe)))+  ("Root", OutputType, Proxy @(Root Maybe))  defaultTypes :: TypeUpdater defaultTypes = flip

@@ -7,6 +7,7 @@ -- |  GraphQL Wai Server Applications module Data.Morpheus.Server   ( gqlSocketApp+  , gqlSocketMonadIOApp   , initGQLState   , GQLState   )@@ -14,6 +15,7 @@  import           Control.Exception              ( finally ) import           Control.Monad                  ( forever )+import           Control.Monad.IO.Class         ( MonadIO(liftIO) ) import           Data.Text                      ( Text ) import           Network.WebSockets             ( ServerApp                                                 , acceptRequestWith@@ -55,21 +57,21 @@                                                 ( GQLClient(..) ) import           Data.Morpheus.Types.IO         ( GQLResponse(..) ) import           Data.Morpheus.Types.Internal.AST-                                                ( Value )+                                                ( ValidValue )  handleSubscription-  :: (Eq (StreamChannel e), GQLChannel e)-  => GQLClient IO e-  -> GQLState IO e+  :: (Eq (StreamChannel e), GQLChannel e, MonadIO m)+  => GQLClient m e+  -> GQLState m e   -> Text-  -> ResponseStream e IO Value-  -> IO ()+  -> ResponseStream e m ValidValue+  -> m () handleSubscription GQLClient { clientConnection, clientID } state sessionId stream   = do     response <- runResultT stream     case response of       Success { events } -> mapM_ execute events-      Failure errors     -> sendTextData+      Failure errors     -> liftIO $ sendTextData         clientConnection         (toApolloResponse sessionId $ Errors errors)  where@@ -77,25 +79,35 @@   execute (Subscribe sub) = addClientSubscription clientID sub sessionId state  -- | Wai WebSocket Server App for GraphQL subscriptions-gqlSocketApp-  :: RootResCon IO e que mut sub-  => GQLRootResolver IO e que mut sub-  -> GQLState IO e+gqlSocketMonadIOApp+  :: (RootResCon m e que mut sub, MonadIO m)+  => GQLRootResolver m e que mut sub+  -> GQLState m e+  -> (m () -> IO ())   -> ServerApp-gqlSocketApp gqlRoot state pending = do+gqlSocketMonadIOApp gqlRoot state f pending = do   connection <- acceptRequestWith pending     $ acceptApolloSubProtocol (pendingRequest pending)   forkPingThread connection 30   client <- connectClient connection state-  finally (queryHandler client) (disconnectClient client state)+  finally (f $ queryHandler client) (disconnectClient client state)  where   queryHandler client = forever handleRequest    where-    handleRequest =-      receiveData (clientConnection client) >>= resolveMessage . apolloFormat+    handleRequest = do+      d <- liftIO $ receiveData (clientConnection client)+      resolveMessage (apolloFormat d)      where-      resolveMessage (SubError x) = print x+      resolveMessage (SubError x) = liftIO $ print x       resolveMessage (AddSub sessionId request) =         handleSubscription client state sessionId (coreResolver gqlRoot request)       resolveMessage (RemoveSub sessionId) =         removeClientSubscription (clientID client) sessionId state++-- | Same as above but specific to IO+gqlSocketApp+  :: (RootResCon IO e que mut sub)+  => GQLRootResolver IO e que mut sub+  -> GQLState IO e+  -> ServerApp+gqlSocketApp gqlRoot state = gqlSocketMonadIOApp gqlRoot state id

@@ -29,9 +29,11 @@   , ResolveQ   , ResolveM   , ResolveS+  , failRes   ) where +import           Data.Text                      ( pack ) import           Data.Morpheus.Types.GQLScalar  ( GQLScalar                                                   ( parseValue                                                   , serialize@@ -51,6 +53,7 @@                                                 , Resolver(..)                                                 , LiftEither(..)                                                 , lift+                                                , failure                                                 ) import           Data.Morpheus.Types.IO         ( GQLRequest(..)                                                 , GQLResponse(..)@@ -76,3 +79,6 @@  constMutRes :: Monad m => [e] -> a -> args -> MutRes e m a constMutRes events value = const $ MutResolver $ pure (events, value)++failRes :: (LiftEither o Resolver, Monad m) => String -> Resolver o e m a+failRes = failure . pack

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs                   #-} {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE OverloadedStrings       #-} {-# LANGUAGE ScopedTypeVariables     #-}@@ -10,14 +11,15 @@  import           Data.Morpheus.Types.Internal.AST.Data                                                 ( DataValidator(..) )-import           Data.Morpheus.Types.Internal.AST.Value+import           Data.Morpheus.Types.Internal.AST                                                 ( ScalarValue(..)+                                                , ValidValue                                                 , Value(..)                                                 ) import           Data.Proxy                     ( Proxy(..) ) import           Data.Text                      ( Text ) -toScalar :: Value -> Either Text ScalarValue+toScalar :: ValidValue -> Either Text ScalarValue toScalar (Scalar x) = pure x toScalar _          = Left "" @@ -65,5 +67,6 @@  instance GQLScalar Float where   parseValue (Float x) = pure x+  parseValue (Int   x) = pure $ fromInteger $ toInteger x   parseValue _         = Left ""   serialize = Float

@@ -80,13 +80,34 @@ --     instance GQLType ... where --       description = const "your description ..." --  @-class GQLType a where++class IsObject (a :: GQL_KIND) where+  isObject :: Proxy a -> Bool++instance IsObject SCALAR where+  isObject _ = False++instance IsObject ENUM where+  isObject _ = False++instance IsObject WRAPPER where+  isObject _ = False++instance IsObject INPUT where+  isObject _ = True++instance IsObject OUTPUT where+  isObject _ = True++class IsObject (KIND a) => GQLType a where   type KIND a :: GQL_KIND-  type KIND a = OBJECT+  type KIND a = OUTPUT   type CUSTOM a :: Bool   type CUSTOM a = FALSE   description :: Proxy a -> Maybe Text   description _ = Nothing+  isObjectKind :: Proxy a -> Bool+  isObjectKind _ = isObject (Proxy @(KIND a))   __typeName :: Proxy a -> Text   default __typeName :: (Typeable a) =>     Proxy a -> Text@@ -96,7 +117,7 @@   __typeFingerprint :: Proxy a -> DataFingerprint   default __typeFingerprint :: (Typeable a) =>     Proxy a -> DataFingerprint-  __typeFingerprint _ = TypeableFingerprint $ map show $ conFingerprints (Proxy @a)+  __typeFingerprint _ = DataFingerprint "Typeable" $ map show $ conFingerprints (Proxy @a)     where       conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep) @@ -143,10 +164,10 @@   __typeFingerprint _ = __typeFingerprint (Proxy @a)  instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where-  type KIND (Pair a b) = OBJECT+  type KIND (Pair a b) = OUTPUT  instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where-  type KIND (MapKind a b m) = OBJECT+  type KIND (MapKind a b m) = OUTPUT   __typeName _ = __typeName (Proxy @(Map a b))   __typeFingerprint _ = __typeFingerprint (Proxy @(Map a b)) 

@@ -10,7 +10,7 @@ import           Data.Morpheus.Kind             ( SCALAR ) import           Data.Morpheus.Types.GQLScalar  ( GQLScalar(..) ) import           Data.Morpheus.Types.GQLType    ( GQLType(KIND) )-import           Data.Morpheus.Types.Internal.AST.Value+import           Data.Morpheus.Types.Internal.AST                                                 ( ScalarValue(..) ) import           Data.Text                      ( Text                                                 , pack

@@ -32,10 +32,10 @@                                                 , Result(..)                                                 ) import           Data.Morpheus.Types.Internal.AST.Value-                                                ( Value )+                                                ( ValidValue )  -renderResponse :: Result e GQLError con Value -> GQLResponse+renderResponse :: Result e GQLError con ValidValue -> GQLResponse renderResponse (Failure errors)   = Errors errors renderResponse Success { result } = Data result @@ -57,7 +57,7 @@  -- | GraphQL Response data GQLResponse-  = Data Value+  = Data ValidValue   | Errors [GQLError]   deriving (Show, Generic) 

@@ -1,4 +1,6 @@-{-# LANGUAGE DeriveLift       #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveLift           #-}+{-# LANGUAGE OverloadedStrings    #-}  module Data.Morpheus.Types.Internal.AST   (@@ -11,6 +13,10 @@   , anonymousRef   , Name   , Description+  , Stage+  , RESOLVED+  , VALID+  , RAW    -- VALUE   , Value(..)@@ -21,22 +27,32 @@   , decodeScientific   , convertToJSONName   , convertToHaskellName+  , RawValue+  , ValidValue+  , RawObject+  , ValidObject+  , ResolvedObject+  , ResolvedValue+  , unpackInputUnion    -- Selection   , Argument(..)   , Arguments   , SelectionSet-  , SelectionRec(..)-  , ValueOrigin(..)+  , SelectionContent(..)   , ValidSelection   , Selection(..)-  , RawSelection'+  , RawSelection   , FragmentLib   , RawArguments   , RawSelectionSet   , Fragment(..)-  , RawArgument(..)-  , RawSelection(..)+  , RawArgument+  , ValidSelectionSet+  , ValidArgument+  , ValidArguments+  , RawSelectionRec+  , ValidSelectionRec    -- OPERATION   , Operation(..)@@ -48,6 +64,7 @@   , DefaultValue   , getOperationName   , getOperationDataType+  , getOperationObject     -- DSL@@ -58,7 +75,7 @@   , DataUnion   , DataArguments   , DataField(..)-  , DataTyCon(..)+  , DataTypeContent(..)   , DataType(..)   , DataTypeLib(..)   , DataTypeWrapper(..)@@ -68,7 +85,7 @@   , RawDataType(..)   , ResolverKind(..)   , TypeWrapper(..)-  , TypeAlias(..)+  , TypeRef(..)   , ArgsType(..)   , DataEnumValue(..)   , isTypeDefined@@ -120,7 +137,6 @@   , Meta(..)   , Directive(..)   , createEnumValue-  , fromDataType   , insertType   , TypeUpdater   , lookupDeprecated@@ -130,33 +146,64 @@   , ClientQuery(..)   , GQLTypeD(..)   , ClientType(..)+  , DataInputUnion+  , VariableContent(..)   -- LOCAL   , GQLQuery(..)   , Variables+  , isNullableWrapper   ) where  import           Data.Map                       ( Map ) import           Language.Haskell.TH.Syntax     ( Lift )-import           Instances.TH.Lift              ( )+import           Data.Semigroup                 ( (<>) )  -- Morpheus import           Data.Morpheus.Types.Internal.AST.Data --import           Data.Morpheus.Types.Internal.AST.Operation- import           Data.Morpheus.Types.Internal.AST.Selection  import           Data.Morpheus.Types.Internal.AST.Base  import           Data.Morpheus.Types.Internal.AST.Value +import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( Failure(..) ) -type Variables = Map Key Value+type Variables = Map Key ResolvedValue  data GQLQuery = GQLQuery   { fragments      :: FragmentLib   , operation      :: RawOperation-  , inputVariables :: [(Key, Value)]+  , inputVariables :: [(Key, ResolvedValue)]   } deriving (Show,Lift)++unpackInputUnion+  :: [(Name, Bool)]+  -> Object stage+  -> Either Message (Name, Maybe (Value stage))+unpackInputUnion tags [("__typename", enum)] = do+  tyName <- isPosibeUnion tags enum+  pure (tyName, Nothing)+unpackInputUnion tags [("__typename", enum), (name, value)] = do+  tyName <- isPosibeUnion tags enum+  inputtypeName tyName name value+unpackInputUnion tags [(name, value), ("__typename", enum)] = do+  tyName <- isPosibeUnion tags enum+  inputtypeName tyName name value+unpackInputUnion _ _ = failure+  ("valid input union should contain __typename and actual value" :: Message)++isPosibeUnion :: [(Name, Bool)] -> Value stage -> Either Message Name+isPosibeUnion tags (Enum name) = case lookup name tags of+  Nothing -> failure (name <> " is not posible union type" :: Message)+  _       -> pure name+isPosibeUnion _ _ = failure ("__typename must be Enum" :: Message)+++inputtypeName+  :: Name -> Name -> Value stage -> Either Message (Name, Maybe (Value stage))+inputtypeName name fName fieldValue+  | fName == name = pure (name, Just fieldValue)+  | otherwise = failure ("field \"" <> name <> "\" was not provided" :: Message)

@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric   #-} {-# LANGUAGE DeriveLift      #-} {-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE DataKinds       #-}  module Data.Morpheus.Types.Internal.AST.Base   ( Key@@ -12,6 +13,12 @@   , anonymousRef   , Name   , Description+  , VALID+  , RAW+  , TypeWrapper(..)+  , Stage(..)+  , RESOLVED+  , TypeRef(..)   ) where @@ -31,6 +38,15 @@  type Collection a = [(Key, a)] ++data Stage = RAW | RESOLVED | VALID++type VALID = 'RAW++type RESOLVED = 'RESOLVED++type RAW = 'VALID+ data Position = Position   { line   :: Int   , column :: Int@@ -53,3 +69,14 @@  anonymousRef :: Key -> Ref anonymousRef refName = Ref { refName, refPosition = Position 0 0 }++data TypeWrapper+  = TypeList+  | TypeMaybe+  deriving (Show, Lift)++data TypeRef = TypeRef+  { typeConName    :: Name+  , typeArgs     :: Maybe Name+  , typeWrappers :: [TypeWrapper]+  } deriving (Show,Lift)

@@ -10,15 +10,14 @@ {-# LANGUAGE RankNTypes            #-}  module Data.Morpheus.Types.Internal.AST.Data-  ( -    DataScalar+  ( DataScalar   , DataEnum   , DataObject   , DataArgument   , DataUnion   , DataArguments   , DataField(..)-  , DataTyCon(..)+  , DataTypeContent(..)   , DataType(..)   , DataTypeLib(..)   , DataTypeWrapper(..)@@ -28,7 +27,7 @@   , RawDataType(..)   , ResolverKind(..)   , TypeWrapper(..)-  , TypeAlias(..)+  , TypeRef(..)   , ArgsType(..)   , DataEnumValue(..)   , isTypeDefined@@ -80,7 +79,6 @@   , Meta(..)   , Directive(..)   , createEnumValue-  , fromDataType   , insertType   , TypeUpdater   , lookupDeprecated@@ -90,6 +88,8 @@   , ClientQuery(..)   , GQLTypeD(..)   , ClientType(..)+  , DataInputUnion+  , isNullableWrapper   ) where @@ -117,6 +117,8 @@                                                 , Position                                                 , Name                                                 , Description+                                                , TypeWrapper(..)+                                                , TypeRef(..)                                                 ) import           Data.Morpheus.Types.Internal.Resolving.Core                                                 ( Validation@@ -126,7 +128,8 @@                                                 , resolveUpdates                                                 ) import           Data.Morpheus.Types.Internal.AST.Value-                                                ( Value(..)+                                                ( Value(..) +                                                , ValidValue                                                 , ScalarValue(..)                                                 ) import           Data.Morpheus.Error.Schema     ( nameCollisionError )@@ -196,18 +199,19 @@   | ExternalResolver   deriving (Show, Eq, Lift) -data TypeWrapper-  = TypeList-  | TypeMaybe-  deriving (Show, Lift) + isFieldNullable :: DataField -> Bool-isFieldNullable = isNullable . aliasWrappers . fieldType+isFieldNullable = isNullable . fieldType -isNullable :: [TypeWrapper] -> Bool-isNullable (TypeMaybe : _) = True-isNullable _               = False+isNullable :: TypeRef -> Bool+isNullable TypeRef { typeWrappers = typeWrappers } = isNullableWrapper typeWrappers +isNullableWrapper :: [TypeWrapper] -> Bool+isNullableWrapper (TypeMaybe : _ ) = True+isNullableWrapper _               = False++ isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool isWeaker (TypeMaybe : xs1) (TypeMaybe : xs2) = isWeaker xs1 xs2 isWeaker (TypeMaybe : _  ) _                 = True@@ -229,27 +233,21 @@ toHSWrappers []                              = [TypeMaybe] toHSWrappers [NonNullType]                   = [] -data DataFingerprint = SystemFingerprint Key | TypeableFingerprint [String]-  deriving (Show, Eq, Ord, Lift)-+data DataFingerprint = DataFingerprint Name [String] deriving (Show, Eq, Ord, Lift)  newtype DataValidator = DataValidator-  { validateValue :: Value -> Either Key Value+  { validateValue :: ValidValue -> Either Key ValidValue   }  instance Show DataValidator where   show _ = "DataValidator" -type DataScalar = DataTyCon DataValidator--type DataEnum = DataTyCon [DataEnumValue]--type DataObject = DataTyCon [(Key, DataField)]-+type DataScalar = DataValidator+type DataEnum = [DataEnumValue]+type DataObject = [(Key, DataField)] type DataArgument = DataField--type DataUnion = DataTyCon [Key]-+type DataUnion = [Key]+type DataInputUnion = [(Key, Bool)] type DataArguments = [(Key, DataArgument)]  data DataTypeWrapper@@ -257,12 +255,6 @@   | NonNullType   deriving (Show, Lift) -data TypeAlias = TypeAlias-  { aliasTyCon    :: Key-  , aliasArgs     :: Maybe Key-  , aliasWrappers :: [TypeWrapper]-  } deriving (Show,Lift)- data ArgsType = ArgsType   { argsTypeName :: Key   , resKind      :: ResolverKind@@ -270,7 +262,7 @@  data Directive = Directive {   directiveName :: Name,-  directiveArgs :: [(Name,Value)]+  directiveArgs :: [(Name, ValidValue)] } deriving (Show,Lift)  -- META@@ -289,6 +281,7 @@ lookupDeprecatedReason Directive { directiveArgs } =   maybeString . snd <$> find isReason directiveArgs  where+  maybeString :: ValidValue -> Name   maybeString (Scalar (String x)) = x   maybeString _                   = "can't read deprecated Reason Value"   isReason ("reason", _) = True@@ -305,7 +298,7 @@   { fieldName     :: Key   , fieldArgs     :: [(Key, DataArgument)]   , fieldArgsType :: Maybe ArgsType-  , fieldType     :: TypeAlias+  , fieldType     :: TypeRef   , fieldMeta     :: Maybe Meta   } deriving (Show,Lift) @@ -316,11 +309,11 @@ fieldVisibility _                 = True  createField :: DataArguments -> Key -> ([TypeWrapper], Key) -> DataField-createField fieldArgs fieldName (aliasWrappers, aliasTyCon) = DataField+createField fieldArgs fieldName (typeWrappers, typeConName) = DataField   { fieldArgs   , fieldArgsType = Nothing   , fieldName-  , fieldType     = TypeAlias { aliasTyCon, aliasWrappers, aliasArgs = Nothing }+  , fieldType     = TypeRef { typeConName, typeWrappers, typeArgs = Nothing }   , fieldMeta     = Nothing   } @@ -330,17 +323,17 @@  toNullableField :: DataField -> DataField toNullableField dataField-  | isNullable (aliasWrappers $ fieldType dataField) = dataField+  | isNullable (fieldType dataField) = dataField   | otherwise = dataField { fieldType = nullable (fieldType dataField) }  where-  nullable alias@TypeAlias { aliasWrappers } =-    alias { aliasWrappers = TypeMaybe : aliasWrappers }+  nullable alias@TypeRef { typeWrappers } =+    alias { typeWrappers = TypeMaybe : typeWrappers }  toListField :: DataField -> DataField toListField dataField = dataField { fieldType = listW (fieldType dataField) }  where-  listW alias@TypeAlias { aliasWrappers } =-    alias { aliasWrappers = TypeList : aliasWrappers }+  listW alias@TypeRef { typeWrappers } =+    alias { typeWrappers = TypeList : typeWrappers }  lookupField :: Failure error m => Key -> [(Key, field)] -> error -> m field lookupField key fields gqlError = case lookup key fields of@@ -350,58 +343,69 @@ lookupSelectionField   :: Failure GQLErrors Validation   => Position-  -> Key+  -> Name+  -> Name   -> DataObject   -> Validation DataField-lookupSelectionField position fieldName DataTyCon { typeData, typeName } =-  lookupField fieldName typeData gqlError+lookupSelectionField position fieldName typeName fields = lookupField+  fieldName+  fields+  gqlError   where gqlError = cannotQueryField fieldName typeName position  -- -- TYPE CONSTRUCTOR ---------------------------------------------------------------------------------------------------data DataTyCon a = DataTyCon-  { typeName        :: Key-  , typeFingerprint :: DataFingerprint-  , typeMeta :: Maybe Meta-  , typeData        :: a-  } deriving (Show, Lift) - data RawDataType   = FinalDataType DataType-  | Interface DataObject-  | Implements { implementsInterfaces :: [Key]-               , unImplements         :: DataObject }+  | Interface {+      interfaceName    :: Key+      , interfaceMeta    :: Maybe Meta+      , interfaceContent :: DataObject+    }+  | Implements {+        implementsName    :: Key+      , implementsInterfaces :: [Key]+      , implementsMeta    :: Maybe Meta+      , implementsContent         :: DataObject+    }   deriving (Show)  -- -- DATA TYPE ---------------------------------------------------------------------------------------------------data DataType+data DataTypeContent   = DataScalar DataScalar   | DataEnum DataEnum   | DataInputObject DataObject   | DataObject DataObject   | DataUnion DataUnion-  | DataInputUnion DataUnion+  | DataInputUnion [(Key,Bool)]   deriving (Show) -createType :: Key -> a -> DataTyCon a-createType typeName typeData = DataTyCon+data DataType = DataType+  { typeName        :: Key+  , typeFingerprint :: DataFingerprint+  , typeMeta :: Maybe Meta+  , typeContent       :: DataTypeContent+  } deriving (Show)++createType :: Key -> DataTypeContent -> DataType+createType typeName typeContent = DataType   { typeName   , typeMeta        = Nothing-  , typeFingerprint = SystemFingerprint ""-  , typeData+  , typeFingerprint = DataFingerprint typeName []+  , typeContent   }  createScalarType :: Key -> (Key, DataType) createScalarType typeName =-  (typeName, DataScalar $ createType typeName (DataValidator pure))+  (typeName, createType typeName $ DataScalar (DataValidator pure))  createEnumType :: Key -> [Key] -> (Key, DataType) createEnumType typeName typeData =-  (typeName, DataEnum $ createType typeName enumValues)+  (typeName, createType typeName $ DataEnum enumValues)   where enumValues = map createEnumValue typeData  createEnumValue :: Key -> DataEnumValue@@ -409,58 +413,54 @@  createUnionType :: Key -> [Key] -> (Key, DataType) createUnionType typeName typeData =-  (typeName, DataUnion $ createType typeName typeData)-+  (typeName, createType typeName $ DataUnion typeData) -isEntNode :: DataType -> Bool-isEntNode DataScalar{} = True-isEntNode DataEnum{}   = True-isEntNode _            = False+isEntNode :: DataTypeContent -> Bool+isEntNode DataScalar{}  = True+isEntNode DataEnum{} = True+isEntNode _ = False  isInputDataType :: DataType -> Bool-isInputDataType DataScalar{}      = True-isInputDataType DataEnum{}        = True-isInputDataType DataInputObject{} = True-isInputDataType DataInputUnion{}  = True-isInputDataType _                 = False+isInputDataType DataType { typeContent } = __isInput typeContent+ where+  __isInput DataScalar{}      = True+  __isInput DataEnum{}        = True+  __isInput DataInputObject{} = True+  __isInput DataInputUnion{}  = True+  __isInput _                 = False -coerceDataObject :: Failure error m => error -> DataType -> m DataObject-coerceDataObject _        (DataObject object) = pure object-coerceDataObject gqlError _                   = failure gqlError+coerceDataObject :: Failure error m => error -> DataType -> m (Name,DataObject)+coerceDataObject _ DataType { typeContent = DataObject object , typeName } = pure (typeName,object)+coerceDataObject gqlError _ = failure gqlError  coerceDataUnion :: Failure error m => error -> DataType -> m DataUnion-coerceDataUnion _        (DataUnion object) = pure object-coerceDataUnion gqlError _                  = failure gqlError+coerceDataUnion _ DataType { typeContent = DataUnion members } = pure members+coerceDataUnion gqlError _ = failure gqlError  kindOf :: DataType -> DataTypeKind-kindOf (DataScalar      _) = KindScalar-kindOf (DataEnum        _) = KindEnum-kindOf (DataInputObject _) = KindInputObject-kindOf (DataObject      _) = KindObject Nothing-kindOf (DataUnion       _) = KindUnion-kindOf (DataInputUnion  _) = KindInputUnion+kindOf DataType { typeContent } = __kind typeContent+ where+  __kind (DataScalar      _) = KindScalar+  __kind (DataEnum        _) = KindEnum+  __kind (DataInputObject _) = KindInputObject+  __kind (DataObject      _) = KindObject Nothing+  __kind (DataUnion       _) = KindUnion+  __kind (DataInputUnion  _) = KindInputUnion -fromDataType :: (DataTyCon () -> v) -> DataType -> v-fromDataType f (DataScalar      dt) = f dt { typeData = () }-fromDataType f (DataEnum        dt) = f dt { typeData = () }-fromDataType f (DataUnion       dt) = f dt { typeData = () }-fromDataType f (DataInputObject dt) = f dt { typeData = () }-fromDataType f (DataInputUnion  dt) = f dt { typeData = () }-fromDataType f (DataObject      dt) = f dt { typeData = () }  -- -- Type Register -------------------------------------------------------------------------------------------------- data DataTypeLib = DataTypeLib   { types        :: HashMap Key DataType-  , query        :: (Key,  DataObject)-  , mutation     :: Maybe (Key, DataObject)-  , subscription :: Maybe (Key, DataObject)+  , query        :: (Name,DataType)+  , mutation     :: Maybe (Name, DataType)+  , subscription :: Maybe (Name, DataType)   } deriving (Show)  type TypeRegister = HashMap Key DataType -initTypeLib :: (Key, DataObject) -> DataTypeLib+initTypeLib :: (Key, DataType) -> DataTypeLib initTypeLib query = DataTypeLib { types        = empty                                 , query        = query                                 , mutation     = Nothing@@ -476,9 +476,9 @@   types `union` fromList     (concatMap fromOperation [Just query, mutation, subscription]) -fromOperation :: Maybe (Key, DataObject) -> [(Key, DataType)]-fromOperation (Just (key', dataType')) = [(key', DataObject dataType')]-fromOperation Nothing                  = []+fromOperation :: Maybe (Key, DataType) -> [(Key, DataType)]+fromOperation (Just (key, datatype)) = [(key, datatype)]+fromOperation Nothing = []  lookupDataType :: Key -> DataTypeLib -> Maybe DataType lookupDataType name lib = name `HM.lookup` typeRegister lib@@ -489,7 +489,7 @@   _      -> failure gqlError  lookupDataObject-  :: (Monad m, Failure e m) => e -> Key -> DataTypeLib -> m DataObject+  :: (Monad m, Failure e m) => e -> Key -> DataTypeLib -> m (Name,DataObject) lookupDataObject validationError name lib =   getDataType name lib validationError >>= coerceDataObject validationError @@ -504,11 +504,10 @@   -> Key   -> DataTypeLib   -> DataField-  -> m [DataObject]-lookupUnionTypes position key lib DataField { fieldType = TypeAlias { aliasTyCon = typeName } }+  -> m [(Name,DataObject)]+lookupUnionTypes position key lib DataField { fieldType = TypeRef { typeConName = typeName } }   = lookupDataUnion gqlError typeName lib     >>= mapM (flip (lookupDataObject gqlError) lib)-    .   typeData   where gqlError = hasNoSubfields key typeName position  lookupFieldAsSelectionSet@@ -517,10 +516,10 @@   -> Key   -> DataTypeLib   -> DataField-  -> m DataObject-lookupFieldAsSelectionSet position key lib DataField { fieldType = TypeAlias { aliasTyCon } }-  = lookupDataObject gqlError aliasTyCon lib-  where gqlError = hasNoSubfields key aliasTyCon position+  -> m (Name,DataObject)+lookupFieldAsSelectionSet position key lib DataField { fieldType = TypeRef { typeConName } }+  = lookupDataObject gqlError typeConName lib+  where gqlError = hasNoSubfields key typeConName position  lookupInputType :: Failure e m => Key -> DataTypeLib -> e -> m DataType lookupInputType name lib errors = case lookupDataType name lib of@@ -528,19 +527,19 @@   _                          -> failure errors  isTypeDefined :: Key -> DataTypeLib -> Maybe DataFingerprint-isTypeDefined name lib =-  fromDataType typeFingerprint <$> lookupDataType name lib+isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib  defineType :: (Key, DataType) -> DataTypeLib -> DataTypeLib-defineType (key, datatype@(DataInputUnion DataTyCon { typeName, typeData = enumKeys, typeFingerprint })) lib+defineType (key, datatype@DataType { typeName, typeContent = DataInputUnion enumKeys, typeFingerprint }) lib   = lib { types = insert name unionTags (insert key datatype (types lib)) }  where   name      = typeName <> "Tags"-  unionTags = DataEnum DataTyCon { typeName        = name-                                 , typeFingerprint-                                 , typeMeta        = Nothing-                                 , typeData = map createEnumValue enumKeys-                                 }+  unionTags = DataType+    { typeName        = name+    , typeFingerprint+    , typeMeta        = Nothing+    , typeContent     = DataEnum $ map (createEnumValue . fst) enumKeys+    } defineType (key, datatype) lib =   lib { types = insert key datatype (types lib) } @@ -560,33 +559,19 @@                                                        }           )   _ -> internalError "Query Not Defined"-  ------------------------------------------------------------------------------------------  where   takeByKey key lib = case lookup key lib of-    Just (DataObject value) -> (Just (key, value), filter ((/= key) . fst) lib)-    _                       -> (Nothing, lib)+    Just dt@DataType { typeContent = DataObject {} } ->+      (Just (key, dt), filter ((/= key) . fst) lib)+    _ -> (Nothing, lib)   createInputUnionFields :: Key -> [Key] -> [(Key, DataField)] createInputUnionFields name members = fieldTag : map unionField members  where   fieldTag =-    ( "tag"-    , DataField { fieldName     = "tag"+    ( "__typename"+    , DataField { fieldName     = "__typename"                 , fieldArgs     = []                 , fieldArgsType = Nothing                 , fieldType     = createAlias (name <> "Tags")@@ -599,17 +584,17 @@       { fieldArgs     = []       , fieldArgsType = Nothing       , fieldName     = memberName-      , fieldType     = TypeAlias { aliasTyCon    = memberName-                                  , aliasWrappers = [TypeMaybe]-                                  , aliasArgs     = Nothing+      , fieldType     = TypeRef { typeConName    = memberName+                                  , typeWrappers = [TypeMaybe]+                                  , typeArgs     = Nothing                                   }       , fieldMeta     = Nothing       }     ) -createAlias :: Key -> TypeAlias-createAlias aliasTyCon =-  TypeAlias { aliasTyCon, aliasWrappers = [], aliasArgs = Nothing }+createAlias :: Key -> TypeRef+createAlias typeConName =+  TypeRef { typeConName, typeWrappers = [], typeArgs = Nothing }   type TypeUpdater = LibUpdater DataTypeLib@@ -617,11 +602,10 @@ insertType :: (Key, DataType) -> TypeUpdater insertType nextType@(name, datatype) lib = case isTypeDefined name lib of   Nothing -> resolveUpdates (defineType nextType lib) []-  Just fingerprint-    | fingerprint == fromDataType typeFingerprint datatype -> return lib-    |+  Just fingerprint | fingerprint == typeFingerprint datatype -> return lib+                   |       -- throw error if 2 different types has same name-      otherwise -> failure $ nameCollisionError name+                     otherwise -> failure $ nameCollisionError name   -- TEMPLATE HASKELL DATA TYPES

@@ -1,88 +0,0 @@-{-# LANGUAGE DeriveLift         #-}-{-# LANGUAGE NamedFieldPuns     #-}-{-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE OverloadedStrings  #-}--module Data.Morpheus.Types.Internal.AST.Operation-  ( Operation(..)-  , Variable(..)-  , ValidOperation-  , RawOperation-  , VariableDefinitions-  , ValidVariables-  , DefaultValue-  , getOperationName-  , getOperationDataType-  )-where--import           Data.Maybe                     ( fromMaybe )-import           Language.Haskell.TH.Syntax     ( Lift(..) )---- MORPHEUS-import           Data.Morpheus.Error.Mutation   ( mutationIsNotDefined )-import           Data.Morpheus.Error.Subscription-                                                ( subscriptionIsNotDefined )-import           Data.Morpheus.Types.Internal.AST.Selection-                                                ( Arguments-                                                , SelectionSet-                                                , RawSelectionSet-                                                )--import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( Validation ,Failure(..) )-import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Collection-                                                , Key-                                                , Position-                                                )-import           Data.Morpheus.Types.Internal.AST.Data-                                                ( OperationType(..)-                                                , TypeWrapper-                                                , DataTypeLib(..)-                                                , DataObject-                                                )-import           Data.Morpheus.Types.Internal.AST.Value-                                                ( Value )--type DefaultValue = Maybe Value--type VariableDefinitions = Collection (Variable DefaultValue)--type ValidVariables = Collection (Variable Value)--type ValidOperation = Operation Arguments SelectionSet--type RawOperation = Operation VariableDefinitions RawSelectionSet--getOperationName :: Maybe Key -> Key-getOperationName = fromMaybe "AnonymousOperation"--data Operation args sel = Operation-  { operationName      :: Maybe Key-  , operationType      :: OperationType-  , operationArgs      :: args-  , operationSelection :: sel-  , operationPosition  :: Position-  } deriving (Show,Lift)--data Variable a = Variable-  { variableType         :: Key-  , isVariableRequired   :: Bool-  , variableTypeWrappers :: [TypeWrapper]-  , variablePosition     :: Position-  , variableValue        :: a-  } deriving (Show,Lift)--getOperationDataType :: Operation a b -> DataTypeLib -> Validation DataObject-getOperationDataType Operation { operationType = Query } lib =-  pure $ snd $ query lib-getOperationDataType Operation { operationType = Mutation, operationPosition } lib-  = case mutation lib of-    Just (_, mutation') -> pure mutation'-    Nothing             -> failure $ mutationIsNotDefined operationPosition-getOperationDataType Operation { operationType = Subscription, operationPosition } lib-  = case subscription lib of-    Just (_, subscription') -> pure subscription'-    Nothing                 -> failure $ subscriptionIsNotDefined operationPosition-

@@ -1,95 +1,179 @@-{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE DeriveLift         #-}+{-# LANGUAGE KindSignatures     #-}+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE FlexibleInstances  #-} + module Data.Morpheus.Types.Internal.AST.Selection   ( Argument(..)   , Arguments   , SelectionSet-  , SelectionRec(..)-  , ValueOrigin(..)+  , SelectionContent(..)   , ValidSelection   , Selection(..)-  , RawSelection'+  , RawSelection   , FragmentLib   , RawArguments   , RawSelectionSet   , Fragment(..)-  , RawArgument(..)-  , RawSelection(..)+  , RawArgument+  , ValidSelectionSet+  , ValidArgument+  , ValidArguments+  , RawSelectionRec+  , ValidSelectionRec+  , Operation(..)+  , Variable(..)+  , ValidOperation+  , RawOperation+  , VariableDefinitions+  , ValidVariables+  , DefaultValue+  , getOperationName+  , getOperationDataType+  , getOperationObject   ) where -import           Language.Haskell.TH.Syntax     ( Lift ) +import           Data.Maybe                     ( fromMaybe )+import           Data.Semigroup                 ( (<>) )+import           Language.Haskell.TH.Syntax     ( Lift(..) )  -- MORPHEUS+import           Data.Morpheus.Error.Mutation   ( mutationIsNotDefined )+import           Data.Morpheus.Error.Subscription+                                                ( subscriptionIsNotDefined ) import           Data.Morpheus.Types.Internal.AST.Base                                                 ( Collection                                                 , Key                                                 , Position                                                 , Ref(..)+                                                , Name+                                                , VALID+                                                , RAW+                                                , Stage                                                 )-+import           Data.Morpheus.Types.Internal.Resolving.Core+                                                ( Validation+                                                , Failure(..)+                                                )+import           Data.Morpheus.Types.Internal.AST.Data+                                                ( OperationType(..)+                                                , DataTypeLib(..)+                                                , DataType(..)+                                                , DataTypeContent(..)+                                                , DataObject+                                                ) import           Data.Morpheus.Types.Internal.AST.Value-                                                ( Value )+                                                ( Value+                                                , Variable(..)+                                                , ResolvedValue+                                                )  --- RAW SELECTION--type RawSelection' a = Selection RawArguments a+data Fragment = Fragment+  { fragmentType      :: Key+  , fragmentPosition  :: Position+  , fragmentSelection :: RawSelectionSet+  } deriving (Show,Lift)  type FragmentLib = [(Key, Fragment)] -type RawArguments = Collection RawArgument+data Argument (valid :: Stage) = Argument {+    argumentValue    :: Value valid+  , argumentPosition :: Position+  } deriving (Show,Lift) -type RawSelectionSet = Collection RawSelection+type RawArgument = Argument RAW -data Fragment = Fragment-  { fragmentType      :: Key-  , fragmentPosition  :: Position-  , fragmentSelection :: RawSelectionSet-  } deriving (Show, Lift)+type ValidArgument = Argument VALID -data RawArgument-  = VariableRef Ref-  | RawArgument Argument-  deriving (Show, Lift)+type Arguments a = Collection (Argument a) -data RawSelection-  = RawSelectionSet (RawSelection' RawSelectionSet)-  | RawSelectionField (RawSelection' ())-  | InlineFragment Fragment-  | Spread Ref-  deriving (Show,Lift)+type RawArguments = Arguments RAW --- VALID SELECTION -type Arguments = Collection Argument+type ValidArguments = Collection ValidArgument -type SelectionSet = Collection ValidSelection+data SelectionContent (valid :: Stage) where+  SelectionField ::SelectionContent valid+  SelectionSet   ::SelectionSet valid -> SelectionContent valid+  UnionSelection ::UnionSelection -> SelectionContent VALID -type ValidSelection = Selection Arguments SelectionRec+deriving instance Show (SelectionContent a)+deriving instance Lift (SelectionContent a) -type UnionSelection = Collection SelectionSet+type RawSelectionRec = SelectionContent RAW+type ValidSelectionRec = SelectionContent VALID+type UnionSelection = Collection (SelectionSet VALID)+type SelectionSet a = Collection (Selection a)+type RawSelectionSet = Collection RawSelection+type ValidSelectionSet = Collection ValidSelection -data ValueOrigin-  = VARIABLE-  | INLINE-  deriving (Show, Lift) -data Argument = Argument-  { argumentValue    :: Value-  , argumentOrigin   :: ValueOrigin-  , argumentPosition :: Position-  } deriving (Show, Lift)+data Selection (valid:: Stage) where+    Selection ::{+      selectionArguments :: Arguments valid+    , selectionPosition  :: Position+    , selectionAlias     :: Maybe Key+    , selectionContent   :: SelectionContent valid+    } -> Selection valid+    InlineFragment ::Fragment -> Selection RAW+    Spread ::Ref -> Selection RAW -data Selection args rec = Selection-  { selectionArguments :: args-  , selectionPosition  :: Position-  , selectionAlias     :: Maybe Key-  , selectionRec       :: rec+deriving instance Show (Selection a)+deriving instance Lift (Selection a)++type RawSelection = Selection RAW+type ValidSelection = Selection VALID++type DefaultValue = Maybe ResolvedValue++type VariableDefinitions = Collection (Variable RAW)++type ValidVariables = Collection (Variable VALID)++data Operation (stage:: Stage) = Operation+  { operationName      :: Maybe Key+  , operationType      :: OperationType+  , operationArguments :: Collection (Variable stage)+  , operationSelection :: SelectionSet stage+  , operationPosition  :: Position   } deriving (Show,Lift) -data SelectionRec-  = SelectionSet SelectionSet-  | UnionSelection UnionSelection-  | SelectionField-  deriving (Show)+type RawOperation = Operation RAW++type ValidOperation = Operation VALID+++getOperationName :: Maybe Key -> Key+getOperationName = fromMaybe "AnonymousOperation"++getOperationObject+  :: Operation a -> DataTypeLib -> Validation (Name, DataObject)+getOperationObject op lib = do+  dt <- getOperationDataType op lib+  case dt of+    DataType { typeContent = DataObject x, typeName } -> pure (typeName, x)+    DataType { typeName } ->+      failure+        $  "Type Mismatch: operation \""+        <> typeName+        <> "\" must be an Object"++getOperationDataType :: Operation a -> DataTypeLib -> Validation DataType+getOperationDataType Operation { operationType = Query } lib =+  pure $ snd $ query lib+getOperationDataType Operation { operationType = Mutation, operationPosition } lib+  = case mutation lib of+    Just (_, mutation') -> pure mutation'+    Nothing             -> failure $ mutationIsNotDefined operationPosition+getOperationDataType Operation { operationType = Subscription, operationPosition } lib+  = case subscription lib of+    Just (_, subscription') -> pure subscription'+    Nothing -> failure $ subscriptionIsNotDefined operationPosition+

@@ -1,8 +1,14 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveGeneric       #-} {-# LANGUAGE DeriveLift          #-} {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE TemplateHaskell     #-}  module Data.Morpheus.Types.Internal.AST.Value   ( Value(..)@@ -13,6 +19,14 @@   , decodeScientific   , convertToJSONName   , convertToHaskellName+  , RawValue+  , ValidValue+  , RawObject+  , ValidObject+  , Variable(..)+  , ResolvedValue+  , ResolvedObject+  , VariableContent(..)   ) where @@ -30,16 +44,31 @@                                                 , floatingOrInteger                                                 ) import           Data.Semigroup                 ( (<>) )-import           Data.Text                      ( Text )+import           Data.Text                      ( Text+                                                , unpack+                                                ) import qualified Data.Text                     as T import qualified Data.Vector                   as V                                                 ( toList ) import           GHC.Generics                   ( Generic ) import           Instances.TH.Lift              ( )-import           Language.Haskell.TH.Syntax     ( Lift )+import           Language.Haskell.TH.Syntax     ( Lift(..) ) +-- MORPHEUS+import           Data.Morpheus.Types.Internal.AST.Base+                                                ( Collection+                                                , Ref(..)+                                                , Name+                                                , RAW+                                                , VALID+                                                , Position+                                                , Stage+                                                , RESOLVED+                                                , TypeRef+                                                ) -isReserved :: Text -> Bool++isReserved :: Name -> Bool isReserved "case"     = True isReserved "class"    = True isReserved "data"     = True@@ -85,7 +114,6 @@   | Boolean Bool   deriving (Show, Generic,Lift) - instance A.ToJSON ScalarValue where   toJSON (Float   x) = A.toJSON x   toJSON (Int     x) = A.toJSON x@@ -98,22 +126,85 @@   parseJSON (A.String v) = pure $ String v   parseJSON notScalar    = fail $ "Expected Scalar got :" <> show notScalar +type family VAR (a:: Stage) :: Stage+type instance VAR RAW = RESOLVED+type instance VAR RESOLVED = RESOLVED+type instance VAR VALID = VALID -type Object = [(Text, Value)]+data VariableContent (stage:: Stage) where+  DefaultValue ::Maybe ResolvedValue -> VariableContent RESOLVED+  ValidVariableValue ::{ validVarContent::ValidValue }-> VariableContent VALID -data Value-  = Object Object-  | List [Value]-  | Enum Text-  | Scalar ScalarValue-  | Null-  deriving (Show, Generic,Lift)+instance Lift (VariableContent a) where+  lift (DefaultValue       x) = [| DefaultValue x |]+  lift (ValidVariableValue x) = [| ValidVariableValue x |] -instance A.ToJSON Value where+deriving instance Show (VariableContent a)++data Variable (stage :: Stage) = Variable+  { variableType         :: TypeRef+  , variablePosition     :: Position+  , variableValue        :: VariableContent (VAR stage)+  } deriving (Show,Lift)++data Value (valid :: Stage) where+  ResolvedVariable::Ref -> Variable VALID -> Value RESOLVED+  VariableValue ::Ref -> Value RAW+  Object  ::Object a -> Value a+  List ::[Value a] -> Value a+  Enum ::Name -> Value a+  Scalar ::ScalarValue -> Value a+  Null ::Value a+++type Object a = Collection (Value a)+type ValidObject = Object VALID+type RawObject = Object RAW+type ResolvedObject = Object RESOLVED+type RawValue = Value RAW+type ValidValue = Value VALID+type ResolvedValue = Value RESOLVED++deriving instance Lift (Value a)++instance Show (Value a) where+  show Null       = "null"+  show (Enum   x) = "" <> unpack x+  show (Scalar x) = show x+  show (ResolvedVariable Ref { refName } Variable { variableValue }) =+    "($" <> unpack refName <> ": " <> show variableValue <> ") "+  show (VariableValue Ref { refName }) = "$" <> unpack refName <> " "+  show (Object        keys           ) = "{" <> foldl toEntry "" keys <> "}"+   where+    toEntry :: String -> (Name, Value a) -> String+    toEntry ""  (key, value) = unpack key <> ":" <> show value+    toEntry txt (key, value) = txt <> ", " <> unpack key <> ":" <> show value+  show (List list) = "[" <> foldl toEntry "" list <> "]"+   where+    toEntry :: String -> Value a -> String+    toEntry ""  value = show value+    toEntry txt value = txt <> ", " <> show value++instance A.ToJSON (Value a) where+  toJSON (ResolvedVariable _ Variable { variableValue = ValidVariableValue x })+    = A.toJSON x+  toJSON (VariableValue Ref { refName }) =+    A.String $ "($ref:" <> refName <> ")"+  toJSON Null            = A.Null+  toJSON (Enum   x     ) = A.String x+  toJSON (Scalar x     ) = A.toJSON x+  toJSON (List   x     ) = A.toJSON x+  toJSON (Object fields) = A.object $ map toEntry fields+    where toEntry (name, value) = name A..= A.toJSON value+  -------------------------------------------+  toEncoding (ResolvedVariable _ Variable { variableValue = ValidVariableValue x })+    = A.toEncoding x+  toEncoding (VariableValue Ref { refName }) =+    A.toEncoding $ "($ref:" <> refName <> ")"   toEncoding Null        = A.toEncoding A.Null   toEncoding (Enum   x ) = A.toEncoding x-  toEncoding (List   x ) = A.toEncoding x   toEncoding (Scalar x ) = A.toEncoding x+  toEncoding (List   x ) = A.toEncoding x   toEncoding (Object []) = A.toEncoding $ A.object []   toEncoding (Object x ) = A.pairs $ foldl1 (<>) $ map encodeField x     where encodeField (key, value) = convertToJSONName key A..= value@@ -123,18 +214,18 @@   Left  float -> Float float   Right int   -> Int int -replaceValue :: A.Value -> Value+replaceValue :: A.Value -> Value a replaceValue (A.Bool   v) = gqlBoolean v replaceValue (A.Number v) = Scalar $ decodeScientific v replaceValue (A.String v) = gqlString v replaceValue (A.Object v) = gqlObject $ map replace (M.toList v)- where-  replace :: (a, A.Value) -> (a, Value)-  replace (key, val) = (key, replaceValue val)+  where+  --replace :: (a, A.Value) -> (a, Value a)+        replace (key, val) = (key, replaceValue val) replaceValue (A.Array li) = gqlList (map replaceValue (V.toList li)) replaceValue A.Null       = gqlNull -instance A.FromJSON Value where+instance A.FromJSON (Value a) where   parseJSON = pure . replaceValue  -- DEFAULT VALUES@@ -144,10 +235,10 @@   gqlBoolean :: Bool -> a   gqlString :: Text -> a   gqlList :: [a] -> a-  gqlObject :: [(Text, a)] -> a+  gqlObject :: [(Name, a)] -> a  -- build GQL Values for Subscription Resolver-instance GQLValue Value where+instance GQLValue (Value a) where   gqlNull    = Null   gqlScalar  = Scalar   gqlBoolean = Scalar . Boolean

@@ -27,6 +27,10 @@     , GQLErrors     , GQLError(..)     , Position+    , resolveEnum+    , resolve__typename+    , DataResolver(..)+    , FieldRes     ) where 

@@ -1,11 +1,12 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveFunctor      #-}-{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE DataKinds          #-}-{-# LANGUAGE PolyKinds          #-}-{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedStrings     #-}  module Data.Morpheus.Types.Internal.Resolving.Core   ( GQLError(..)@@ -84,6 +85,10 @@ instance Failure [error] (Result ev error con) where   failure = Failure +instance Failure Text Validation where+  failure text =+    Failure [GQLError { message = "INTERNAL ERROR: " <> text, locations = [] }]+ unpackEvents :: Result event c e a -> [event] unpackEvents Success { events } = events unpackEvents _                  = []@@ -137,20 +142,21 @@   => (ea -> eb)   -> ResultT ea er con m value   -> ResultT eb er con m value-mapEvent func (ResultT ma) = ResultT $ do-  state <- ma-  return $ state { events = map func (events state) }+mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma+ where+  mapEv Success { result, warnings, events } =+    Success { result, warnings, events = map func events }+  mapEv (Failure err) = Failure err  mapFailure   :: Monad m   => (er1 -> er2)   -> ResultT ev er1 con m value   -> ResultT ev er2 con m value-mapFailure f (ResultT ma) = ResultT $ do-  state <- ma-  case state of-    Failure x     -> pure $ Failure (map f x)-    Success x w e -> pure $ Success x (map f w) e+mapFailure f (ResultT ma) = ResultT $ mapF <$> ma+ where+  mapF (Failure x    ) = Failure (map f x)+  mapF (Success x w e) = Success x (map f w) e   -- Helper Functions

@@ -14,8 +14,7 @@ {-# LANGUAGE UndecidableInstances  #-}  module Data.Morpheus.Types.Internal.Resolving.Resolver-  ( -    Event(..)+  ( Event(..)   , GQLRootResolver(..)   , UnSubResolver   , Resolver(..)@@ -23,6 +22,7 @@   , MapStrategy(..)   , LiftEither(..)   , resolveObject+  , resolveEnum   , toResponseRes   , withObject   , resolving@@ -32,31 +32,41 @@   , GQLChannel(..)   , ResponseEvent(..)   , ResponseStream+  , resolve__typename+  , DataResolver(..)+  , FieldRes   ) where  import           Control.Monad.Trans.Class      ( MonadTrans(..) ) import           Data.Maybe                     ( fromMaybe )-import           Data.Semigroup                 ( (<>) )+import           Data.Semigroup                 ( (<>)+                                                , Semigroup(..)+                                                ) import           Data.Text                      ( unpack                                                 , pack                                                 )  -- MORPHEUS+import           Data.Morpheus.Error.Internal   ( internalResolvingError ) import           Data.Morpheus.Error.Selection  ( resolvingFailedError                                                 , subfieldsNotSelected                                                 ) import           Data.Morpheus.Types.Internal.AST.Selection                                                 ( Selection(..)-                                                , SelectionRec(..)-                                                , SelectionSet+                                                , SelectionContent(..)                                                 , ValidSelection+                                                , ValidSelectionRec+                                                , ValidSelectionSet+                                                , ValidSelection                                                 ) import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Message , Key )+                                                ( Message+                                                , Key+                                                , Name+                                                ) import           Data.Morpheus.Types.Internal.AST.Data-                                                ( -                                                  MUTATION+                                                ( MUTATION                                                 , OperationType                                                 , QUERY                                                 , SUBSCRIPTION@@ -77,9 +87,11 @@                                                 ) import           Data.Morpheus.Types.Internal.AST.Value                                                 ( GQLValue(..)-                                                , Value+                                                , ValidValue                                                 )-import           Data.Morpheus.Types.IO         (renderResponse, GQLResponse)+import           Data.Morpheus.Types.IO         ( renderResponse+                                                , GQLResponse+                                                ) -- MORPHEUS  class LiftEither (o::OperationType) res where@@ -152,35 +164,75 @@ instance (LiftEither o ResolvingStrategy, Monad m) => Failure GQLErrors (ResolvingStrategy o e m) where   failure = liftEither . pure . Left --- helper functins+-- DataResolver+data DataResolver o e m =+    EnumRes  Name+  | UnionRes  (Name,[FieldRes o e m])+  | ObjectRes  [FieldRes o e m ]+  | UnionRef (FieldRes o e m)+  | InvalidRes Name++instance Semigroup (DataResolver o e m) where+  ObjectRes x <> ObjectRes y = ObjectRes (x <> y)+  _           <> _           = InvalidRes "can't merge: incompatible resolvers"+ withObject   :: (LiftEither o ResolvingStrategy, Monad m)-  => (SelectionSet -> ResolvingStrategy o e m value)+  => (ValidSelectionSet -> ResolvingStrategy o e m value)   -> (Key, ValidSelection)   -> ResolvingStrategy o e m value-withObject f (_, Selection { selectionRec = SelectionSet selection }) =+withObject f (_, Selection { selectionContent = SelectionSet selection }) =   f selection withObject _ (key, Selection { selectionPosition }) =   failure (subfieldsNotSelected key "" selectionPosition)  resolveObject   :: (Monad m, LiftEither o ResolvingStrategy)-  => SelectionSet-  -> [FieldRes o e m]-  -> ResolvingStrategy o e m Value-resolveObject selectionSet fieldResolvers =+  => ValidSelectionSet+  -> DataResolver o e m+  -> ResolvingStrategy o e m ValidValue+resolveObject selectionSet (ObjectRes resolvers) =   gqlObject <$> traverse selectResolver selectionSet  where   selectResolver (key, selection@Selection { selectionAlias }) =     (fromMaybe key selectionAlias, ) <$> lookupRes selection    where     lookupRes sel =-      (fromMaybe (const $ pure gqlNull) $ lookup key fieldResolvers) (key, sel)+      (fromMaybe (const $ pure gqlNull) $ lookup key resolvers) (key, sel)+resolveObject _ _ =+  failure $ internalResolvingError "expected object as resolver" +resolveEnum+  :: (Monad m, LiftEither o ResolvingStrategy)+  => Name+  -> Name+  -> ValidSelectionRec+  -> ResolvingStrategy o e m ValidValue+resolveEnum _        enum SelectionField              = pure $ gqlString enum+resolveEnum typeName enum (UnionSelection selections) = resolveObject+  currentSelection+  resolvers+ where+  enumObjectTypeName = typeName <> "EnumObject"+  currentSelection   = fromMaybe [] $ lookup enumObjectTypeName selections+  resolvers          = ObjectRes+    [ ("enum", const $ pure $ gqlString enum)+    , resolve__typename enumObjectTypeName+    ]+resolveEnum _ _ _ =+  failure $ internalResolvingError "wrong selection on enum value"+++resolve__typename+  :: (Monad m, LiftEither o ResolvingStrategy)+  => Name+  -> (Key, (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue)+resolve__typename name = ("__typename", const $ pure $ gqlString name)+ toResponseRes   :: Monad m-  => ResolvingStrategy o event m Value-  -> ResponseStream event m Value+  => ResolvingStrategy o event m ValidValue+  -> ResponseStream event m ValidValue toResponseRes (ResolveQ resT) = cleanEvents resT toResponseRes (ResolveM resT) = mapEvent Publish resT toResponseRes (ResolveS resT) = ResultT $ handleActions <$> runResultT resT@@ -192,7 +244,8 @@     , events   = [Subscribe $ Event channels eventResolver]     }    where-    eventResolver event = renderResponse <$> runResultT  (unRecResolver subRes event) +    eventResolver event =+      renderResponse <$> runResultT (unRecResolver subRes event)  -- --     @@ -276,7 +329,7 @@  -- RESOLVING type FieldRes o e m-  = (Key, (Key, ValidSelection) -> ResolvingStrategy o e m Value)+  = (Key, (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue)  toResolver   :: (LiftEither o Resolver, Monad m)@@ -290,10 +343,10 @@ resolving   :: forall o e m value    . Monad m-  => (value -> (Key, ValidSelection) -> ResolvingStrategy o e m Value)+  => (value -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue)   -> Resolver o e m value   -> (Key, ValidSelection)-  -> ResolvingStrategy o e m Value+  -> ResolvingStrategy o e m ValidValue resolving encode gResolver selection@(fieldName, Selection { selectionPosition })   = _resolve gResolver  where@@ -322,17 +375,16 @@     , warnings = []     }    where-    eventResolver :: e -> StatelessResT m Value+    eventResolver :: e -> StatelessResT m ValidValue     eventResolver event =       convert (unQueryResolver $ res event) >>= unPureSub . _encode      where       unPureSub         :: Monad m-        => ResolvingStrategy SUBSCRIPTION e m Value-        -> StatelessResT m Value+        => ResolvingStrategy SUBSCRIPTION e m ValidValue+        -> StatelessResT m ValidValue       unPureSub (ResolveS x) = cleanEvents x >>= passEvent-       where-          passEvent (RecResolver f) = f event+        where passEvent (RecResolver f) = f event  -- map Resolving strategies  class MapStrategy (from :: OperationType) (to :: OperationType) where@@ -360,7 +412,7 @@ -- Channel  newtype Channel event = Channel {-  unChannel :: StreamChannel event+  _unChannel :: StreamChannel event }  instance (Eq (StreamChannel event)) => Eq (Channel event) where

@@ -20,10 +20,13 @@                                                 ( DataField(..)                                                 , DataType(..)                                                 , DataObject-                                                , DataTyCon(..)+                                                , DataTypeContent(..)+                                                , Name                                                 , Key                                                 , RawDataType(..)-                                                , TypeAlias(..)+                                                , TypeRef(..)+                                                , DataFingerprint(..)+                                                , Meta                                                 , isWeaker                                                 , isWeaker                                                 )@@ -37,29 +40,37 @@  where   validateType :: (Key, RawDataType) -> Validation (Maybe (Key, DataType))   validateType (name, FinalDataType x) = pure $ Just (name, x)-  validateType (name, Implements interfaces object) =-    asTuple name <$> object `mustImplement` interfaces+  validateType (name, Implements { implementsName, implementsInterfaces, implementsMeta, implementsContent })+    = asTuple name+      <$>             (implementsName, implementsMeta, implementsContent)+      `mustImplement` implementsInterfaces   validateType _ = pure Nothing   -----------------------------------   asTuple name x = Just (name, x)   ------------------------------------  mustImplement :: DataObject -> [Key] -> Validation DataType-  mustImplement object interfaceKey = do+  mustImplement :: (Name, Maybe Meta, DataObject) -> [Key] -> Validation DataType+  mustImplement (typeName, typeMeta, object) interfaceKey = do     interface <- traverse getInterfaceByKey interfaceKey     case concatMap (mustBeSubset object) interface of-      []     -> pure $ DataObject object-      errors -> failure $ partialImplements (typeName object) errors+      [] -> pure $ DataType { typeName+                            , typeFingerprint = DataFingerprint typeName []+                            , typeMeta+                            , typeContent     = DataObject object+                            }+      errors -> failure $ partialImplements typeName errors   --------------------------------  mustBeSubset :: DataObject -> DataObject -> [(Key, Key, ImplementsError)]-  mustBeSubset DataTyCon { typeData = objFields } DataTyCon { typeName, typeData = interfaceFields }-    = concatMap checkField interfaceFields+  mustBeSubset+    :: DataObject -> (Name, DataObject) -> [(Key, Key, ImplementsError)]+  mustBeSubset objFields (typeName, interfaceFields) = concatMap+    checkField+    interfaceFields    where     checkField :: (Key, DataField) -> [(Key, Key, ImplementsError)]-    checkField (key, DataField { fieldType = interfaceT@TypeAlias { aliasTyCon = interfaceTypeName, aliasWrappers = interfaceWrappers } })+    checkField (key, DataField { fieldType = interfaceT@TypeRef { typeConName = interfaceTypeName, typeWrappers = interfaceWrappers } })       = case lookup key objFields of-        Just DataField { fieldType = objT@TypeAlias { aliasTyCon, aliasWrappers } }-          | aliasTyCon == interfaceTypeName && not-            (isWeaker aliasWrappers interfaceWrappers)+        Just DataField { fieldType = objT@TypeRef { typeConName, typeWrappers } }+          | typeConName == interfaceTypeName && not+            (isWeaker typeWrappers interfaceWrappers)           -> []           | otherwise           -> [ ( typeName@@ -71,7 +82,7 @@              ]         Nothing -> [(typeName, key, UndefinedField)]   --------------------------------  getInterfaceByKey :: Key -> Validation DataObject+  getInterfaceByKey :: Key -> Validation (Name,DataObject)   getInterfaceByKey key = case lookup key lib of-    Just (Interface x) -> pure x-    _                  -> failure $ unknownInterface key+    Just Interface { interfaceContent } -> pure (key,interfaceContent)+    _ -> failure $ unknownInterface key

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-} @@ -10,104 +11,190 @@ import           Data.List                      ( elem )  -- MORPHEUS+import           Data.Morpheus.Error.Variable   ( incompatibleVariableType ) import           Data.Morpheus.Error.Input      ( InputError(..)                                                 , InputValidation                                                 , Prop(..)                                                 )-import           Data.Morpheus.Rendering.RenderGQL-                                                ( renderWrapped ) import           Data.Morpheus.Types.Internal.AST                                                 ( DataField(..)-                                                , DataTyCon(..)+                                                , DataTypeContent(..)                                                 , DataType(..)                                                 , DataTypeLib(..)                                                 , DataValidator(..)                                                 , Key-                                                , TypeAlias(..)+                                                , TypeRef(..)                                                 , TypeWrapper(..)                                                 , DataEnumValue(..)-                                                , isNullable                                                 , lookupField                                                 , lookupInputType                                                 , Value(..)+                                                , ValidValue+                                                , Variable(..)+                                                , Ref(..)+                                                , isWeaker+                                                , DataScalar+                                                , Message+                                                , Name+                                                , ResolvedValue+                                                , VALID+                                                , VariableContent(..)+                                                , unpackInputUnion+                                                , isFieldNullable+                                                , TypeRef(..)+                                                , isNullableWrapper                                                 )  import           Data.Morpheus.Types.Internal.Resolving                                                 ( Failure(..) )+import           Data.Morpheus.Rendering.RenderGQL+                                                ( RenderGQL(..) ) +checkTypeEquality+  :: (Name, [TypeWrapper])+  -> Ref+  -> Variable VALID+  -> InputValidation ValidValue+checkTypeEquality (tyConName, tyWrappers) Ref { refName, refPosition } Variable { variableValue = ValidVariableValue value, variableType }+  | typeConName variableType == tyConName && not+    (isWeaker (typeWrappers variableType) tyWrappers)+  = pure value+  | otherwise+  = failure $ GlobalInputError $ incompatibleVariableType refName+                                                          varSignature+                                                          fieldSignature+                                                          refPosition+ where+  varSignature   = render variableType+  fieldSignature = render TypeRef { typeConName  = tyConName+                                  , typeWrappers = tyWrappers+                                  , typeArgs     = Nothing+                                  }+++ -- Validate Variable Argument or all Possible input Values validateInputValue   :: DataTypeLib   -> [Prop]   -> [TypeWrapper]   -> DataType-  -> (Key, Value)-  -> InputValidation Value-validateInputValue lib prop' = validate+  -> (Key, ResolvedValue)+  -> InputValidation ValidValue+validateInputValue lib props rw datatype@DataType { typeContent, typeName } =+  validateWrapped rw typeContent  where-  throwError :: [TypeWrapper] -> DataType -> Value -> InputValidation Value-  throwError wrappers datatype value =-    Left $ UnexpectedType prop' (renderWrapped datatype wrappers) value Nothing+  throwError :: [TypeWrapper] -> ResolvedValue -> InputValidation ValidValue+  throwError wrappers value =+    Left $ UnexpectedType props (renderWrapped datatype wrappers) value Nothing   -- VALIDATION-  validate :: [TypeWrapper] -> DataType -> (Key, Value) -> InputValidation Value+  validateWrapped+    :: [TypeWrapper]+    -> DataTypeContent+    -> (Key, ResolvedValue)+    -> InputValidation ValidValue   -- Validate Null. value = null ?-  validate wrappers tName (_, Null) | isNullable wrappers = return Null-                                    | otherwise = throwError wrappers tName Null+  validateWrapped wrappers _ (_, ResolvedVariable ref variable) =+    checkTypeEquality (typeName, wrappers) ref variable+  validateWrapped wrappers _ (_, Null)+    | isNullableWrapper wrappers = return Null+    | otherwise                  = throwError wrappers Null   -- Validate LIST-  validate (TypeMaybe : wrappers) type' value' =-    validateInputValue lib prop' wrappers type' value'-  validate (TypeList : wrappers) type' (key', List list') =-    List <$> mapM validateElement list'+  validateWrapped (TypeMaybe : wrappers) _ value =+    validateInputValue lib props wrappers datatype value+  validateWrapped (TypeList : wrappers) _ (key, List list) =+    List <$> mapM validateElement list    where-    validateElement element' =-      validateInputValue lib prop' wrappers type' (key', element')+    validateElement element =+      validateInputValue lib props wrappers datatype (key, element)   {-- 2. VALIDATE TYPES, all wrappers are already Processed --}   {-- VALIDATE OBJECT--}-  validate [] (DataInputObject DataTyCon { typeData = parentFields' }) (_, Object fields)-    = Object <$> mapM validateField fields+  validateWrapped [] dt v = validate dt v    where-    validateField (_name, value) = do-      (type', currentProp') <- validationData value-      wrappers'             <- aliasWrappers . fieldType <$> getField-      value''               <- validateInputValue lib-                                                  currentProp'-                                                  wrappers'-                                                  type'-                                                  (_name, value)-      return (_name, value'')+    validate+      :: DataTypeContent -> (Key, ResolvedValue) -> InputValidation ValidValue+    validate (DataInputObject parentFields) (_, Object fields) =+      traverse requiredFieldsDefined parentFields+        >>  Object+        <$> traverse validateField fields      where-      validationData x = do-        fieldTypeName' <- aliasTyCon . fieldType <$> getField-        let currentProp = prop' ++ [Prop _name fieldTypeName']-        type' <- lookupInputType fieldTypeName'-                                 lib-                                 (typeMismatch x fieldTypeName' currentProp)-        return (type', currentProp)-      getField = lookupField _name parentFields' (UnknownField prop' _name)-  -- VALIDATE INPUT UNION-  -- TODO: Validate Union-  validate [] (DataInputUnion DataTyCon { typeData }) (_, Object fields) =-    return (Object fields)-  {-- VALIDATE SCALAR --}-  validate [] (DataEnum DataTyCon { typeData = tags, typeName = name' }) (_, value')-    = validateEnum (UnexpectedType prop' name' value' Nothing) tags value'-  {-- VALIDATE ENUM --}-  validate [] (DataScalar DataTyCon { typeName = name', typeData = DataValidator { validateValue = validator' } }) (_, value')-    = case validator' value' of-      Right _  -> return value'-      Left  "" -> failure (UnexpectedType prop' name' value' Nothing)-      Left errorMessage ->-        Left $ UnexpectedType prop' name' value' (Just errorMessage)-  {-- 3. THROW ERROR: on invalid values --}-  validate wrappers datatype (_, value) = throwError wrappers datatype value+      requiredFieldsDefined (fName, datafield)+        | fName `elem` map fst fields || isFieldNullable datafield = pure ()+        | otherwise = failure (UndefinedField props fName)+      validateField+        :: (Name, ResolvedValue) -> InputValidation (Name, ValidValue)+      validateField (_name, value) = do+        (type', currentProp') <- validationData value+        wrappers'             <- typeWrappers . fieldType <$> getField+        value''               <- validateInputValue lib+                                                    currentProp'+                                                    wrappers'+                                                    type'+                                                    (_name, value)+        return (_name, value'')+       where+        validationData :: ResolvedValue -> InputValidation (DataType, [Prop])+        validationData x = do+          fieldTypeName' <- typeConName . fieldType <$> getField+          let currentProp = props ++ [Prop _name fieldTypeName']+          type' <- lookupInputType fieldTypeName'+                                   lib+                                   (typeMismatch x fieldTypeName' currentProp)+          return (type', currentProp)+        getField = lookupField _name parentFields (UnknownField props _name)+    -- VALIDATE INPUT UNION+    validate (DataInputUnion inputUnion) (_, Object rawFields) =+      case unpackInputUnion inputUnion rawFields of+        Left message -> failure+          $ UnexpectedType props typeName (Object rawFields) (Just message)+        Right (name, Nothing   ) -> return (Object [("__typename", Enum name)])+        Right (name, Just value) -> do+          currentUnionDatatype <- lookupInputType+            name+            lib+            (typeMismatch value name props)+          validValue <- validateInputValue lib+                                           props+                                           [TypeMaybe]+                                           currentUnionDatatype+                                           (name, value)+          return (Object [("__typename", Enum name), (name, validValue)]) -validateEnum :: error -> [DataEnumValue] -> Value -> Either error Value+    {-- VALIDATE ENUM --}+    validate (DataEnum tags) (_, value) =+      validateEnum (UnexpectedType props typeName value Nothing) tags value+    {-- VALIDATE SCALAR --}+    validate (DataScalar dataScalar) (_, value) =+      validateScalar dataScalar value (UnexpectedType props typeName)+    validate _ (_, value) = throwError [] value+    {-- 3. THROW ERROR: on invalid values --}+  validateWrapped wrappers _ (_, value) = throwError wrappers value+++validateScalar+  :: DataScalar+  -> ResolvedValue+  -> (ResolvedValue -> Maybe Message -> InputError)+  -> InputValidation ValidValue+validateScalar DataValidator { validateValue } value err = do+  scalarValue <- toScalar value+  case validateValue scalarValue of+    Right _            -> return scalarValue+    Left  ""           -> failure (err value Nothing)+    Left  errorMessage -> failure $ err value (Just errorMessage)+ where+  toScalar :: ResolvedValue -> InputValidation ValidValue+  toScalar (Scalar x) = pure (Scalar x)+  toScalar scValue    = Left (err scValue Nothing)++validateEnum+  :: error -> [DataEnumValue] -> ResolvedValue -> Either error ValidValue validateEnum gqlError enumValues (Enum enumValue)   | enumValue `elem` tags = pure (Enum enumValue)   | otherwise             = Left gqlError   where tags = map enumName enumValues validateEnum gqlError _ _ = Left gqlError -typeMismatch :: Value -> Key -> [Prop] -> InputError+typeMismatch :: ResolvedValue -> Key -> [Prop] -> InputError typeMismatch jsType expected' path' =   UnexpectedType path' expected' jsType Nothing

@@ -1,11 +1,13 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TupleSections  #-}  module Data.Morpheus.Validation.Query.Arguments   ( validateArguments   ) where +import           Data.Maybe                     ( maybe ) import           Data.Morpheus.Error.Arguments  ( argumentGotInvalidValue                                                 , argumentNameCollision                                                 , undefinedArgument@@ -15,29 +17,30 @@                                                 , inputErrorMessage                                                 ) import           Data.Morpheus.Error.Internal   ( internalUnknownTypeMessage )-import           Data.Morpheus.Error.Variable   ( incompatibleVariableType-                                                , undefinedVariable-                                                )-import           Data.Morpheus.Rendering.RenderGQL-                                                ( RenderGQL(..) )+import           Data.Morpheus.Error.Variable   ( undefinedVariable ) import           Data.Morpheus.Types.Internal.AST                                                 ( ValidVariables                                                 , Variable(..)                                                 , Argument(..)-                                                , ValueOrigin(..)-                                                , Arguments-                                                , RawArgument(..)+                                                , RawArgument                                                 , RawArguments+                                                , ValidArgument+                                                , ValidArguments+                                                , Arguments                                                 , Ref(..)                                                 , Position                                                 , DataArgument                                                 , DataField(..)                                                 , DataTypeLib-                                                , TypeAlias(..)+                                                , TypeRef(..)                                                 , isFieldNullable-                                                , isWeaker                                                 , lookupInputType-                                                , Value(Null)+                                                , Value(..)+                                                , Name+                                                , RawValue+                                                , ResolvedValue+                                                , RESOLVED+                                                , VALID                                                 ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( Validation@@ -51,74 +54,86 @@                                                 ( validateInputValue ) import           Data.Text                      ( Text ) +-- only Resolves , doesnot checks the types+resolveObject :: Name -> ValidVariables -> RawValue -> Validation ResolvedValue+resolveObject operationName variables = resolve+ where+  resolve :: RawValue -> Validation ResolvedValue+  resolve Null         = pure Null+  resolve (Scalar x  ) = pure $ Scalar x+  resolve (Enum   x  ) = pure $ Enum x+  resolve (List   x  ) = List <$> traverse resolve x+  resolve (Object obj) = Object <$> traverse mapSecond obj+    where mapSecond (fName, y) = (fName, ) <$> resolve y+  resolve (VariableValue ref) =+    ResolvedVariable ref <$> variableByRef operationName variables ref+    --  >>= checkTypeEquality ref fieldType+  -- RAW | RESOLVED | Valid ++variableByRef :: Name -> ValidVariables -> Ref -> Validation (Variable VALID)+variableByRef operationName variables Ref { refName, refPosition } = maybe+  variableError+  pure+  (lookup refName variables)+ where+  variableError = failure $ undefinedVariable operationName refPosition refName+++ resolveArgumentVariables-  :: Text -> ValidVariables -> DataField -> RawArguments -> Validation Arguments-resolveArgumentVariables operatorName variables DataField { fieldName, fieldArgs }+  :: Name+  -> ValidVariables+  -> DataField+  -> RawArguments+  -> Validation (Arguments RESOLVED)+resolveArgumentVariables operationName variables DataField { fieldName, fieldArgs }   = mapM resolveVariable  where-  resolveVariable :: (Text, RawArgument) -> Validation (Text, Argument)-  resolveVariable (key, RawArgument argument) = pure (key, argument)-  resolveVariable (key, VariableRef Ref { refName, refPosition }) =-    (key, ) . toArgument <$> lookupVar-   where-    toArgument argumentValue = Argument { argumentValue-                                        , argumentOrigin   = VARIABLE-                                        , argumentPosition = refPosition-                                        }-    lookupVar = case lookup refName variables of-      Nothing -> failure $ undefinedVariable operatorName refPosition refName-      Just Variable { variableValue, variableType, variableTypeWrappers } ->-        case lookup key fieldArgs of-          Nothing -> failure $ unknownArguments fieldName [Ref key refPosition]-          Just DataField { fieldType = fieldT@TypeAlias { aliasTyCon, aliasWrappers } }-            -> if variableType == aliasTyCon && not-                 (isWeaker variableTypeWrappers aliasWrappers)-              then return variableValue-              else failure $ incompatibleVariableType refName-                                                      varSignature-                                                      fieldSignature-                                                      refPosition-           where-            varSignature   = renderWrapped variableType variableTypeWrappers-            fieldSignature = render fieldT+  resolveVariable :: (Text, RawArgument) -> Validation (Text, Argument RESOLVED)+  resolveVariable (key, Argument val position) = case lookup key fieldArgs of+    Nothing -> failure $ unknownArguments fieldName [Ref key position]+    Just _  -> do+      constValue <- resolveObject operationName variables val+      pure (key, Argument constValue position)  validateArgument   :: DataTypeLib   -> Position-  -> Arguments+  -> Arguments RESOLVED   -> (Text, DataArgument)-  -> Validation (Text, Argument)-validateArgument lib fieldPosition requestArgs (key, argType@DataField { fieldType = TypeAlias { aliasTyCon, aliasWrappers } })+  -> Validation (Text, ValidArgument)+validateArgument lib fieldPosition requestArgs (key, argType@DataField { fieldType = TypeRef { typeConName, typeWrappers } })   = case lookup key requestArgs of     Nothing -> handleNullable-    Just argument@Argument { argumentOrigin = VARIABLE } ->-      pure (key, argument) -- Variables are already checked in Variable Validation+    -- TODO: move it in value validation+   -- Just argument@Argument { argumentOrigin = VARIABLE } ->+   --   pure (key, argument) -- Variables are already checked in Variable Validation     Just Argument { argumentValue = Null } -> handleNullable-    Just argument                          -> validateArgumentValue argument+    Just argument -> validateArgumentValue argument  where   handleNullable-    | isFieldNullable argType = pure-      ( key-      , Argument { argumentValue    = Null-                 , argumentOrigin   = INLINE-                 , argumentPosition = fieldPosition-                 }-      )-    | otherwise = failure $ undefinedArgument (Ref key fieldPosition)+    | isFieldNullable argType+    = pure+      (key, Argument { argumentValue = Null, argumentPosition = fieldPosition })+    | otherwise+    = failure $ undefinedArgument (Ref key fieldPosition)   --------------------------------------------------------------------------  validateArgumentValue :: Argument -> Validation (Text, Argument)-  validateArgumentValue arg@Argument { argumentValue, argumentPosition } =-    lookupInputType aliasTyCon lib (internalUnknownTypeMessage aliasTyCon)-      >>= checkType-      >>  pure (key, arg)+  validateArgumentValue :: Argument RESOLVED -> Validation (Text, ValidArgument)+  validateArgumentValue Argument { argumentValue = value, argumentPosition } =+    do+      datatype <- lookupInputType typeConName+                                  lib+                                  (internalUnknownTypeMessage typeConName)+      argumentValue <- handleInputError+        $ validateInputValue lib [] typeWrappers datatype (key, value)+      pure (key, Argument { argumentValue, argumentPosition })    where-    checkType type' = handleInputError-      (validateInputValue lib [] aliasWrappers type' (key, argumentValue))     ----------    handleInputError :: InputValidation a -> Validation ()-    handleInputError (Left err) = failure-      $ argumentGotInvalidValue key (inputErrorMessage err) argumentPosition-    handleInputError _ = pure ()+    handleInputError :: InputValidation a -> Validation a+    handleInputError (Left err) = failure $ case inputErrorMessage err of+      Left  errors  -> errors+      Right message -> argumentGotInvalidValue key message argumentPosition+    handleInputError (Right x) = pure x  validateArguments   :: DataTypeLib@@ -127,14 +142,15 @@   -> (Text, DataField)   -> Position   -> RawArguments-  -> Validation Arguments+  -> Validation ValidArguments validateArguments typeLib operatorName variables (key, field@DataField { fieldArgs }) pos rawArgs   = do     args     <- resolveArgumentVariables operatorName variables field rawArgs     dataArgs <- checkForUnknownArguments args     mapM (validateArgument typeLib pos args) dataArgs  where-  checkForUnknownArguments :: Arguments -> Validation [(Text, DataField)]+  checkForUnknownArguments+    :: Arguments RESOLVED -> Validation [(Text, DataField)]   checkForUnknownArguments args =     checkForUnknownKeys enhancedKeys fieldKeys argError       >> checkNameCollision enhancedKeys argumentNameCollision@@ -142,5 +158,6 @@    where     argError     = unknownArguments key     enhancedKeys = map argToKey args+    argToKey :: (Name, Argument RESOLVED) -> Ref     argToKey (key', Argument { argumentPosition }) = Ref key' argumentPosition     fieldKeys = map fst fieldArgs

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -12,8 +13,6 @@ import           Data.List                      ( (\\) ) import           Data.Semigroup                 ( (<>) ) import           Data.Text                      ( Text )-import qualified Data.Text                     as T-                                                ( concat )  -- MORPHEUS import           Data.Morpheus.Error.Fragment   ( cannotBeSpreadOnType@@ -26,7 +25,8 @@ import           Data.Morpheus.Types.Internal.AST                                                 ( Fragment(..)                                                 , FragmentLib-                                                , RawSelection(..)+                                                , RawSelection+                                                , SelectionContent(..)                                                 , Selection(..)                                                 , Ref(..)                                                 , Position@@ -69,11 +69,10 @@  castFragmentType   :: Maybe Text -> Position -> [Text] -> Fragment -> Validation Fragment-castFragmentType key' position' targets' fragment@Fragment { fragmentType } =-  if fragmentType `elem` targets'+castFragmentType key' position' typeMembers fragment@Fragment { fragmentType }+  = if fragmentType `elem` typeMembers     then pure fragment-    else failure-      $ cannotBeSpreadOnType key' fragmentType position' (T.concat targets')+    else failure $ cannotBeSpreadOnType key' fragmentType position' typeMembers  resolveSpread :: FragmentLib -> [Text] -> Ref -> Validation Fragment resolveSpread fragments allowedTargets reference@Ref { refName, refPosition } =@@ -81,27 +80,28 @@     >>= castFragmentType (Just refName) refPosition allowedTargets  usedFragments :: FragmentLib -> [(Text, RawSelection)] -> [Node]-usedFragments fragments = concatMap findAllUses+usedFragments fragments = concatMap (findAllUses . snd)  where-  findAllUses :: (Text, RawSelection) -> [Node]-  findAllUses (_, RawSelectionSet Selection { selectionRec }) =-    concatMap findAllUses selectionRec-  findAllUses (_, InlineFragment Fragment { fragmentSelection }) =-    concatMap findAllUses fragmentSelection-  findAllUses (_, RawSelectionField{}) = []-  findAllUses (_, Spread Ref { refName, refPosition }) =+  findAllUses :: RawSelection -> [Node]+  findAllUses Selection { selectionContent = SelectionField } = []+  findAllUses Selection { selectionContent = SelectionSet selectionSet } =+    concatMap (findAllUses . snd) selectionSet+  findAllUses (InlineFragment Fragment { fragmentSelection }) =+    concatMap (findAllUses . snd) fragmentSelection+  findAllUses (Spread Ref { refName, refPosition }) =     [Ref refName refPosition] <> searchInFragment    where-    searchInFragment = maybe []-                             (concatMap findAllUses . fragmentSelection)-                             (lookup refName fragments)+    searchInFragment = maybe+      []+      (concatMap (findAllUses . snd) . fragmentSelection)+      (lookup refName fragments)  scanForSpread :: (Text, RawSelection) -> [Node]-scanForSpread (_, RawSelectionSet Selection { selectionRec }) =-  concatMap scanForSpread selectionRec+scanForSpread (_, Selection { selectionContent = SelectionField }) = []+scanForSpread (_, Selection { selectionContent = SelectionSet selectionSet }) =+  concatMap scanForSpread selectionSet scanForSpread (_, InlineFragment Fragment { fragmentSelection = selection' }) =   concatMap scanForSpread selection'-scanForSpread (_, RawSelectionField{}) = [] scanForSpread (_, Spread Ref { refName = name', refPosition = position' }) =   [Ref name' position'] 

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE NamedFieldPuns      #-}@@ -22,21 +23,23 @@                                                 ) import           Data.Morpheus.Error.Variable   ( unknownType ) import           Data.Morpheus.Types.Internal.AST-                                                ( ValidVariables +                                                ( ValidVariables                                                 , Selection(..)-                                                , SelectionRec(..)-                                                , SelectionSet+                                                , SelectionContent(..)+                                                , ValidSelection+                                                , ValidSelectionSet                                                 , Fragment(..)                                                 , FragmentLib-                                                , RawSelection(..)+                                                , RawSelection                                                 , RawSelectionSet                                                 , DataField(..)                                                 , Ref(..)                                                 , DataObject-                                                , DataTyCon(..)+                                                , DataTypeContent(..)                                                 , DataType(..)                                                 , DataTypeLib(..)-                                                , TypeAlias(..)+                                                , TypeRef(..)+                                                , Name                                                 , allDataTypes                                                 , isEntNode                                                 , lookupFieldAsSelectionSet@@ -57,51 +60,52 @@                                                 , resolveSpread                                                 ) -checkDuplicatesOn :: DataObject -> SelectionSet -> Validation SelectionSet-checkDuplicatesOn DataTyCon { typeName = name' } keys =-  checkNameCollision enhancedKeys selError >> pure keys+checkDuplicatesOn :: Name -> ValidSelectionSet -> Validation ValidSelectionSet+checkDuplicatesOn typeName keys = checkNameCollision enhancedKeys selError+  >> pure keys  where-  selError     = duplicateQuerySelections name'+  selError     = duplicateQuerySelections typeName   enhancedKeys = map selToKey keys+  selToKey :: (Name, ValidSelection) -> Ref   selToKey (key, Selection { selectionPosition = position', selectionAlias }) =     Ref (fromMaybe key selectionAlias) position'  clusterUnionSelection   :: FragmentLib   -> Text-  -> [DataObject]+  -> [Name]   -> (Text, RawSelection)-  -> Validation ([Fragment], SelectionSet)-clusterUnionSelection fragments type' possibleTypes' = splitFrag+  -> Validation ([Fragment], ValidSelectionSet)+clusterUnionSelection fragments type' typeNames = splitFrag  where   packFragment fragment = return ([fragment], [])-  typeNames = map typeName possibleTypes'-  splitFrag :: (Text, RawSelection) -> Validation ([Fragment], SelectionSet)+  splitFrag+    :: (Text, RawSelection) -> Validation ([Fragment], ValidSelectionSet)   splitFrag (_, Spread ref) =     resolveSpread fragments typeNames ref >>= packFragment-  splitFrag ("__typename", RawSelectionField selection) = pure-    ( []-    , [ ( "__typename"-        , selection { selectionArguments = [], selectionRec = SelectionField }-        )-      ]-    )-  splitFrag (key, RawSelectionSet Selection { selectionPosition }) =-    failure $ cannotQueryField key type' selectionPosition-  splitFrag (key, RawSelectionField Selection { selectionPosition }) =+  splitFrag ("__typename", selection@Selection { selectionContent = SelectionField })+    = pure+      ( []+      , [ ( "__typename"+          , selection { selectionArguments = [], selectionContent = SelectionField }+          )+        ]+      )+  splitFrag (key, Selection { selectionPosition }) =     failure $ cannotQueryField key type' selectionPosition --  splitFrag (key', RawAlias {rawAliasPosition = position'}) = failure $ cannotQueryField key' type' position'   splitFrag (_, InlineFragment fragment') =     castFragmentType Nothing (fragmentPosition fragment') typeNames fragment'       >>= packFragment -categorizeTypes :: [DataObject] -> [Fragment] -> [(DataObject, [Fragment])]+categorizeTypes+  :: [(Name, DataObject)] -> [Fragment] -> [((Name, DataObject), [Fragment])] categorizeTypes types fragments = filter notEmpty $ map categorizeType types  where   notEmpty = (0 /=) . length . snd-  categorizeType :: DataObject -> (DataObject, [Fragment])+  categorizeType :: (Name, DataObject) -> ((Name, DataObject), [Fragment])   categorizeType datatype = (datatype, filter matches fragments)-    where matches fragment = fragmentType fragment == typeName datatype+    where matches fragment = fragmentType fragment == fst datatype  flatTuple :: [([a], [b])] -> ([a], [b]) flatTuple list' = (concatMap fst list', concatMap snd list')@@ -122,45 +126,51 @@   -> FragmentLib   -> Text   -> ValidVariables-  -> DataObject+  -> (Name, DataObject)   -> RawSelectionSet-  -> Validation SelectionSet+  -> Validation ValidSelectionSet validateSelectionSet lib fragments' operatorName variables = __validate  where-  __validate dataType'@DataTyCon { typeName = typeName' } selectionSet' =+  __validate+    :: (Name, DataObject) -> RawSelectionSet -> Validation ValidSelectionSet+  __validate dataType@(typeName, objectFields) selectionSet =     concat-      <$> mapM validateSelection selectionSet'-      >>= checkDuplicatesOn dataType'+    <$> mapM validateSelection selectionSet+    >>= checkDuplicatesOn typeName    where     validateFragment Fragment { fragmentSelection = selection' } =-      __validate dataType' selection'+      __validate dataType selection'     {-             get dataField and validated arguments for RawSelection         -}-    getValidationData key Selection { selectionArguments, selectionPosition } =-      do-        selectionField <- lookupSelectionField selectionPosition key dataType'-        -- validate field Argument ------        arguments      <- validateArguments lib-                                            operatorName-                                            variables-                                            (key, selectionField)-                                            selectionPosition-                                            selectionArguments-        -- check field Type existence  ------        fieldDataType <- lookupType-          (unknownType (aliasTyCon $fieldType selectionField) selectionPosition)-          (allDataTypes lib)-          (aliasTyCon $ fieldType selectionField)-        return (selectionField, fieldDataType, arguments)+    -- getValidationData :: Name -> ValidSelection -> (DataField, DataTypeContent, ValidArguments)+    getValidationData key (selectionArguments, selectionPosition) = do+      selectionField <- lookupSelectionField selectionPosition+                                             key+                                             typeName+                                             objectFields+      -- validate field Argument -----+      arguments <- validateArguments lib+                                     operatorName+                                     variables+                                     (key, selectionField)+                                     selectionPosition+                                     selectionArguments+      -- check field Type existence  -----+      fieldDataType <- lookupType+        (unknownType (typeConName $fieldType selectionField) selectionPosition)+        (allDataTypes lib)+        (typeConName $ fieldType selectionField)+      return (selectionField, fieldDataType, arguments)     -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet     ---    validateSelection :: (Text, RawSelection) -> Validation SelectionSet-    validateSelection (key', RawSelectionSet fullRawSelection@Selection { selectionRec = rawSelection, selectionPosition })+    validateSelection :: (Text, RawSelection) -> Validation ValidSelectionSet+    validateSelection (key', fullRawSelection@Selection { selectionArguments = selArgs, selectionContent = SelectionSet rawSelection, selectionPosition })       = do-        (dataField, dataType, arguments) <- getValidationData key'-                                                              fullRawSelection-        case dataType of+        (dataField, datatype, arguments) <- getValidationData+          key'+          (selArgs, selectionPosition)+        case typeContent datatype of           DataUnion _ -> do             (categories, __typename) <- clusterTypes             mapM (validateCluster __typename) categories@@ -175,19 +185,22 @@               (spreads, __typename) <-                 flatTuple                   <$> mapM-                        (clusterUnionSelection fragments' typeName' unionTypes)+                        (   clusterUnionSelection fragments' typeName+                        $   fst+                        <$> unionTypes+                        )                         rawSelection               return (categorizeTypes unionTypes spreads, __typename)             --             --    second arguments will be added to every selection cluster             validateCluster-              :: SelectionSet-              -> (DataObject, [Fragment])-              -> Validation (Text, SelectionSet)+              :: ValidSelectionSet+              -> ((Name, DataObject), [Fragment])+              -> Validation (Text, ValidSelectionSet)             validateCluster sysSelection' (type', frags') = do               selection' <- __validate type'                                        (concatMap fragmentSelection frags')-              return (typeName type', sysSelection' ++ selection')+              return (fst type', sysSelection' ++ selection')           DataObject _ -> do             fieldType' <- lookupFieldAsSelectionSet selectionPosition                                                     key'@@ -197,32 +210,29 @@               >>= returnSelection arguments               .   SelectionSet           _ -> failure $ hasNoSubfields key'-                                        (aliasTyCon $fieldType dataField)+                                        (typeConName $fieldType dataField)                                         selectionPosition      where-      returnSelection selectionArguments selectionRec =-        pure [(key', fullRawSelection { selectionArguments, selectionRec })]-    validateSelection (key, RawSelectionField rawSelection@Selection { selectionPosition })+      returnSelection selectionArguments selectionContent =+        pure [(key', fullRawSelection { selectionArguments, selectionContent })]+    validateSelection (key, rawSelection@Selection { selectionArguments = selArgs, selectionPosition, selectionContent = SelectionField })       = do         (dataField, datatype, selectionArguments) <- getValidationData           key-          rawSelection-        isLeaf datatype dataField+          (selArgs, selectionPosition)+        isLeaf (typeContent datatype) dataField         pure           [ ( key-            , rawSelection { selectionArguments, selectionRec = SelectionField }+            , rawSelection { selectionArguments, selectionContent = SelectionField }             )           ]      where-      isLeaf dataType DataField { fieldType = TypeAlias { aliasTyCon } }-        | isEntNode dataType = pure ()+      isLeaf datatype DataField { fieldType = TypeRef { typeConName } }+        | isEntNode datatype = pure ()         | otherwise = failure-        $ subfieldsNotSelected key aliasTyCon selectionPosition+        $ subfieldsNotSelected key typeConName selectionPosition     validateSelection (_, Spread reference') =-      resolveSpread fragments' [typeName'] reference' >>= validateFragment+      resolveSpread fragments' [typeName] reference' >>= validateFragment     validateSelection (_, InlineFragment fragment') =-      castFragmentType Nothing-                       (fragmentPosition fragment')-                       [typeName']-                       fragment'+      castFragmentType Nothing (fragmentPosition fragment') [typeName] fragment'         >>= validateFragment

@@ -13,7 +13,7 @@                                                 ( Operation(..)                                                 , ValidOperation                                                 , getOperationName-                                                , getOperationDataType+                                                , getOperationObject                                                 , DataTypeLib(..)                                                 , GQLQuery(..)                                                 )@@ -34,7 +34,7 @@   :: DataTypeLib -> VALIDATION_MODE -> GQLQuery -> Validation ValidOperation validateRequest lib validationMode GQLQuery { fragments, inputVariables, operation = rawOperation@Operation { operationName, operationType, operationSelection, operationPosition } }   = do-    operationDataType <- getOperationDataType rawOperation lib+    operationDataType <-  getOperationObject rawOperation lib     variables         <- resolveOperationVariables lib                                                    fragments                                                    (fromList inputVariables)@@ -49,7 +49,7 @@                                       operationSelection     pure $ Operation { operationName                      , operationType-                     , operationArgs      = []+                     , operationArguments      = []                      , operationSelection = selection                      , operationPosition                      }

@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -29,10 +31,12 @@                                                 , getOperationName                                                 , Fragment(..)                                                 , FragmentLib-                                                , RawArgument(..)-                                                , RawSelection(..)-                                                , RawSelectionSet+                                                , Argument(..)+                                                , RawArgument                                                 , Selection(..)+                                                , SelectionContent(..)+                                                , RawSelection+                                                , RawSelectionSet                                                 , Ref(..)                                                 , Position                                                 , DataType@@ -40,6 +44,15 @@                                                 , lookupInputType                                                 , Variables                                                 , Value(..)+                                                , ValidValue+                                                , RawValue+                                                , ResolvedValue+                                                , Name+                                                , VALID+                                                , RAW+                                                , VariableContent(..)+                                                , isNullable+                                                , TypeRef(..)                                                 ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( Validation@@ -59,24 +72,34 @@ concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f = fmap concat . mapM f ++class ExploreRefs a where+  exploreRefs :: a -> [Ref]++instance ExploreRefs RawValue where+  exploreRefs (VariableValue ref   ) = [ref]+  exploreRefs (Object        fields) = concatMap (exploreRefs . snd) fields+  exploreRefs (List          ls    ) = concatMap exploreRefs ls+  exploreRefs _                      = []++instance ExploreRefs (Text, RawArgument) where+  exploreRefs (_, Argument { argumentValue }) = exploreRefs argumentValue+ allVariableRefs :: FragmentLib -> [RawSelectionSet] -> Validation [Ref] allVariableRefs fragmentLib = concatMapM (concatMapM searchRefs)  where-  referencesFromArgument :: (Text, RawArgument) -> [Ref]-  referencesFromArgument (_, RawArgument{}) = []-  referencesFromArgument (_, VariableRef Ref { refName, refPosition }) =-    [Ref refName refPosition]+   -- | search used variables in every arguments   searchRefs :: (Text, RawSelection) -> Validation [Ref]-  searchRefs (_, RawSelectionSet Selection { selectionArguments, selectionRec })-    = getArgs <$> concatMapM searchRefs selectionRec+  searchRefs (_, Selection { selectionArguments, selectionContent = SelectionField })+    = return $ concatMap exploreRefs selectionArguments+  searchRefs (_, Selection { selectionArguments, selectionContent = SelectionSet selSet })+    = getArgs <$> concatMapM searchRefs selSet    where     getArgs :: [Ref] -> [Ref]-    getArgs x = concatMap referencesFromArgument selectionArguments <> x+    getArgs x = concatMap exploreRefs selectionArguments <> x   searchRefs (_, InlineFragment Fragment { fragmentSelection }) =     concatMapM searchRefs fragmentSelection-  searchRefs (_, RawSelectionField Selection { selectionArguments }) =-    return $ concatMap referencesFromArgument selectionArguments   searchRefs (_, Spread reference) =     getFragment reference fragmentLib       >>= concatMapM searchRefs@@ -89,17 +112,17 @@   -> VALIDATION_MODE   -> RawOperation   -> Validation ValidVariables-resolveOperationVariables typeLib lib root validationMode Operation { operationName, operationSelection, operationArgs }+resolveOperationVariables typeLib lib root validationMode Operation { operationName, operationSelection, operationArguments }   = do     allVariableRefs lib [operationSelection] >>= checkUnusedVariables     mapM (lookupAndValidateValueOnBody typeLib root validationMode)-         operationArgs+         operationArguments  where   varToKey :: (Text, Variable a) -> Ref   varToKey (key', Variable { variablePosition }) = Ref key' variablePosition   --   checkUnusedVariables :: [Ref] -> Validation ()-  checkUnusedVariables refs = case map varToKey operationArgs \\ refs of+  checkUnusedVariables refs = case map varToKey operationArguments \\ refs of     [] -> pure ()     unused' ->       failure $ unusedVariables (getOperationName operationName) unused'@@ -108,40 +131,50 @@   :: DataTypeLib   -> Variables   -> VALIDATION_MODE-  -> (Text, Variable DefaultValue)-  -> Validation (Text, Variable Value)-lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType, variablePosition, isVariableRequired, variableTypeWrappers, variableValue = defaultValue })+  -> (Text, Variable RAW)+  -> Validation (Text, Variable VALID)+lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType, variablePosition, variableValue = DefaultValue defaultValue })   = toVariable-    <$> (   getVariableType variableType variablePosition typeLib+    <$> (   getVariableType (typeConName variableType) variablePosition typeLib         >>= checkType getVariable defaultValue         )  where-  toVariable (varKey, variableValue) = (varKey, var { variableValue })+  toVariable (varKey, x) =+    (varKey, var { variableValue = ValidVariableValue x })+  getVariable :: Maybe ResolvedValue   getVariable = M.lookup key bodyVariables   ------------------------------------------------------------------+  -- checkType :: +  checkType+    :: Maybe ResolvedValue+    -> DefaultValue+    -> DataType+    -> Validation (Name, ValidValue)   checkType (Just variable) Nothing varType = validator varType variable   checkType (Just variable) (Just defValue) varType =     validator varType defValue >> validator varType variable   checkType Nothing (Just defValue) varType = validator varType defValue   checkType Nothing Nothing varType-    | validationMode /= WITHOUT_VARIABLES && isVariableRequired-    = failure $ uninitializedVariable variablePosition variableType key+    | validationMode /= WITHOUT_VARIABLES && not (isNullable variableType)+    = failure+      $ uninitializedVariable variablePosition (typeConName variableType) key     | otherwise     = returnNull    where     returnNull =       maybe (pure (key, Null)) (validator varType) (M.lookup key bodyVariables)   -----------------------------------------------------------------------------------------------+  validator :: DataType -> ResolvedValue -> Validation (Name, ValidValue)   validator varType varValue =     case         validateInputValue typeLib                            []-                           variableTypeWrappers+                           (typeWrappers variableType)                            varType                            (key, varValue)       of-        Left message -> failure $ variableGotInvalidValue-          key-          (inputErrorMessage message)-          variablePosition+        Left message -> failure $ case inputErrorMessage message of+          Left errors -> errors+          Right errMessage ->+            variableGotInvalidValue key errMessage variablePosition         Right value -> pure (key, value)

@@ -28,6 +28,8 @@                                                 , ScalarValue(..)                                                 , Resolver(..)                                                 , constRes+                                                , failRes+                                                , liftEither                                                 ) import           Data.Text                      ( Text ) import           GHC.Generics                   ( Generic )@@ -53,9 +55,19 @@  importGQLDocument "test/Feature/Holistic/schema.gql" +++alwaysFail :: IO (Either String a)+alwaysFail = pure $ Left "fail with Either"++ rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription rootResolver = GQLRootResolver-  { queryResolver        = Query { user, testUnion = constRes Nothing }+  { queryResolver        = Query { user+                                 , testUnion = constRes Nothing+                                 , fail1     = const $ liftEither alwaysFail+                                 , fail2 = const $ failRes "fail with failRes"+                                 }   , mutationResolver     = Mutation { createUser = user }   , subscriptionResolver = Subscription                              { newUser = const SubResolver

@@ -200,6 +200,10 @@     "description": "fail when: directive is used in Variable Definition"   },   {+    "path": "parsing/numbers",+    "description": "parse signed numbers and numbers with expotential"+  },+  {     "path": "introspection/description/object",     "description": "check object descriptions, type, field, args"   },@@ -222,5 +226,9 @@   {     "path": "introspection/deprecated/field",     "description": "check if deprecated works with object fields"+  },+  {+    "path": "failure/resolveFailure",+    "description": "test failed resolvers"   } ]

@@ -0,0 +1,4 @@+{+  fail1+  fail2+}

@@ -0,0 +1,12 @@+{+  "errors": [+    {+      "message": "Failure on Resolving Field \"fail1\": fail with Either",+      "locations": [{ "line": 2, "column": 3 }]+    },+    {+      "message": "Failure on Resolving Field \"fail2\": fail with failRes",+      "locations": [{ "line": 3, "column": 3 }]+    }+  ]+}

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Cannot spread fragment \"A\" within itself via A,A,C.",+      "message": "Cannot spread fragment \"A\" within itself via A, A, C.",       "locations": [         { "line": 17, "column": 3 },         { "line": 7, "column": 10 },

@@ -13,6 +13,10 @@       "locations": [{ "line": 15, "column": 21 }]     },     {+      "message": "Argument cityID got invalid value ; Expected type \"TestEnum\" found \"HH\".",+      "locations": [{ "line": 15, "column": 33 }]+    },+    {       "message": "Cannot query field \"home\" on type \"User\".",       "locations": [{ "line": 25, "column": 5 }]     },

@@ -1,13 +1,8 @@ {   "errors": [     {-      "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Directives, IgnoredTokens, Selection, body, digit, letter, maybeArguments, or white space\n",-      "locations": [-        {-          "line": 1,-          "column": 27-        }-      ]+      "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Arguments, Directives, IgnoredTokens, Selection, body, digit, letter, or white space\n",+      "locations": [{ "line": 1, "column": 27 }]     }   ] }

@@ -0,0 +1,7 @@+{+  negative1(num: -1)+  negative2(num: -20232)+  negative3(num: -5.0)+  exp1(num: 1.01e4)+  exp2(num: 6.0221413e23)+}

@@ -0,0 +1,24 @@+{+  "errors": [+    {+      "message": "Cannot query field \"negative1\" on type \"Query\".",+      "locations": [{ "line": 2, "column": 3 }]+    },+    {+      "message": "Cannot query field \"negative2\" on type \"Query\".",+      "locations": [{ "line": 3, "column": 3 }]+    },+    {+      "message": "Cannot query field \"negative3\" on type \"Query\".",+      "locations": [{ "line": 4, "column": 3 }]+    },+    {+      "message": "Cannot query field \"exp1\" on type \"Query\".",+      "locations": [{ "line": 5, "column": 3 }]+    },+    {+      "message": "Cannot query field \"exp2\" on type \"Query\".",+      "locations": [{ "line": 6, "column": 3 }]+    }+  ]+}

@@ -92,6 +92,8 @@ type Query {   user: User!   testUnion: TestUnion+  fail1: String!+  fail2: Int! }  type Mutation {

@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE TypeOperators  #-}++module Feature.Input.Object.API+  ( api+  )+where++import           Data.Morpheus                  ( interpreter )+import           Data.Morpheus.Types            ( GQLRequest+                                                , GQLResponse+                                                , GQLRootResolver(..)+                                                , GQLType(..)+                                                , Undefined(..)+                                                )+import           GHC.Generics                   ( Generic )+import           Data.Morpheus.Kind             ( INPUT )+import           Data.Text                      ( Text+                                                , pack+                                                )+++data InputObject = InputObject {+  field :: Text,+  nullableField :: Maybe Int+} deriving (Generic, Show)++instance GQLType InputObject where+  type KIND InputObject = INPUT++-- types & args+newtype Arg a = Arg+  { value :: a+  } deriving (Generic, Show)++-- query+testRes :: Show a => Applicative m => Arg a -> m Text+testRes Arg { value } = pure $ pack $ show value++-- resolver+newtype Query m = Query+  { input  :: Arg InputObject -> m Text+  } deriving (Generic, GQLType)++rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver = GQLRootResolver { queryResolver = Query { input = testRes }+                               , mutationResolver = Undefined+                               , subscriptionResolver = Undefined+                               }++api :: GQLRequest -> IO GQLResponse+api = interpreter rootResolver

@@ -0,0 +1,30 @@+[+  {+    "path": "undefinedField",+    "description": "fail when field was not provided"+  },+  {+    "path": "nullableUndefinedField",+    "description": "dont fail when nullable field was not provided"+  },+  {+    "path": "unknownField",+    "description": "fail on unknown field"+  },+  {+    "path": "unexpectedValue",+    "description": "fail on value with unexpected type"+  },+  {+    "path": "unexpectedVariable",+    "description": "fail on use of variable with unexpected type"+  },+  {+    "path": "resolveVariable",+    "description": "resolve by variable"+  },+  {+    "path": "resolveObject",+    "description": "resolve object"+  }+]

@@ -0,0 +1,3 @@+query NullableUndefinedField {+  input(value: { field: "value" })+}

@@ -0,0 +1,5 @@+{+  "data": {+    "input": "InputObject {field = \"value\", nullableField = Nothing}"+  }+}

@@ -0,0 +1,4 @@+query ResolveObject {+  i1: input(value: { field: "v1", nullableField: 123 })+  i2: input(value: { field: "v2" })+}

@@ -0,0 +1,6 @@+{+  "data": {+    "i1": "InputObject {field = \"v1\", nullableField = Just 123}",+    "i2": "InputObject {field = \"v2\", nullableField = Nothing}"+  }+}