morpheus-graphql-core 0.12.0 → 0.13.0

raw patch · 77 files changed

+3353/−1969 lines, 77 filesdep +directorydep +mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, mtl

API changes (from Hackage documentation)

Files

• changelog.md +15/−0
• morpheus-graphql-core.cabal +39/−11
• src/Data/Morpheus/Error/Document/Interface.hs +73/−26
• src/Data/Morpheus/Internal/TH.hs +12/−62
• src/Data/Morpheus/Parsing/Document/TypeSystem.hs +34/−45
• src/Data/Morpheus/Parsing/Internal/Pattern.hs +15/−36
• src/Data/Morpheus/Parsing/Internal/Value.hs +2/−3
• src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +4/−3
• src/Data/Morpheus/Parsing/Request/Operation.hs +1/−1
• src/Data/Morpheus/Rendering/RenderGQL.hs +14/−0
• src/Data/Morpheus/Rendering/RenderIntrospection.hs +283/−235
• src/Data/Morpheus/Schema/DSL.hs +43/−0
• src/Data/Morpheus/Schema/Directives.hs +3/−4
• src/Data/Morpheus/Schema/Schema.hs +9/−9
• src/Data/Morpheus/Schema/SchemaAPI.hs +12/−14
• src/Data/Morpheus/Types/GQLScalar.hs +85/−0
• src/Data/Morpheus/Types/ID.hs +43/−0
• src/Data/Morpheus/Types/Internal/AST.hs +12/−9
• src/Data/Morpheus/Types/Internal/AST/Base.hs +13/−15
• src/Data/Morpheus/Types/Internal/AST/Data.hs +0/−765
• src/Data/Morpheus/Types/Internal/AST/DirectiveLocation.hs +30/−0
• src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs +9/−6
• src/Data/Morpheus/Types/Internal/AST/Selection.hs +7/−7
• src/Data/Morpheus/Types/Internal/AST/TH.hs +16/−35
• src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs +790/−0
• src/Data/Morpheus/Types/Internal/AST/Value.hs +32/−21
• src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +4/−4
• src/Data/Morpheus/Types/Internal/Validation.hs +118/−143
• src/Data/Morpheus/Types/Internal/Validation/Error.hs +79/−38
• src/Data/Morpheus/Types/Internal/Validation/SchemaValidator.hs +144/−0
• src/Data/Morpheus/Types/Internal/Validation/Validator.hs +275/−73
• src/Data/Morpheus/Validation/Document/Validation.hs +213/−40
• src/Data/Morpheus/Validation/Internal/Value.hs +203/−64
• src/Data/Morpheus/Validation/Query/Arguments.hs +14/−16
• src/Data/Morpheus/Validation/Query/Fragment.hs +2/−1
• src/Data/Morpheus/Validation/Query/UnionSelection.hs +8/−6
• src/Data/Morpheus/Validation/Query/Validation.hs +10/−16
• src/Data/Morpheus/Validation/Query/Variable.hs +9/−9
• test/Lib.hs +53/−0
• test/Schema.hs +28/−22
• test/Spec.hs +5/−4
• test/api/interface/query.gql +79/−0
• test/api/interface/response.json +65/−0
• test/api/simple/query.gql +6/−0
• test/api/simple/response.json +6/−0
• test/interface/query.gql +0/−79
• test/interface/response.json +0/−65
• test/schema/validation/default-value/argument/compound-ok/response.json +1/−0
• test/schema/validation/default-value/argument/compound-ok/schema.gql +35/−0
• test/schema/validation/default-value/argument/missing-field/response.json +24/−0
• test/schema/validation/default-value/argument/missing-field/schema.gql +22/−0
• test/schema/validation/default-value/argument/unexpected-value/response.json +32/−0
• test/schema/validation/default-value/argument/unexpected-value/schema.gql +25/−0
• test/schema/validation/default-value/argument/unknown-field/response.json +16/−0
• test/schema/validation/default-value/argument/unknown-field/schema.gql +20/−0
• test/schema/validation/default-value/field/compound-ok/response.json +1/−0
• test/schema/validation/default-value/field/compound-ok/schema.gql +23/−0
• test/schema/validation/default-value/field/missing-field/response.json +12/−0
• test/schema/validation/default-value/field/missing-field/schema.gql +18/−0
• test/schema/validation/default-value/field/unexpected-value/response.json +36/−0
• test/schema/validation/default-value/field/unexpected-value/schema.gql +22/−0
• test/schema/validation/default-value/field/unknown-field/response.json +16/−0
• test/schema/validation/default-value/field/unknown-field/schema.gql +18/−0
• test/schema/validation/interface/fail/response.json +0/−16
• test/schema/validation/interface/fail/schema.gql +0/−33
• test/schema/validation/interface/field-args/fail/response.json +16/−0
• test/schema/validation/interface/field-args/fail/schema.gql +23/−0
• test/schema/validation/interface/field-args/ok/response.json +1/−0
• test/schema/validation/interface/field-args/ok/schema.gql +18/−0
• test/schema/validation/interface/field-type/fail/response.json +16/−0
• test/schema/validation/interface/field-type/fail/schema.gql +20/−0
• test/schema/validation/interface/field-type/ok/response.json +1/−0
• test/schema/validation/interface/field-type/ok/schema.gql +20/−0
• test/schema/validation/interface/ok/response.json +0/−1
• test/schema/validation/interface/ok/schema.gql +0/−20
• test/simple/query.gql +0/−6
• test/simple/response.json +0/−6

@@ -1,5 +1,20 @@ # Changelog +## 0.13.0 - Unreleased Changes++### new features++- exposed: `Data.Morpheus.Types.GQLScalar`+- exposed: `Data.Morpheus.Types.ID`+- finished interface validation+- supports default values++## minor changes++- internal refactoring+- added dependency `mtl`+- validates strings as enum from JSON value+ ## 0.12.0 - 21.05.2020  ## New features

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 4a337fa1d88f2e1ca1eb76ec72c4bd0e5e91ef67626a02682384994f6731d446+-- hash: b13e1668b9269ab28dfdd66f04b342a5bdbec82e6ba59c98c0467604df7270a6  name:           morpheus-graphql-core-version:        0.12.0+version:        0.13.0 synopsis:       Morpheus GraphQL Core description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -23,14 +23,34 @@     changelog.md     README.md data-files:-    test/interface/query.gql-    test/schema/validation/interface/fail/schema.gql-    test/schema/validation/interface/ok/schema.gql-    test/simple/query.gql-    test/interface/response.json-    test/schema/validation/interface/fail/response.json-    test/schema/validation/interface/ok/response.json-    test/simple/response.json+    test/api/interface/query.gql+    test/api/simple/query.gql+    test/schema/validation/default-value/argument/compound-ok/schema.gql+    test/schema/validation/default-value/argument/missing-field/schema.gql+    test/schema/validation/default-value/argument/unexpected-value/schema.gql+    test/schema/validation/default-value/argument/unknown-field/schema.gql+    test/schema/validation/default-value/field/compound-ok/schema.gql+    test/schema/validation/default-value/field/missing-field/schema.gql+    test/schema/validation/default-value/field/unexpected-value/schema.gql+    test/schema/validation/default-value/field/unknown-field/schema.gql+    test/schema/validation/interface/field-args/fail/schema.gql+    test/schema/validation/interface/field-args/ok/schema.gql+    test/schema/validation/interface/field-type/fail/schema.gql+    test/schema/validation/interface/field-type/ok/schema.gql+    test/api/interface/response.json+    test/api/simple/response.json+    test/schema/validation/default-value/argument/compound-ok/response.json+    test/schema/validation/default-value/argument/missing-field/response.json+    test/schema/validation/default-value/argument/unexpected-value/response.json+    test/schema/validation/default-value/argument/unknown-field/response.json+    test/schema/validation/default-value/field/compound-ok/response.json+    test/schema/validation/default-value/field/missing-field/response.json+    test/schema/validation/default-value/field/unexpected-value/response.json+    test/schema/validation/default-value/field/unknown-field/response.json+    test/schema/validation/interface/field-args/fail/response.json+    test/schema/validation/interface/field-args/ok/response.json+    test/schema/validation/interface/field-type/fail/response.json+    test/schema/validation/interface/field-type/ok/response.json  source-repository head   type: git@@ -46,6 +66,8 @@       Data.Morpheus.Types.Internal.AST       Data.Morpheus.Types.IO       Data.Morpheus.Types.Internal.Resolving+      Data.Morpheus.Types.GQLScalar+      Data.Morpheus.Types.ID   other-modules:       Data.Morpheus.Error.Document.Interface       Data.Morpheus.Error.Fragment@@ -73,20 +95,23 @@       Data.Morpheus.Rendering.RenderGQL       Data.Morpheus.Rendering.RenderIntrospection       Data.Morpheus.Schema.Directives+      Data.Morpheus.Schema.DSL       Data.Morpheus.Schema.Schema       Data.Morpheus.Schema.SchemaAPI       Data.Morpheus.Schema.TypeKind       Data.Morpheus.Types.Internal.AST.Base-      Data.Morpheus.Types.Internal.AST.Data+      Data.Morpheus.Types.Internal.AST.DirectiveLocation       Data.Morpheus.Types.Internal.AST.MergeSet       Data.Morpheus.Types.Internal.AST.OrderedMap       Data.Morpheus.Types.Internal.AST.Selection       Data.Morpheus.Types.Internal.AST.TH+      Data.Morpheus.Types.Internal.AST.TypeSystem       Data.Morpheus.Types.Internal.AST.Value       Data.Morpheus.Types.Internal.Resolving.Core       Data.Morpheus.Types.Internal.Resolving.Resolver       Data.Morpheus.Types.Internal.Validation       Data.Morpheus.Types.Internal.Validation.Error+      Data.Morpheus.Types.Internal.Validation.SchemaValidator       Data.Morpheus.Types.Internal.Validation.Validator       Data.Morpheus.Types.SelectionTree       Data.Morpheus.Validation.Document.Validation@@ -108,6 +133,7 @@     , bytestring >=0.10.4 && <0.11     , hashable >=1.0.0     , megaparsec >=7.0.0 && <9.0.0+    , mtl >=2.0 && <=3.0     , scientific >=0.3.6.2 && <0.4     , template-haskell >=2.0 && <=3.0     , text >=1.2.3.0 && <1.3@@ -131,9 +157,11 @@       aeson     , base >=4.7 && <5     , bytestring >=0.10.4 && <0.11+    , directory >=1.0     , hashable >=1.0.0     , megaparsec >=7.0.0 && <9.0.0     , morpheus-graphql-core+    , mtl >=2.0 && <=3.0     , scientific >=0.3.6.2 && <0.4     , tasty     , tasty-hunit

@@ -1,22 +1,29 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Error.Document.Interface   ( unknownInterface,-    partialImplements,+    PartialImplements (..),     ImplementsError (..),+    Place (..),   ) where  import Data.Morpheus.Error.Utils (globalErrorMessage) import Data.Morpheus.Types.Internal.AST.Base-  ( FieldName,+  ( FieldName (..),     GQLError (..),     GQLErrors,-    TypeName,+    TypeName (..),     TypeRef,     msg,   )+import Data.Morpheus.Types.Internal.Validation.SchemaValidator+  ( Field (..),+    Interface (..),+    renderField,+  ) import Data.Semigroup ((<>))  unknownInterface :: TypeName -> GQLErrors@@ -29,30 +36,70 @@       { expectedType :: TypeRef,         foundType :: TypeRef       }-  | UndefinedField+  | Missing -partialImplements :: TypeName -> [(TypeName, FieldName, ImplementsError)] -> GQLErrors-partialImplements name = map impError-  where-    impError (interfaceName, key, errorType) =-      GQLError+data Place = Place+  { fieldname :: TypeName,+    typename :: FieldName,+    fieldArg :: Maybe (FieldName, TypeName)+  }++class PartialImplements ctx where+  partialImplements :: ctx -> ImplementsError -> GQLErrors++instance PartialImplements (Interface, FieldName) where+  partialImplements (Interface interfaceName typename, fieldname) errorType =+    [ GQLError         { message = message,           locations = []         }-      where-        message =-          "type "-            <> msg name-            <> " implements Interface "-            <> msg interfaceName-            <> " Partially,"-            <> detailedMessage errorType-        detailedMessage UnexpectedType {expectedType, foundType} =-          " on key "-            <> msg key-            <> " expected type "-            <> msg expectedType-            <> " found "-            <> msg foundType-            <> "."-        detailedMessage UndefinedField = " key " <> msg key <> " not found ."+    ]+    where+      message =+        "Interface field "+          <> renderField interfaceName fieldname Nothing+          <> detailedMessage errorType+      detailedMessage UnexpectedType {expectedType, foundType} =+        " expects type "+          <> msg expectedType+          <> " but "+          <> renderField typename fieldname Nothing+          <> " is type "+          <> msg foundType+          <> "."+      detailedMessage Missing =+        " expected but "+          <> msg typename+          <> " does not provide it."++-- Interface field TestInterface.name expected but User does not provide it.+-- Interface field TestInterface.name expects type String! but User.name is type Int!.++instance PartialImplements (Interface, Field) where+  partialImplements (Interface interfaceName typename, Field fieldname argName) errorType =+    [ GQLError+        { message = message,+          locations = []+        }+    ]+    where+      --+      message =+        "Interface field argument "+          <> renderField interfaceName fieldname (Just argName)+          <> detailedMessage errorType+      detailedMessage UnexpectedType {expectedType, foundType} =+        " expects type"+          <> msg expectedType+          <> " but "+          <> renderField typename fieldname (Just argName)+          <> " is type "+          <> msg foundType+          <> "."+      detailedMessage Missing =+        " expected but "+          <> renderField typename fieldname Nothing+          <> " does not provide it."++-- Interface field argument TestInterface.name(id:) expected but User.name does not provide it.+-- Interface field argument TestInterface.name(id:) expects type ID but User.name(id:) is type String.

@@ -10,9 +10,7 @@ {-# LANGUAGE TypeApplications #-}  module Data.Morpheus.Internal.TH-  ( declareType,-    tyConArgs,-    Scope (..),+  ( tyConArgs,     apply,     applyT,     typeT,@@ -34,42 +32,39 @@     nameConE,     nameVarP,     mkTypeName,+    mkFieldName,+    declareTypeRef,+    nameSpaceField,+    nameSpaceType,+    m_,+    m',+    isEnum,   ) where -import Data.Maybe (maybe) -- MORPHEUS import Data.Morpheus.Internal.Utils   ( nameSpaceField,     nameSpaceType,   ) import Data.Morpheus.Types.Internal.AST-  ( ArgumentsDefinition (..),-    ConsD (..),-    DataTypeKind (..),-    DataTypeKind (..),-    FieldDefinition (..),-    FieldName,-    TypeD (..),+  ( FieldName,+    TypeKind (..),+    TypeKind (..),     TypeName (..),     TypeRef (..),     TypeWrapper (..),     convertToHaskellName,     isEnum,     isOutputObject,-    isSubscription,     readName,   ) import Data.Morpheus.Types.Internal.Resolving   ( UnSubResolver,   )-import Data.Semigroup ((<>)) import Data.Text (unpack)-import GHC.Generics (Generic) import Language.Haskell.TH -type Arrow = (->)- m' :: Type m' = VarT $ mkTypeName m_ @@ -94,55 +89,10 @@     decType (Just par) = AppT typeName (VarT $ mkTypeName par)     decType _ = typeName -tyConArgs :: DataTypeKind -> [TypeName]+tyConArgs :: TypeKind -> [TypeName] tyConArgs kindD   | isOutputObject kindD || kindD == KindUnion = [m_]   | otherwise = []--data Scope = CLIENT | SERVER-  deriving (Eq)--declareType :: Scope -> Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec-declareType scope namespace kindD derivingList TypeD {tName, tCons, tNamespace} =-  DataD [] (genName tName) tVars Nothing cons $-    map derive (''Generic : derivingList)-  where-    genName = mkTypeName . nameSpaceType tNamespace-    tVars = maybe [] (declareTyVar . tyConArgs) kindD-      where-        declareTyVar = map (PlainTV . mkTypeName)-    defBang = Bang NoSourceUnpackedness NoSourceStrictness-    derive className = DerivClause Nothing [ConT className]-    cons-      | scope == CLIENT && isEnum tCons = map consE tCons-      | otherwise = map consR tCons-    consE ConsD {cName} = NormalC (genName $ tName <> cName) []-    consR ConsD {cName, cFields} =-      RecC-        (genName cName)-        (map declareField cFields)-      where-        declareField FieldDefinition {fieldName, fieldArgs, fieldType} =-          (mkFieldName fName, defBang, fiType)-          where-            fName-              | namespace = nameSpaceField tName fieldName-              | otherwise = fieldName-            fiType = genFieldT fieldArgs-              where-                ----------------------------                genFieldT ArgumentsDefinition {argumentsTypename = Just argsTypename} =-                  AppT-                    (AppT arrowType argType)-                    (AppT m' result)-                  where-                    argType = ConT $ mkTypeName argsTypename-                    arrowType = ConT ''Arrow-                genFieldT _-                  | (isOutputObject <$> kindD) == Just True = AppT m' result-                  | otherwise = result-                -------------------------------------------------                result = declareTypeRef (maybe False isSubscription kindD) fieldType  apply :: Name -> [Q Exp] -> Q Exp apply n = foldl appE (conE n)

@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Data.Morpheus.Parsing.Document.TypeSystem   ( parseSchema,@@ -33,12 +34,13 @@     DataFingerprint (..),     Description,     IN,-    Meta (..),     OUT,     ScalarDefinition (..),     TypeContent (..),     TypeDefinition (..),     TypeName,+    UnionMember (..),+    mkUnionMember,     toAny,   ) import Data.Morpheus.Types.Internal.Resolving@@ -59,15 +61,14 @@ --    Description(opt) scalar Name Directives(Const)(opt) -- scalarTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY)-scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do+scalarTypeDefinition typeDescription = label "ScalarTypeDefinition" $ do   typeName <- typeDeclaration "scalar"-  metaDirectives <- optionalDirectives+  typeDirectives <- optionalDirectives   pure     TypeDefinition-      { typeName,-        typeMeta = Just Meta {metaDescription, metaDirectives},-        typeFingerprint = DataFingerprint typeName [],-        typeContent = DataScalar $ ScalarDefinition pure+      { typeFingerprint = DataFingerprint typeName [],+        typeContent = DataScalar $ ScalarDefinition pure,+        ..       }  -- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects@@ -86,18 +87,17 @@ --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) -- objectTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)-objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do+objectTypeDefinition typeDescription = label "ObjectTypeDefinition" $ do   typeName <- typeDeclaration "type"   objectImplements <- optionalImplementsInterfaces-  metaDirectives <- optionalDirectives+  typeDirectives <- optionalDirectives   objectFields <- fieldsDefinition   -- build object   pure     TypeDefinition-      { typeName,-        typeMeta = Just Meta {metaDescription, metaDirectives},-        typeFingerprint = DataFingerprint typeName [],-        typeContent = DataObject {objectImplements, objectFields}+      { typeFingerprint = DataFingerprint typeName [],+        typeContent = DataObject {objectImplements, objectFields},+        ..       }  optionalImplementsInterfaces :: Parser [TypeName]@@ -112,17 +112,14 @@ --    Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) -- interfaceTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)-interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do+interfaceTypeDefinition typeDescription = label "InterfaceTypeDefinition" $ do   typeName <- typeDeclaration "interface"-  metaDirectives <- optionalDirectives-  fields <- fieldsDefinition-  -- build interface+  typeDirectives <- optionalDirectives+  typeContent <- DataInterface <$> fieldsDefinition   pure     TypeDefinition-      { typeName,-        typeMeta = Just Meta {metaDescription, metaDirectives},-        typeFingerprint = DataFingerprint typeName [],-        typeContent = DataInterface fields+      { typeFingerprint = DataFingerprint typeName [],+        ..       }  -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions@@ -135,20 +132,17 @@ --      UnionMemberTypes | NamedType -- unionTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)-unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do+unionTypeDefinition typeDescription = label "UnionTypeDefinition" $ do   typeName <- typeDeclaration "union"-  metaDirectives <- optionalDirectives-  memberTypes <- unionMemberTypes-  -- build union+  typeDirectives <- optionalDirectives+  typeContent <- DataUnion <$> unionMemberTypes   pure     TypeDefinition-      { typeName,-        typeMeta = Just Meta {metaDescription, metaDirectives},-        typeFingerprint = DataFingerprint typeName [],-        typeContent = DataUnion memberTypes+      { typeFingerprint = DataFingerprint typeName [],+        ..       }   where-    unionMemberTypes = operator '=' *> parseTypeName `sepBy1` pipeLiteral+    unionMemberTypes = operator '=' *> (mkUnionMember <$> parseTypeName) `sepBy1` pipeLiteral  -- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums --@@ -162,17 +156,14 @@ --    Description(opt) EnumValue Directives(Const)(opt) -- enumTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY)-enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do+enumTypeDefinition typeDescription = label "EnumTypeDefinition" $ do   typeName <- typeDeclaration "enum"-  metaDirectives <- optionalDirectives-  enumValuesDefinitions <- collection enumValueDefinition-  -- build enum+  typeDirectives <- optionalDirectives+  typeContent <- DataEnum <$> collection enumValueDefinition   pure     TypeDefinition-      { typeName,-        typeContent = DataEnum enumValuesDefinitions,-        typeFingerprint = DataFingerprint typeName [],-        typeMeta = Just Meta {metaDescription, metaDirectives}+      { typeFingerprint = DataFingerprint typeName [],+        ..       }  -- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects@@ -184,18 +175,16 @@ --     { InputValueDefinition(list) } -- inputObjectTypeDefinition :: Maybe Description -> Parser (TypeDefinition IN)-inputObjectTypeDefinition metaDescription =+inputObjectTypeDefinition typeDescription =   label "InputObjectTypeDefinition" $ do     typeName <- typeDeclaration "input"-    metaDirectives <- optionalDirectives-    fields <- inputFieldsDefinition+    typeDirectives <- optionalDirectives+    typeContent <- DataInputObject <$> inputFieldsDefinition     -- build input     pure       TypeDefinition-        { typeName,-          typeContent = DataInputObject fields,-          typeFingerprint = DataFingerprint typeName [],-          typeMeta = Just Meta {metaDescription, metaDirectives}+        { typeFingerprint = DataFingerprint typeName [],+          ..         }  parseDataType :: Parser (TypeDefinition ANY)

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}  module Data.Morpheus.Parsing.Internal.Pattern@@ -13,15 +12,12 @@ where  -- MORPHEUS- import Data.Morpheus.Parsing.Internal.Arguments   ( maybeArguments,   ) import Data.Morpheus.Parsing.Internal.Internal   ( Parser,-  )-import Data.Morpheus.Parsing.Internal.Internal-  ( getLocation,+    getLocation,   ) import Data.Morpheus.Parsing.Internal.Terms   ( keyword,@@ -42,20 +38,20 @@   ( ArgumentsDefinition (..),     DataEnumValue (..),     Directive (..),+    FieldContent (..),     FieldDefinition (..),     FieldName,     FieldsDefinition,     IN,     InputFieldsDefinition,-    Meta (..),     OUT,     TypeName,     Value,   ) import Text.Megaparsec-  ( (<|>),-    label,+  ( label,     many,+    optional,   )  --  EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition@@ -65,14 +61,10 @@ -- enumValueDefinition :: Parser DataEnumValue enumValueDefinition = label "EnumValueDefinition" $ do-  metaDescription <- optDescription+  enumDescription <- optDescription   enumName <- parseTypeName-  metaDirectives <- optionalDirectives-  return $-    DataEnumValue-      { enumName,-        enumMeta = Just Meta {metaDescription, metaDirectives}-      }+  enumDirectives <- optionalDirectives+  return DataEnumValue {..}  -- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition --@@ -81,19 +73,13 @@ -- inputValueDefinition :: Parser (FieldDefinition IN) inputValueDefinition = label "InputValueDefinition" $ do-  metaDescription <- optDescription+  fieldDescription <- optDescription   fieldName <- parseName   litAssignment -- ':'   fieldType <- parseType-  _ <- parseDefaultValue-  metaDirectives <- optionalDirectives-  pure-    FieldDefinition-      { fieldArgs = NoArguments,-        fieldName,-        fieldType,-        fieldMeta = Just Meta {metaDescription, metaDirectives}-      }+  fieldContent <- optional (DefaultInputValue <$> parseDefaultValue)+  fieldDirectives <- optionalDirectives+  pure FieldDefinition {..}  -- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments --@@ -104,7 +90,6 @@ argumentsDefinition =   label "ArgumentsDefinition" $     uniqTuple inputValueDefinition-      <|> pure NoArguments  --  FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition --@@ -119,19 +104,13 @@ -- fieldDefinition :: Parser (FieldDefinition OUT) fieldDefinition = label "FieldDefinition" $ do-  metaDescription <- optDescription+  fieldDescription <- optDescription   fieldName <- parseName-  fieldArgs <- argumentsDefinition+  fieldContent <- optional (FieldArgs <$> argumentsDefinition)   litAssignment -- ':'   fieldType <- parseType-  metaDirectives <- optionalDirectives-  pure-    FieldDefinition-      { fieldName,-        fieldArgs,-        fieldType,-        fieldMeta = Just Meta {metaDescription, metaDirectives}-      }+  fieldDirectives <- optionalDirectives+  pure FieldDefinition {..}  -- InputFieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives --   InputFieldsDefinition:

@@ -45,7 +45,6 @@     choice,     label,     many,-    optional,     sepBy,   ) import Text.Megaparsec.Char@@ -116,8 +115,8 @@ parsePrimitives =   valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue -parseDefaultValue :: Parser (Maybe ResolvedValue)-parseDefaultValue = optional $ do+parseDefaultValue :: Parser ResolvedValue+parseDefaultValue = do   litEquals   parseV   where

@@ -42,10 +42,11 @@     TypeWrapper,     createArgument,     createEnumType,-    createField,     createScalarType,     createType,     createUnionType,+    mkField,+    mkObjectField,     msg,     toAny,     toHSWrappers,@@ -93,13 +94,13 @@   parse Field {fieldName, fieldArgs, fieldType} = do     fType <- fieldTypeFromJSON fieldType     args <- traverse genArg fieldArgs >>= fromElems-    pure $ createField (ArgumentsDefinition Nothing args) fieldName fType+    pure $ mkObjectField (ArgumentsDefinition Nothing args) fieldName fType     where       genArg InputValue {inputName = argName, inputType = argType} =         createArgument argName <$> fieldTypeFromJSON argType  instance ParseJSONSchema InputValue (FieldDefinition IN) where-  parse InputValue {inputName, inputType} = createField NoArguments inputName <$> fieldTypeFromJSON inputType+  parse InputValue {inputName, inputType} = mkField inputName <$> fieldTypeFromJSON inputType  fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], TypeName) fieldTypeFromJSON = fmap toHs . fieldTypeRec []

@@ -60,7 +60,7 @@   (Ref variableName variablePosition) <- variable   operator ':'   variableType <- parseType-  variableValue <- DefaultValue <$> parseDefaultValue+  variableValue <- DefaultValue <$> optional parseDefaultValue   pure Variable {..}  -- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations

@@ -13,12 +13,26 @@ import Data.Text   ( Text,     intercalate,+    pack,   )  type Rendering = Text  class RenderGQL a where   render :: a -> Rendering++instance RenderGQL Int where+  render = pack . show++instance RenderGQL Float where+  render = pack . show++instance RenderGQL Text where+  render = pack . show++instance RenderGQL Bool where+  render True = "true"+  render False = "false"  renderIndent :: Rendering renderIndent = "  "

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -19,35 +20,46 @@ -- Morpheus  import Data.Morpheus.Internal.Utils-  ( elems,+  ( Failure,+    elems,     failure,+    fromElems,     selectBy,+    selectOr,   )+import qualified Data.Morpheus.Rendering.RenderGQL as GQL (RenderGQL (..)) import Data.Morpheus.Schema.TypeKind (TypeKind (..))+import qualified Data.Morpheus.Types.Internal.AST as AST (TypeKind (..)) import Data.Morpheus.Types.Internal.AST-  ( ArgumentsDefinition (..),+  ( ANY,+    ArgumentsDefinition (..),     DataEnumValue (..),-    DataInputUnion,-    DataInputUnion,-    DataTypeKind (..),     DataTypeWrapper (..),-    DataUnion,     Description,     DirectiveDefinition (..),     DirectiveLocation,+    Directives,+    FieldContent (..),     FieldDefinition (..),     FieldName (..),     FieldsDefinition,+    GQLErrors,     IN,     Message,-    Meta (..),     OUT,+    Object,+    ObjectEntry (..),     QUERY,+    RESOLVED,     Schema,+    TRUE,     TypeContent (..),     TypeDefinition (..),     TypeName (..),     TypeRef (..),+    UnionMember (..),+    VALID,+    Value (..),     createInputUnionFields,     fieldVisibility,     kindOf,@@ -57,298 +69,334 @@     toGQLWrapper,   ) import Data.Morpheus.Types.Internal.Resolving-  ( ResModel,+  ( Context (..),+    ResModel,     Resolver,     mkBoolean,     mkList,     mkNull,     mkObject,     mkString,+    unsafeInternalContext,   ) import Data.Semigroup ((<>)) import Data.Text (pack) -constRes :: Applicative m => a -> b -> m a-constRes = const . pure+type Result e m a = Resolver QUERY e m a -type Result e m a = Schema -> Resolver QUERY e m a+class+  ( Monad m,+    Failure Message m,+    Failure GQLErrors m+  ) =>+  WithSchema m+  where+  getSchema :: m Schema -class RenderSchema a where-  render :: (Monad m) => a -> Schema -> Resolver QUERY e m (ResModel QUERY e m)+instance Monad m => WithSchema (Resolver QUERY e m) where+  getSchema = schema <$> unsafeInternalContext -instance RenderSchema DirectiveDefinition where+selectType ::+  WithSchema m =>+  TypeName ->+  m (TypeDefinition ANY)+selectType name =+  getSchema+    >>= selectBy (" INTERNAL: INTROSPECTION Type not Found: \"" <> msg name <> "\"") name++class RenderIntrospection a where+  render ::+    (Monad m) =>+    a ->+    Resolver QUERY e m (ResModel QUERY e m)++instance RenderIntrospection TypeName where+  render = pure . mkString . readTypeName++instance RenderIntrospection FieldName where+  render = pure . mkString . readName++instance RenderIntrospection Description where+  render = pure . mkString++instance RenderIntrospection TypeKind where+  render = pure . mkString . pack . show++instance RenderIntrospection a => RenderIntrospection [a] where+  render ls = mkList <$> traverse render ls++instance RenderIntrospection DirectiveDefinition where   render     DirectiveDefinition       { directiveDefinitionName,         directiveDefinitionDescription,         directiveDefinitionLocations,         directiveDefinitionArgs-      }-    schema =+      } =       pure $         mkObject           "__Directive"-          [ renderFieldName directiveDefinitionName,-            renderDescription directiveDefinitionDescription,-            ("locations", render directiveDefinitionLocations schema),-            ("args", mkList <$> renderArguments directiveDefinitionArgs schema)+          [ renderName directiveDefinitionName,+            description directiveDefinitionDescription,+            ("locations", render directiveDefinitionLocations),+            ("args", render directiveDefinitionArgs)           ] -instance RenderSchema a => RenderSchema [a] where-  render ls schema = mkList <$> traverse (`render` schema) ls+instance RenderIntrospection DirectiveLocation where+  render locations = pure $ mkString (pack $ show locations) -instance RenderSchema DirectiveLocation where-  render locations _ = pure $ mkString (pack $ show locations)+instance RenderIntrospection (TypeDefinition a) where+  render+    TypeDefinition+      { typeName,+        typeDescription,+        typeContent+      } = pure $ renderContent typeContent+      where+        __type :: Monad m => TypeKind -> [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] -> ResModel QUERY e m+        __type kind = mkType kind typeName typeDescription+        renderContent :: Monad m => TypeContent bool a -> ResModel QUERY e m+        renderContent DataScalar {} = __type SCALAR []+        renderContent (DataEnum enums) = __type ENUM [("enumValues", render enums)]+        renderContent (DataInputObject inputFiels) =+          __type+            INPUT_OBJECT+            [("inputFields", render inputFiels)]+        renderContent DataObject {objectImplements, objectFields} =+          createObjectType typeName typeDescription objectImplements objectFields+        renderContent (DataUnion union) =+          __type+            UNION+            [("possibleTypes", render union)]+        renderContent (DataInputUnion members) =+          __type+            INPUT_OBJECT+            [ ( "inputFields",+                render+                  $ createInputUnionFields typeName+                  $ filter visibility members+              )+            ]+        renderContent (DataInterface fields) =+          __type+            INTERFACE+            [ ("fields", render fields),+              ("possibleTypes", interfacePossibleTypes typeName)+            ] -instance RenderSchema (TypeDefinition a) where-  render TypeDefinition {typeName, typeMeta, typeContent} = __render typeContent-    where-      __render ::-        (Monad m) => TypeContent bool a -> Schema -> Resolver QUERY e m (ResModel QUERY e m)-      __render DataScalar {} =-        constRes $ createLeafType SCALAR typeName typeMeta Nothing-      __render (DataEnum enums) =-        constRes $-          createLeafType ENUM typeName typeMeta (Just $ map createEnumValue enums)-      __render (DataInputObject fields) = \lib ->-        createInputObject typeName typeMeta-          <$> traverse (`renderinputValue` lib) (elems fields)-      __render DataObject {objectImplements, objectFields} =-        pure . createObjectType typeName typeMeta objectImplements objectFields-      __render (DataUnion union) = \schema ->-        pure $ typeFromUnion schema (typeName, typeMeta, union)-      __render (DataInputUnion members) =-        renderInputUnion (typeName, typeMeta, members)-      __render (DataInterface fields) =-        renderInterface typeName Nothing fields+instance RenderIntrospection (UnionMember OUT) where+  render UnionMember {memberName} = selectType memberName >>= render -renderFields :: Monad m => Schema -> FieldsDefinition cat -> Resolver QUERY e m [ResModel QUERY e m]-renderFields schema = traverse (`render` schema) . filter fieldVisibility . elems+instance RenderIntrospection (FieldDefinition cat) => RenderIntrospection (FieldsDefinition cat) where+  render = render . filter fieldVisibility . elems -renderInterface ::-  Monad m => TypeName -> Maybe Meta -> FieldsDefinition OUT -> Schema -> Resolver QUERY e m (ResModel QUERY e m)-renderInterface name meta fields schema =-  pure $-    mkObject-      "__Type"-      [ renderKind INTERFACE,-        renderName name,-        description meta,-        ("fields", mkList <$> renderFields schema fields),-        ("possibleTypes", mkList <$> interfacePossibleTypes schema name)+instance RenderIntrospection (FieldDefinition OUT) where+  render FieldDefinition {..} =+    pure+      $ mkObject "__Field"+      $ [ renderName fieldName,+          description fieldDescription,+          type' fieldType,+          ("args", maybe (pure $ mkList []) render fieldContent)+        ]+        <> renderDeprecated fieldDirectives++instance RenderIntrospection (FieldContent TRUE OUT) where+  render (FieldArgs args) = render args++instance RenderIntrospection ArgumentsDefinition where+  render ArgumentsDefinition {arguments} = mkList <$> traverse render (elems arguments)++instance RenderIntrospection (FieldDefinition IN) where+  render FieldDefinition {..} =+    pure $+      mkObject+        "__InputValue"+        [ renderName fieldName,+          description fieldDescription,+          type' fieldType,+          defaultValue fieldType (fmap defaultInputValue fieldContent)+        ]++instance RenderIntrospection DataEnumValue where+  render DataEnumValue {enumName, enumDescription, enumDirectives} =+    pure $ mkObject "__Field" $+      [ renderName enumName,+        description enumDescription       ]+        <> renderDeprecated enumDirectives +instance RenderIntrospection TypeRef where+  render TypeRef {typeConName, typeWrappers} = do+    kind <- lookupKind typeConName+    let currentType = mkType kind typeConName Nothing []+    pure $ foldr wrap currentType (toGQLWrapper typeWrappers)+    where+      wrap :: Monad m => DataTypeWrapper -> ResModel QUERY e m -> ResModel QUERY e m+      wrap wrapper contentType =+        mkObject+          "__Type"+          [ renderKind (wrapperKind wrapper),+            ("ofType", pure contentType)+          ]+      wrapperKind ListType = LIST+      wrapperKind NonNullType = NON_NULL+ interfacePossibleTypes ::   (Monad m) =>-  Schema ->   TypeName ->-  Resolver QUERY e m [ResModel QUERY e m]-interfacePossibleTypes schema interfaceName = sequence $ concatMap implements (elems schema)+  Resolver QUERY e m (ResModel QUERY e m)+interfacePossibleTypes interfaceName =+  mkList+    <$> ( getSchema+            >>= sequence+              . concatMap implements+              . elems+        )   where     implements typeDef@TypeDefinition {typeContent = DataObject {objectImplements}, ..}-      | interfaceName `elem` objectImplements = [render typeDef schema]+      | interfaceName `elem` objectImplements = [render typeDef]     implements _ = [] -createEnumValue :: Monad m => DataEnumValue -> ResModel QUERY e m-createEnumValue DataEnumValue {enumName, enumMeta} =-  mkObject "__Field" $-    [ renderName enumName,-      description enumMeta-    ]-      <> renderDeprecated enumMeta- renderDeprecated ::   (Monad m) =>-  Maybe Meta ->+  Directives VALID ->   [(FieldName, Resolver QUERY e m (ResModel QUERY e m))]-renderDeprecated meta =-  [ ("isDeprecated", pure $ mkBoolean (isJust $ meta >>= lookupDeprecated)),-    ("deprecationReason", opt (pure . mkString) (meta >>= lookupDeprecated >>= lookupDeprecatedReason))+renderDeprecated dirs =+  [ ("isDeprecated", pure $ mkBoolean (isJust $ lookupDeprecated dirs)),+    ("deprecationReason", opt (pure . mkString) (lookupDeprecated dirs >>= lookupDeprecatedReason))   ] -description :: Monad m => Maybe Meta -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))-description enumMeta = renderDescription (enumMeta >>= metaDescription)--renderDescription :: Monad m => Maybe Description -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))-renderDescription desc = ("description", opt (pure . mkString) desc)--renderArguments :: (Monad m) => ArgumentsDefinition -> Schema -> Resolver QUERY e m [ResModel QUERY e m]-renderArguments ArgumentsDefinition {arguments} lib = traverse (`renderinputValue` lib) $ elems arguments-renderArguments NoArguments _ = pure []--instance RenderSchema (FieldDefinition cat) where-  render field@FieldDefinition {fieldName, fieldType = TypeRef {typeConName}, fieldArgs, fieldMeta} lib =-    do-      kind <- renderTypeKind <$> lookupKind typeConName lib-      pure-        $ mkObject "__Field"-        $ [ renderFieldName fieldName,-            description fieldMeta,-            ("args", mkList <$> renderArguments fieldArgs lib),-            ("type", pure (withTypeWrapper field $ createType kind typeConName Nothing $ Just []))-          ]-          <> renderDeprecated fieldMeta--renderTypeKind :: DataTypeKind -> TypeKind-renderTypeKind KindScalar = SCALAR-renderTypeKind (KindObject _) = OBJECT-renderTypeKind KindUnion = UNION-renderTypeKind KindInputUnion = INPUT_OBJECT-renderTypeKind KindEnum = ENUM-renderTypeKind KindInputObject = INPUT_OBJECT-renderTypeKind KindList = LIST-renderTypeKind KindNonNull = NON_NULL-renderTypeKind KindInterface = INTERFACE--lookupKind :: (Monad m) => TypeName -> Result e m DataTypeKind-lookupKind name schema = kindOf <$> selectBy ("Kind Not Found: " <> msg name) name schema--renderinputValue ::-  (Monad m) =>-  FieldDefinition IN ->-  Result e m (ResModel QUERY e m)-renderinputValue input = fmap (createInputValueWith (fieldName input) (fieldMeta input)) . createInputObjectType input+description :: Monad m => Maybe Description -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))+description desc = ("description", opt render desc) -createInputObjectType ::-  (Monad m) => FieldDefinition IN -> Result e m (ResModel QUERY e m)-createInputObjectType field@FieldDefinition {fieldType = TypeRef {typeConName}} lib =-  do-    kind <- renderTypeKind <$> lookupKind typeConName lib-    pure $ withTypeWrapper field $ createType kind typeConName Nothing $ Just []+lookupKind :: (Monad m) => TypeName -> Result e m TypeKind+lookupKind = fmap (renderTypeKind . kindOf) . selectType -renderInputUnion ::-  (Monad m) =>-  (TypeName, Maybe Meta, DataInputUnion) ->-  Result e m (ResModel QUERY e m)-renderInputUnion (key, meta, fields) lib =-  createInputObject key meta-    <$> traverse-      createField-      (createInputUnionFields key $ map fst $ filter snd fields)-  where-    createField field =-      createInputValueWith (fieldName field) Nothing <$> createInputObjectType field lib+renderTypeKind :: AST.TypeKind -> TypeKind+renderTypeKind AST.KindScalar = SCALAR+renderTypeKind (AST.KindObject _) = OBJECT+renderTypeKind AST.KindUnion = UNION+renderTypeKind AST.KindInputUnion = INPUT_OBJECT+renderTypeKind AST.KindEnum = ENUM+renderTypeKind AST.KindInputObject = INPUT_OBJECT+renderTypeKind AST.KindList = LIST+renderTypeKind AST.KindNonNull = NON_NULL+renderTypeKind AST.KindInterface = INTERFACE -createLeafType ::-  Monad m =>+mkType ::+  (Monad m, RenderIntrospection name) =>   TypeKind ->-  TypeName ->-  Maybe Meta ->-  Maybe [ResModel QUERY e m] ->+  name ->+  Maybe Description ->+  [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] ->   ResModel QUERY e m-createLeafType kind name meta enums =-  mkObject-    "__Type"-    [ renderKind kind,-      renderName name,-      description meta,-      ("enumValues", optList enums)-    ]--typeFromUnion :: Monad m => Schema -> (TypeName, Maybe Meta, DataUnion) -> ResModel QUERY e m-typeFromUnion schema (name, typeMeta, typeContent) =+mkType kind name desc etc =   mkObject     "__Type"-    [ renderKind UNION,-      renderName name,-      description typeMeta,-      ("possibleTypes", mkList <$> traverse (unionPossibleType schema) typeContent)-    ]--unionPossibleType :: Monad m => Schema -> TypeName -> Resolver QUERY e m (ResModel QUERY e m)-unionPossibleType schema name =-  selectBy (" INTERNAL: INTROSPECTION Type not Found: \"" <> msg name <> "\"") name schema-    >>= (`render` schema)+    ( [ renderKind kind,+        renderName name,+        description desc+      ]+        <> etc+    )  createObjectType ::-  Monad m => TypeName -> Maybe Meta -> [TypeName] -> FieldsDefinition OUT -> Schema -> ResModel QUERY e m-createObjectType name meta interfaces fields schema =-  mkObject-    "__Type"-    [ renderKind OBJECT,-      renderName name,-      description meta,-      ("fields", mkList <$> renderFields schema fields),-      ("interfaces", mkList <$> traverse (implementedInterface schema) interfaces)-    ]+  Monad m => TypeName -> Maybe Description -> [TypeName] -> FieldsDefinition OUT -> ResModel QUERY e m+createObjectType name desc interfaces fields =+  mkType OBJECT name desc [("fields", render fields), ("interfaces", mkList <$> traverse implementedInterface interfaces)]  implementedInterface ::   (Monad m) =>-  Schema ->   TypeName ->   Resolver QUERY e m (ResModel QUERY e m)-implementedInterface schema name =-  selectBy ("INTERNAL: cant found  Interface " <> msg name) name schema-    >>= __render+implementedInterface name =+  selectType name+    >>= renderContent   where-    __render typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef schema-    __render _ = failure ("Type " <> msg name <> " must be an Interface" :: Message)--optList :: Monad m => Maybe [ResModel QUERY e m] -> Resolver QUERY e m (ResModel QUERY e m)-optList = pure . maybe mkNull mkList--createInputObject ::-  Monad m => TypeName -> Maybe Meta -> [ResModel QUERY e m] -> ResModel QUERY e m-createInputObject name meta fields =-  mkObject-    "__Type"-    [ renderKind INPUT_OBJECT,-      renderName name,-      description meta,-      ("inputFields", pure $ mkList fields)-    ]--createType ::-  Monad m =>-  TypeKind ->-  TypeName ->-  Maybe Meta ->-  Maybe [ResModel QUERY e m] ->-  ResModel QUERY e m-createType kind name desc fields =-  mkObject-    "__Type"-    [ renderKind kind,-      renderName name,-      description desc,-      ("fields", pure $ maybe mkNull mkList fields),-      ("enumValues", pure $ mkList [])-    ]+    renderContent typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef+    renderContent _ = failure ("Type " <> msg name <> " must be an Interface" :: Message)  opt :: Monad m => (a -> Resolver QUERY e m (ResModel QUERY e m)) -> Maybe a -> Resolver QUERY e m (ResModel QUERY e m) opt f (Just x) = f x opt _ Nothing = pure mkNull -renderName :: Monad m => TypeName -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))-renderName = ("name",) . pure . mkString . readTypeName--renderFieldName :: Monad m => FieldName -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))-renderFieldName (FieldName name) = ("name", pure $ mkString name)+renderName ::+  ( RenderIntrospection name,+    Monad m+  ) =>+  name ->+  (FieldName, Resolver QUERY e m (ResModel QUERY e m))+renderName = ("name",) . render  renderKind :: Monad m => TypeKind -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))-renderKind = ("kind",) . pure . mkString . pack . show+renderKind = ("kind",) . render -withTypeWrapper :: Monad m => FieldDefinition cat -> ResModel QUERY e m -> ResModel QUERY e m-withTypeWrapper FieldDefinition {fieldType = TypeRef {typeWrappers}} typ =-  foldr wrapAs typ (toGQLWrapper typeWrappers)+type' :: Monad m => TypeRef -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))+type' ref = ("type", render ref) -wrapAs :: Monad m => DataTypeWrapper -> ResModel QUERY e m -> ResModel QUERY e m-wrapAs wrapper contentType =-  mkObject-    "__Type"-    [ renderKind (kind wrapper),-      ("ofType", pure contentType)-    ]-  where-    kind ListType = LIST-    kind NonNullType = NON_NULL+defaultValue ::+  Monad m =>+  TypeRef ->+  Maybe (Value RESOLVED) ->+  ( FieldName,+    Resolver QUERY e m (ResModel QUERY e m)+  )+defaultValue+  typeRef+  value =+    ( "defaultValue",+      opt+        ( fmap+            (mkString . GQL.render)+            . fulfill typeRef+            . Just+        )+        value+    ) -createInputValueWith ::-  Monad m => FieldName -> Maybe Meta -> ResModel QUERY e m -> ResModel QUERY e m-createInputValueWith name meta ivType =-  mkObject-    "__InputValue"-    [ renderFieldName name,-      description meta,-      ("type", pure ivType)-    ]+fulfill ::+  WithSchema m =>+  TypeRef ->+  Maybe (Value RESOLVED) ->+  m (Value RESOLVED)+fulfill TypeRef {typeConName} (Just (Object fields)) =+  selectType typeConName+    >>= \case+      TypeDefinition+        { typeContent =+            DataInputObject {inputObjectFields}+        } ->+          Object+            <$> ( traverse+                    (handleField fields)+                    (elems inputObjectFields)+                    >>= fromElems+                )+      _ -> failure (msg typeConName <> "is not must be Object")+fulfill typeRef (Just (List values)) =+  List <$> traverse (fulfill typeRef . Just) values+fulfill _ (Just v) = pure v+fulfill _ Nothing = pure Null++handleField ::+  WithSchema m =>+  Object RESOLVED ->+  FieldDefinition IN ->+  m (ObjectEntry RESOLVED)+handleField+  fields+  FieldDefinition+    { fieldName,+      fieldType,+      fieldContent = x+    } =+    ObjectEntry fieldName+      <$> fulfill+        fieldType+        ( selectOr+            (fmap defaultInputValue x)+            (Just . entryValue)+            fieldName+            fields+        )

@@ -0,0 +1,43 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Schema.DSL (dsl) where++import Data.Morpheus.Error+  ( gqlWarnings,+    renderGQLErrors,+  )+import Data.Morpheus.Parsing.Document.TypeSystem (parseSchema)+import Data.Morpheus.Types.Internal.AST (ANY, TypeDefinition)+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+    Result (..),+  )+import Data.Text+  ( Text,+    pack,+  )+import Language.Haskell.TH+import Language.Haskell.TH.Quote++dsl :: QuasiQuoter+dsl =+  QuasiQuoter+    { quoteExp = dslExpression . pack,+      quotePat = notHandled "Patterns",+      quoteType = notHandled "Types",+      quoteDec = notHandled "Declarations"+    }+  where+    notHandled things =+      error $ things ++ " are not supported by the GraphQL QuasiQuoter"++dslExpression :: Text -> Q Exp+dslExpression doc = case (parseSchema doc :: Eventless [TypeDefinition ANY]) of+  Failure errors -> fail (renderGQLErrors errors)+  Success {result, warnings} ->+    gqlWarnings warnings >> [|result|]

@@ -10,7 +10,7 @@     DirectiveDefinition (..),     DirectiveLocation (..),     TypeWrapper (..),-    createField,+    mkField,   )  defaultDirectives :: [DirectiveDefinition]@@ -33,12 +33,11 @@         directiveDefinitionLocations = [FIELD_DEFINITION, ENUM_VALUE],         directiveDefinitionArgs =           singleton $-            createField-              NoArguments+            mkField               "reason"               ([TypeMaybe], "String")       }   ]  argumentsIf :: ArgumentsDefinition-argumentsIf = singleton $ createField NoArguments "if" ([], "Boolean")+argumentsIf = singleton $ mkField "if" ([], "Boolean")

@@ -10,6 +10,7 @@  module Data.Morpheus.Schema.Schema   ( withSystemTypes,+    systemTypes,   ) where @@ -19,10 +20,9 @@   ( (<:>),     singleton,   )-import Data.Morpheus.QuasiQuoter (dsl)+import Data.Morpheus.Schema.DSL (dsl) import Data.Morpheus.Types.Internal.AST   ( ANY,-    ArgumentsDefinition (..),     DataFingerprint (..),     FieldsDefinition,     Message,@@ -33,9 +33,10 @@     TypeUpdater,     TypeWrapper (..),     createArgument,-    createField,     insertType,     internalFingerprint,+    mkField,+    mkObjectField,     unsafeFromFields,   ) import Data.Morpheus.Types.Internal.Resolving@@ -49,18 +50,17 @@       fs <- fields <:> hiddenFields       pure $ s {query = q {typeContent = DataObject inter fs}}   )-    >>= (`resolveUpdates` map (insertType . internalType) schemaTypes)+    >>= (`resolveUpdates` map (insertType . internalType) systemTypes) withSystemTypes _ = failure ("Query must be an Object Type" :: Message)  hiddenFields :: FieldsDefinition OUT hiddenFields =   unsafeFromFields-    [ createField+    [ mkObjectField         (singleton (createArgument "name" ([], "String")))         "__type"         ([TypeMaybe], "__Type"),-      createField-        NoArguments+      mkField         "__schema"         ([], "__Schema")     ]@@ -72,8 +72,8 @@     } =     tyDef {typeFingerprint = internalFingerprint name xs} -schemaTypes :: [TypeDefinition ANY]-schemaTypes =+systemTypes :: [TypeDefinition ANY]+systemTypes =   [dsl|  # default scalars

@@ -11,7 +11,6 @@ where  -- MORPHEUS- import Data.Morpheus.Internal.Utils   ( (<:>),     elems,@@ -51,28 +50,27 @@  resolveTypes ::   Monad m => Schema -> Resolver QUERY e m (ResModel QUERY e m)-resolveTypes schema = mkList <$> traverse (`render` schema) (elems schema)+resolveTypes schema = mkList <$> traverse render (elems schema) -buildSchemaLinkType ::-  Monad m => Maybe (TypeDefinition OUT) -> Schema -> ResModel QUERY e m-buildSchemaLinkType (Just TypeDefinition {typeName}) = createObjectType typeName Nothing [] empty-buildSchemaLinkType Nothing = const mkNull+renderOperation ::+  Monad m => Maybe (TypeDefinition OUT) -> Resolver QUERY e m (ResModel QUERY e m)+renderOperation (Just TypeDefinition {typeName}) = pure $ createObjectType typeName Nothing [] empty+renderOperation Nothing = pure mkNull  findType ::   Monad m =>   TypeName ->   Schema ->   Resolver QUERY e m (ResModel QUERY e m)-findType name schema = selectOr (pure mkNull) (`render` schema) name schema+findType = selectOr (pure mkNull) render  renderDirectives ::   Monad m =>-  Schema ->   Resolver QUERY e m (ResModel QUERY e m)-renderDirectives schema =+renderDirectives =   mkList     <$> traverse-      (`render` schema)+      render       defaultDirectives  schemaResolver ::@@ -84,10 +82,10 @@     mkObject       "__Schema"       [ ("types", resolveTypes schema),-        ("queryType", pure $ buildSchemaLinkType (Just query) schema),-        ("mutationType", pure $ buildSchemaLinkType mutation schema),-        ("subscriptionType", pure $ buildSchemaLinkType subscription schema),-        ("directives", renderDirectives schema)+        ("queryType", renderOperation (Just query)),+        ("mutationType", renderOperation mutation),+        ("subscriptionType", renderOperation subscription),+        ("directives", renderDirectives)       ]  schemaAPI :: Monad m => Schema -> ResModel QUERY e m

@@ -0,0 +1,85 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Morpheus.Types.GQLScalar+  ( GQLScalar (..),+    toScalar,+    scalarToJSON,+    scalarFromJSON,+  )+where++import Control.Monad.Fail (MonadFail)+import qualified Data.Aeson as A+import Data.Morpheus.Types.Internal.AST+  ( ScalarDefinition (..),+    ScalarValue (..),+    ValidValue,+    Value (..),+    replaceValue,+  )+import Data.Proxy (Proxy (..))+import Data.Text (Text, unpack)++toScalar :: ValidValue -> Either Text ScalarValue+toScalar (Scalar x) = pure x+toScalar _ = Left ""++-- | GraphQL Scalar+--+-- 'parseValue' and 'serialize' should be provided for every instances manually+class GQLScalar a where+  -- | value parsing and validating+  --+  -- for exhaustive pattern matching  should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean'+  --+  -- invalid values can be reported with 'Left' constructor :+  --+  -- @+  --   parseValue String _ = Left "" -- without error message+  --   -- or+  --   parseValue String _ = Left "Error Message"+  -- @+  parseValue :: ScalarValue -> Either Text a++  -- | serialization of haskell type into scalar value+  serialize :: a -> ScalarValue++  scalarValidator :: Proxy a -> ScalarDefinition+  scalarValidator _ = ScalarDefinition {validateValue = validator}+    where+      validator value = do+        scalarValue' <- toScalar value+        (_ :: a) <- parseValue scalarValue'+        return value++instance GQLScalar Text where+  parseValue (String x) = pure x+  parseValue _ = Left ""+  serialize = String++instance GQLScalar Bool where+  parseValue (Boolean x) = pure x+  parseValue _ = Left ""+  serialize = Boolean++instance GQLScalar Int where+  parseValue (Int x) = pure x+  parseValue _ = Left ""+  serialize = Int++instance GQLScalar Float where+  parseValue (Float x) = pure x+  parseValue (Int x) = pure $ fromInteger $ toInteger x+  parseValue _ = Left ""+  serialize = Float++scalarToJSON :: GQLScalar a => a -> A.Value+scalarToJSON = A.toJSON . serialize++scalarFromJSON :: (Monad m, MonadFail m) => GQLScalar a => A.Value -> m a+scalarFromJSON x = case replaceValue x of+  Scalar value -> either (fail . unpack) pure (parseValue value)+  _ -> fail "input must be scalar value"

@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Types.ID+  ( ID (..),+  )+where++import Data.Aeson (FromJSON (..), ToJSON (..))+import Data.Morpheus.Types.GQLScalar+  ( GQLScalar (..),+    scalarFromJSON,+    scalarToJSON,+  )+import Data.Morpheus.Types.Internal.AST+  ( ScalarValue (..),+  )+import Data.Text+  ( Text,+    pack,+  )+import GHC.Generics (Generic)++-- | default GraphQL type,+-- parses only 'String' and 'Int' values,+-- serialized always as 'String'+newtype ID = ID+  { unpackID :: Text+  }+  deriving (Show, Generic)++instance GQLScalar ID where+  parseValue (Int x) = return (ID $ pack $ show x)+  parseValue (String x) = return (ID x)+  parseValue _ = Left ""+  serialize (ID x) = String x++instance ToJSON ID where+  toJSON = scalarToJSON++instance FromJSON ID where+  parseJSON = scalarFromJSON

@@ -61,7 +61,7 @@     TypeDefinition (..),     Schema (..),     DataTypeWrapper (..),-    DataTypeKind (..),+    TypeKind (..),     DataFingerprint (..),     TypeWrapper (..),     TypeRef (..),@@ -70,12 +70,9 @@     QUERY,     MUTATION,     SUBSCRIPTION,-    Meta (..),     Directive (..),     TypeUpdater,-    TypeD (..),     ConsD (..),-    GQLTypeD (..),     TypeCategory,     DataInputUnion,     VariableContent (..),@@ -110,9 +107,7 @@     insertType,     lookupDeprecated,     lookupDeprecatedReason,-    hasArguments,     lookupWith,-    typeFromScalar,     -- Temaplate Haskell     hsTypeName,     -- LOCAL@@ -142,8 +137,7 @@     toFieldName,     TypeNameRef (..),     isEnum,-    Fields,-    argumentsToFields,+    Fields (..),     fieldsToArguments,     mkCons,     mkConsEnum,@@ -151,16 +145,25 @@     DirectiveDefinitions,     DirectiveDefinition (..),     DirectiveLocation (..),+    FieldContent (..),+    fieldContentArgs,+    mkField,+    TypeNameTH (..),+    isOutput,+    mkObjectField,+    UnionMember (..),+    mkUnionMember,   ) where  import Data.HashMap.Lazy (HashMap) -- Morpheus import Data.Morpheus.Types.Internal.AST.Base-import Data.Morpheus.Types.Internal.AST.Data+import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..)) import Data.Morpheus.Types.Internal.AST.OrderedMap import Data.Morpheus.Types.Internal.AST.Selection import Data.Morpheus.Types.Internal.AST.TH+import Data.Morpheus.Types.Internal.AST.TypeSystem import Data.Morpheus.Types.Internal.AST.Value import Language.Haskell.TH.Syntax (Lift) 

@@ -26,7 +26,7 @@     QUERY,     MUTATION,     SUBSCRIPTION,-    DataTypeKind (..),+    TypeKind (..),     DataFingerprint (..),     DataTypeWrapper (..),     Token,@@ -43,7 +43,6 @@     isInput,     isNullableWrapper,     sysFields,-    typeFromScalar,     hsTypeName,     toOperationType,     splitDuplicates,@@ -60,6 +59,7 @@     TypeNameRef (..),     convertToJSONName,     convertToHaskellName,+    isOutput,   ) where @@ -247,7 +247,7 @@  -- Kind ------------------------------------------------------------------------------------data DataTypeKind+data TypeKind   = KindScalar   | KindObject (Maybe OperationType)   | KindUnion@@ -259,22 +259,28 @@   | KindInterface   deriving (Eq, Show, Lift) -isSubscription :: DataTypeKind -> Bool+isSubscription :: TypeKind -> Bool isSubscription (KindObject (Just Subscription)) = True isSubscription _ = False -isOutputObject :: DataTypeKind -> Bool+isOutputObject :: TypeKind -> Bool isOutputObject (KindObject _) = True isOutputObject KindInterface = True isOutputObject _ = False -isObject :: DataTypeKind -> Bool+isOutput :: TypeKind -> Bool+isOutput (KindObject _) = True+isOutput KindUnion = True+isOutput KindInterface = True+isOutput _ = False++isObject :: TypeKind -> Bool isObject (KindObject _) = True isObject KindInputObject = True isObject KindInterface = True isObject _ = False -isInput :: DataTypeKind -> Bool+isInput :: TypeKind -> Bool isInput KindInputObject = True isInput _ = False @@ -344,14 +350,6 @@  sysFields :: [FieldName] sysFields = ["__typename", "__schema", "__type"]--typeFromScalar :: TypeName -> TypeName-typeFromScalar "Boolean" = "Bool"-typeFromScalar "Int" = "Int"-typeFromScalar "Float" = "Float"-typeFromScalar "String" = "Text"-typeFromScalar "ID" = "ID"-typeFromScalar _ = "ScalarValue"  hsTypeName :: TypeName -> TypeName hsTypeName "String" = "Text"

@@ -1,765 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Data.Morpheus.Types.Internal.AST.Data-  ( Arguments,-    ScalarDefinition (..),-    DataEnum,-    FieldsDefinition,-    ArgumentDefinition,-    DataUnion,-    ArgumentsDefinition (..),-    FieldDefinition (..),-    InputFieldsDefinition,-    TypeContent (..),-    TypeDefinition (..),-    Schema (..),-    DataEnumValue (..),-    TypeLib,-    Meta (..),-    Directive (..),-    TypeUpdater,-    TypeCategory,-    DataInputUnion,-    Argument (..),-    Fields,-    createField,-    createArgument,-    createEnumType,-    createScalarType,-    createType,-    createUnionType,-    createAlias,-    createInputUnionFields,-    createEnumValue,-    defineType,-    isTypeDefined,-    initTypeLib,-    isFieldNullable,-    insertType,-    fieldVisibility,-    kindOf,-    toNullableField,-    toListField,-    isEntNode,-    lookupDeprecated,-    lookupDeprecatedReason,-    lookupWith,-    hasArguments,-    unsafeFromFields,-    __inputname,-    updateSchema,-    OUT,-    IN,-    ANY,-    FromAny (..),-    ToAny (..),-    DirectiveDefinitions,-    DirectiveDefinition (..),-    Directives,-    argumentsToFields,-    fieldsToArguments,-    DirectiveLocation (..),-  )-where--import Data.HashMap.Lazy-  ( HashMap,-    union,-  )-import qualified Data.HashMap.Lazy as HM-import Data.List (find)--- MORPHEUS--import Data.Morpheus.Error (globalErrorMessage)-import Data.Morpheus.Error.NameCollision-  ( NameCollision (..),-  )-import Data.Morpheus.Error.Schema (nameCollisionError)-import Data.Morpheus.Internal.Utils-  ( Collection (..),-    KeyOf (..),-    Listable (..),-    Merge (..),-    Selectable (..),-    elems,-  )-import Data.Morpheus.Rendering.RenderGQL-  ( RenderGQL (..),-    renderIndent,-    renderObject,-  )-import Data.Morpheus.Types.Internal.AST.Base-  ( DataFingerprint (..),-    DataTypeKind (..),-    Description,-    FieldName,-    FieldName (..),-    GQLError (..),-    Msg (..),-    Position,-    Stage,-    TRUE,-    Token,-    TypeName,-    TypeRef (..),-    TypeWrapper (..),-    VALID,-    isNullable,-    isSystemTypeName,-    msg,-    sysFields,-    toFieldName,-    toOperationType,-  )-import Data.Morpheus.Types.Internal.AST.OrderedMap-  ( OrderedMap,-    unsafeFromValues,-  )-import Data.Morpheus.Types.Internal.AST.Value-  ( ScalarValue (..),-    ValidValue,-    Value (..),-  )-import Data.Morpheus.Types.Internal.Resolving.Core-  ( Failure (..),-    LibUpdater,-    resolveUpdates,-  )-import Data.Semigroup ((<>), Semigroup (..))-import Data.Text (intercalate)-import Instances.TH.Lift ()-import Language.Haskell.TH.Syntax (Lift (..))--type DataEnum = [DataEnumValue]--type DataUnion = [TypeName]--type DataInputUnion = [(TypeName, Bool)]---- scalar--------------------------------------------------------------------newtype ScalarDefinition = ScalarDefinition-  {validateValue :: ValidValue -> Either Token ValidValue}--instance Show ScalarDefinition where-  show _ = "ScalarDefinition"--instance Lift ScalarDefinition where-  lift _ = [|ScalarDefinition pure|]--data Argument (valid :: Stage) = Argument-  { argumentName :: FieldName,-    argumentValue :: Value valid,-    argumentPosition :: Position-  }-  deriving (Show, Eq, Lift)--instance KeyOf (Argument stage) where-  keyOf = argumentName--instance NameCollision (Argument s) where-  nameCollision _ Argument {argumentName, argumentPosition} =-    GQLError-      { message = "There can Be only One Argument Named " <> msg argumentName,-        locations = [argumentPosition]-      }--type Arguments s = OrderedMap FieldName (Argument s)---- directive--------------------------------------------------------------------data Directive (s :: Stage) = Directive-  { directiveName :: FieldName,-    directivePosition :: Position,-    directiveArgs :: Arguments s-  }-  deriving (Show, Lift, Eq)--instance KeyOf (Directive s) where-  keyOf = directiveName--type Directives s = [Directive s]--data DirectiveDefinition = DirectiveDefinition-  { directiveDefinitionName :: FieldName,-    directiveDefinitionDescription :: Maybe Description,-    directiveDefinitionLocations :: [DirectiveLocation],-    directiveDefinitionArgs :: ArgumentsDefinition-  }-  deriving (Show, Lift)--type DirectiveDefinitions = [DirectiveDefinition]--instance KeyOf DirectiveDefinition where-  keyOf = directiveDefinitionName--instance Selectable DirectiveDefinition ArgumentDefinition where-  selectOr fb f key DirectiveDefinition {directiveDefinitionArgs} =-    selectOr fb f key directiveDefinitionArgs--data DirectiveLocation-  = QUERY-  | MUTATION-  | SUBSCRIPTION-  | FIELD-  | FRAGMENT_DEFINITION-  | FRAGMENT_SPREAD-  | INLINE_FRAGMENT-  | SCHEMA-  | SCALAR-  | OBJECT-  | FIELD_DEFINITION-  | ARGUMENT_DEFINITION-  | INTERFACE-  | UNION-  | ENUM-  | ENUM_VALUE-  | INPUT_OBJECT-  | INPUT_FIELD_DEFINITION-  deriving (Show, Eq, Lift)--instance Msg DirectiveLocation where-  msg = msg . show--lookupDeprecated :: Meta -> Maybe (Directive VALID)-lookupDeprecated Meta {metaDirectives} = find isDeprecation metaDirectives-  where-    isDeprecation Directive {directiveName = "deprecated"} = True-    isDeprecation _ = False--lookupDeprecatedReason :: Directive VALID -> Maybe Description-lookupDeprecatedReason Directive {directiveArgs} =-  selectOr Nothing (Just . maybeString) "reason" directiveArgs-  where-    maybeString :: Argument VALID -> Description-    maybeString Argument {argumentValue = (Scalar (String x))} = x-    maybeString _ = "can't read deprecated Reason Value"---- META-data Meta = Meta-  { metaDescription :: Maybe Description,-    metaDirectives :: [Directive VALID]-  }-  deriving (Show, Lift)---- ENUM VALUE-data DataEnumValue = DataEnumValue-  { enumName :: TypeName,-    enumMeta :: Maybe Meta-  }-  deriving (Show, Lift)--instance RenderGQL DataEnumValue where-  render DataEnumValue {enumName} = render enumName---- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema------------------------------------------------------------------------------- SchemaDefinition :---    schema Directives[Const](opt) { RootOperationTypeDefinition(list)}------ RootOperationTypeDefinition :---    OperationType: NamedType--data Schema = Schema-  { types :: TypeLib,-    query :: TypeDefinition 'Out,-    mutation :: Maybe (TypeDefinition 'Out),-    subscription :: Maybe (TypeDefinition 'Out)-  }-  deriving (Show)--type TypeLib = HashMap TypeName (TypeDefinition ANY)--instance Selectable Schema (TypeDefinition ANY) where-  selectOr fb f name lib = maybe fb f (lookupDataType name lib)--instance Listable (TypeDefinition ANY) Schema where-  elems = HM.elems . typeRegister-  fromElems types = case popByKey "Query" types of-    (Nothing, _) -> failure (globalErrorMessage "INTERNAL: Query Not Defined")-    (Just query, lib1) -> do-      let (mutation, lib2) = popByKey "Mutation" lib1-      let (subscription, lib3) = popByKey "Subscription" lib2-      pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription}--initTypeLib :: TypeDefinition 'Out -> Schema-initTypeLib query =-  Schema-    { types = empty,-      query = query,-      mutation = Nothing,-      subscription = Nothing-    }--typeRegister :: Schema -> TypeLib-typeRegister Schema {types, query, mutation, subscription} =-  types-    `union` HM.fromList-      (concatMap fromOperation [Just query, mutation, subscription])--lookupDataType :: TypeName -> Schema -> Maybe (TypeDefinition ANY)-lookupDataType name = HM.lookup name . typeRegister--isTypeDefined :: TypeName -> Schema -> Maybe DataFingerprint-isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib---- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types----------------------------------------------------------------------------- TypeDefinition :---   ScalarTypeDefinition---   ObjectTypeDefinition---   InterfaceTypeDefinition---   UnionTypeDefinition---   EnumTypeDefinition---   InputObjectTypeDefinition--data TypeDefinition (a :: TypeCategory) = TypeDefinition-  { typeName :: TypeName,-    typeFingerprint :: DataFingerprint,-    typeMeta :: Maybe Meta,-    typeContent :: TypeContent TRUE a-  }-  deriving (Show, Lift)--instance KeyOf (TypeDefinition a) where-  type KEY (TypeDefinition a) = TypeName-  keyOf = typeName--data TypeCategory = In | Out | Any--type IN = 'In--type OUT = 'Out--type ANY = 'Any--class ToAny a where-  toAny :: a (k :: TypeCategory) -> a ANY--instance ToAny TypeDefinition where-  toAny TypeDefinition {typeContent, ..} = TypeDefinition {typeContent = toAny typeContent, ..}--instance ToAny (TypeContent TRUE) where-  toAny DataScalar {..} = DataScalar {..}-  toAny DataEnum {..} = DataEnum {..}-  toAny DataInputObject {..} = DataInputObject {..}-  toAny DataInputUnion {..} = DataInputUnion {..}-  toAny DataObject {..} = DataObject {..}-  toAny DataUnion {..} = DataUnion {..}-  toAny DataInterface {..} = DataInterface {..}--class FromAny a (k :: TypeCategory) where-  fromAny :: a ANY -> Maybe (a k)--instance (FromAny (TypeContent TRUE) a) => FromAny TypeDefinition a where-  fromAny TypeDefinition {typeContent, ..} = bla <$> fromAny typeContent-    where-      bla x = TypeDefinition {typeContent = x, ..}--instance FromAny (TypeContent TRUE) IN where-  fromAny DataScalar {..} = Just DataScalar {..}-  fromAny DataEnum {..} = Just DataEnum {..}-  fromAny DataInputObject {..} = Just DataInputObject {..}-  fromAny DataInputUnion {..} = Just DataInputUnion {..}-  fromAny _ = Nothing--instance FromAny (TypeContent TRUE) OUT where-  fromAny DataScalar {..} = Just DataScalar {..}-  fromAny DataEnum {..} = Just DataEnum {..}-  fromAny DataObject {..} = Just DataObject {..}-  fromAny DataUnion {..} = Just DataUnion {..}-  fromAny DataInterface {..} = Just DataInterface {..}-  fromAny _ = Nothing--class SelectType (c :: TypeCategory) (a :: TypeCategory) where-  type IsSelected c a :: Bool--instance SelectType ANY a where-  type IsSelected ANY a = TRUE--instance SelectType OUT OUT where-  type IsSelected OUT OUT = TRUE--instance SelectType IN IN where-  type IsSelected IN IN = TRUE--data TypeContent (b :: Bool) (a :: TypeCategory) where-  DataScalar ::-    { dataScalar :: ScalarDefinition-    } ->-    TypeContent TRUE a-  DataEnum ::-    { enumMembers :: DataEnum-    } ->-    TypeContent TRUE a-  DataInputObject ::-    { inputObjectFields :: FieldsDefinition IN-    } ->-    TypeContent (IsSelected a IN) a-  DataInputUnion ::-    { inputUnionMembers :: DataInputUnion-    } ->-    TypeContent (IsSelected a IN) a-  DataObject ::-    { objectImplements :: [TypeName],-      objectFields :: FieldsDefinition OUT-    } ->-    TypeContent (IsSelected a OUT) a-  DataUnion ::-    { unionMembers :: DataUnion-    } ->-    TypeContent (IsSelected a OUT) a-  DataInterface ::-    { interfaceFields :: FieldsDefinition OUT-    } ->-    TypeContent (IsSelected a OUT) a--deriving instance Show (TypeContent a b)--deriving instance Lift (TypeContent a b)--createType :: TypeName -> TypeContent TRUE a -> TypeDefinition a-createType typeName typeContent =-  TypeDefinition-    { typeName,-      typeMeta = Nothing,-      typeFingerprint = DataFingerprint typeName [],-      typeContent-    }--createScalarType :: TypeName -> TypeDefinition a-createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure)--createEnumType :: TypeName -> [TypeName] -> TypeDefinition a-createEnumType typeName typeData = createType typeName (DataEnum enumValues)-  where-    enumValues = map createEnumValue typeData--createEnumValue :: TypeName -> DataEnumValue-createEnumValue enumName = DataEnumValue {enumName, enumMeta = Nothing}--createUnionType :: TypeName -> [TypeName] -> TypeDefinition OUT-createUnionType typeName typeData = createType typeName (DataUnion typeData)--isEntNode :: TypeContent TRUE a -> Bool-isEntNode DataScalar {} = True-isEntNode DataEnum {} = True-isEntNode _ = False--kindOf :: TypeDefinition a -> DataTypeKind-kindOf TypeDefinition {typeName, typeContent} = __kind typeContent-  where-    __kind DataScalar {} = KindScalar-    __kind DataEnum {} = KindEnum-    __kind DataInputObject {} = KindInputObject-    __kind DataObject {} = KindObject (toOperationType typeName)-    __kind DataUnion {} = KindUnion-    __kind DataInputUnion {} = KindInputUnion-    __kind DataInterface {} = KindInterface--fromOperation :: Maybe (TypeDefinition OUT) -> [(TypeName, TypeDefinition ANY)]-fromOperation (Just datatype) = [(typeName datatype, toAny datatype)]-fromOperation Nothing = []--defineType :: TypeDefinition cat -> Schema -> Schema-defineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys, typeFingerprint} lib =-  lib {types = HM.insert name unionTags (HM.insert typeName (toAny dt) (types lib))}-  where-    name = typeName <> "Tags"-    unionTags =-      TypeDefinition-        { typeName = name,-          typeFingerprint,-          typeMeta = Nothing,-          typeContent = DataEnum $ map (createEnumValue . fst) enumKeys-        }-defineType datatype lib =-  lib {types = HM.insert (typeName datatype) (toAny datatype) (types lib)}--insertType ::-  TypeDefinition ANY ->-  TypeUpdater-insertType datatype@TypeDefinition {typeName} lib = case isTypeDefined typeName lib of-  Nothing -> resolveUpdates (defineType datatype lib) []-  Just fingerprint-    | fingerprint == typeFingerprint datatype -> return lib-    -- throw error if 2 different types has same name-    | otherwise -> failure $ nameCollisionError typeName--updateSchema ::-  TypeName ->-  DataFingerprint ->-  [TypeUpdater] ->-  (a -> TypeDefinition cat) ->-  a ->-  TypeUpdater-updateSchema name fingerprint stack f x lib =-  case isTypeDefined name lib of-    Nothing ->-      resolveUpdates-        (defineType (f x) lib)-        stack-    Just fingerprint' | fingerprint' == fingerprint -> return lib-    -- throw error if 2 different types has same name-    Just _ -> failure $ nameCollisionError name--lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a-lookupWith f key = find ((== key) . f)---- lookups and removes TypeDefinition from hashmap-popByKey :: TypeName -> [TypeDefinition ANY] -> (Maybe (TypeDefinition OUT), [TypeDefinition ANY])-popByKey name types = case lookupWith typeName name types of-  Just dt@TypeDefinition {typeContent = DataObject {}} ->-    (fromAny dt, filter ((/= name) . typeName) types)-  _ -> (Nothing, types)--newtype Fields def = Fields-  {unFields :: OrderedMap FieldName def}-  deriving-    ( Show,-      Lift,-      Functor,-      Foldable,-      Traversable-    )--deriving instance (KEY def ~ FieldName, KeyOf def) => Collection def (Fields def)--instance Merge (FieldsDefinition cat) where-  merge path (Fields x) (Fields y) = Fields <$> merge path x y--instance Selectable (Fields (FieldDefinition cat)) (FieldDefinition cat) where-  selectOr fb f name (Fields lib) = selectOr fb f name lib--unsafeFromFields :: [FieldDefinition cat] -> FieldsDefinition cat-unsafeFromFields = Fields . unsafeFromValues--argumentsToFields :: ArgumentsDefinition -> FieldsDefinition IN-argumentsToFields = Fields . arguments--fieldsToArguments :: FieldsDefinition IN -> ArgumentsDefinition-fieldsToArguments = ArgumentsDefinition Nothing . unFields--instance (KEY def ~ FieldName, KeyOf def, NameCollision def) => Listable def (Fields def) where-  fromElems = fmap Fields . fromElems-  elems = elems . unFields---- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects----------------------------------------------------------------------------------  ObjectTypeDefinition:---    Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt)------  ImplementsInterfaces---    implements &(opt) NamedType---    ImplementsInterfaces & NamedType------  FieldsDefinition---    { FieldDefinition(list) }----type FieldsDefinition cat = Fields (FieldDefinition cat)----  FieldDefinition---    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)----data FieldDefinition (cat :: TypeCategory) = FieldDefinition-  { fieldName :: FieldName,-    fieldArgs :: ArgumentsDefinition,-    fieldType :: TypeRef,-    fieldMeta :: Maybe Meta-  }-  deriving (Show, Lift)--instance KeyOf (FieldDefinition cat) where-  keyOf = fieldName--instance Selectable (FieldDefinition OUT) ArgumentDefinition where-  selectOr fb f key FieldDefinition {fieldArgs} = selectOr fb f key fieldArgs--instance NameCollision (FieldDefinition cat) where-  nameCollision name _ =-    GQLError-      { message = "There can Be only One field Named " <> msg name,-        locations = []-      }--instance RenderGQL (FieldDefinition cat) where-  render FieldDefinition {fieldName = FieldName name, fieldType, fieldArgs} =-    name <> render fieldArgs <> ": " <> render fieldType--instance RenderGQL (FieldsDefinition OUT) where-  render = renderObject render . ignoreHidden . elems--instance RenderGQL (FieldsDefinition IN) where-  render = renderObject render . ignoreHidden . elems--fieldVisibility :: FieldDefinition cat -> Bool-fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields--isFieldNullable :: FieldDefinition cat -> Bool-isFieldNullable = isNullable . fieldType--createField :: ArgumentsDefinition -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat-createField dataArguments fieldName (typeWrappers, typeConName) =-  FieldDefinition-    { fieldArgs = dataArguments,-      fieldName,-      fieldType = TypeRef {typeConName, typeWrappers, typeArgs = Nothing},-      fieldMeta = Nothing-    }--toNullableField :: FieldDefinition cat -> FieldDefinition cat-toNullableField dataField-  | isNullable (fieldType dataField) = dataField-  | otherwise = dataField {fieldType = nullable (fieldType dataField)}-  where-    nullable alias@TypeRef {typeWrappers} =-      alias {typeWrappers = TypeMaybe : typeWrappers}--toListField :: FieldDefinition cat -> FieldDefinition cat-toListField dataField = dataField {fieldType = listW (fieldType dataField)}-  where-    listW alias@TypeRef {typeWrappers} =-      alias {typeWrappers = TypeList : typeWrappers}---- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects------------------------------------------------------------------------------- InputObjectTypeDefinition--- Description(opt) input Name Directives(const,opt) InputFieldsDefinition(opt)------- InputFieldsDefinition--- { InputValueDefinition(list) }--type InputFieldsDefinition = Fields InputValueDefinition--type InputValueDefinition = FieldDefinition IN---- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments--------------------------------------------------------------------------------------------------- ArgumentsDefinition:---   (InputValueDefinition(list))--data ArgumentsDefinition-  = ArgumentsDefinition-      { argumentsTypename :: Maybe TypeName,-        arguments :: OrderedMap FieldName ArgumentDefinition-      }-  | NoArguments-  deriving (Show, Lift)--instance RenderGQL ArgumentsDefinition where-  render NoArguments = ""-  render arguments = "(" <> intercalate ", " (map render $ elems arguments) <> ")"--type ArgumentDefinition = FieldDefinition IN--instance Selectable ArgumentsDefinition ArgumentDefinition where-  selectOr fb _ _ NoArguments = fb-  selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args--instance Collection ArgumentDefinition ArgumentsDefinition where-  empty = ArgumentsDefinition Nothing empty-  singleton = ArgumentsDefinition Nothing . singleton--instance Listable ArgumentDefinition ArgumentsDefinition where-  elems NoArguments = []-  elems (ArgumentsDefinition _ args) = elems args-  fromElems [] = pure NoArguments-  fromElems args = ArgumentsDefinition Nothing <$> fromElems args--createArgument :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition IN-createArgument = createField NoArguments--hasArguments :: ArgumentsDefinition -> Bool-hasArguments NoArguments = False-hasArguments _ = True---- https://spec.graphql.org/June2018/#InputValueDefinition--- InputValueDefinition---   Description(opt) Name: TypeDefaultValue(opt) Directives[Const](opt)--- TODO: implement inputValue---- data InputValueDefinition = InputValueDefinition---   { inputValueName  :: FieldName---   , inputValueType  :: TypeRef---   , inputValueMeta  :: Maybe Meta---   } deriving (Show,Lift)--__inputname :: FieldName-__inputname = "inputname"--createInputUnionFields :: TypeName -> [TypeName] -> [FieldDefinition IN]-createInputUnionFields name members = fieldTag : map unionField members-  where-    fieldTag =-      FieldDefinition-        { fieldName = __inputname,-          fieldArgs = NoArguments,-          fieldType = createAlias (name <> "Tags"),-          fieldMeta = Nothing-        }-    unionField memberName =-      FieldDefinition-        { fieldArgs = NoArguments,-          fieldName = toFieldName memberName,-          fieldType =-            TypeRef-              { typeConName = memberName,-                typeWrappers = [TypeMaybe],-                typeArgs = Nothing-              },-          fieldMeta = Nothing-        }------- OTHER-----------------------------------------------------------------------------------------------------createAlias :: TypeName -> TypeRef-createAlias typeConName =-  TypeRef {typeConName, typeWrappers = [], typeArgs = Nothing}--type TypeUpdater = LibUpdater Schema--instance RenderGQL Schema where-  render schema = intercalate "\n\n" $ map render visibleTypes-    where-      visibleTypes = filter (not . isSystemTypeName . typeName) (elems schema)--instance RenderGQL (TypeDefinition a) where-  render TypeDefinition {typeName, typeContent} = __render typeContent-    where-      __render DataInterface {interfaceFields} = "interface " <> render typeName <> render interfaceFields-      __render DataScalar {} = "scalar " <> render typeName-      __render (DataEnum tags) = "enum " <> render typeName <> renderObject render tags-      __render (DataUnion members) =-        "union "-          <> render typeName-          <> " =\n    "-          <> intercalate ("\n" <> renderIndent <> "| ") (map render members)-      __render (DataInputObject fields) = "input " <> render typeName <> render fields-      __render (DataInputUnion members) = "input " <> render typeName <> render fieldsDef-        where-          fieldsDef = unsafeFromFields fields-          fields :: [FieldDefinition IN]-          fields = createInputUnionFields typeName (fst <$> members :: [TypeName])-      __render DataObject {objectFields} = "type " <> render typeName <> render objectFields--ignoreHidden :: [FieldDefinition cat] -> [FieldDefinition cat]-ignoreHidden = filter fieldVisibility

@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveLift #-}++module Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..)) where++import Data.Morpheus.Types.Internal.AST.Base (Msg (..))+import Language.Haskell.TH.Syntax (Lift)++data DirectiveLocation+  = QUERY+  | MUTATION+  | SUBSCRIPTION+  | FIELD+  | FRAGMENT_DEFINITION+  | FRAGMENT_SPREAD+  | INLINE_FRAGMENT+  | SCHEMA+  | SCALAR+  | OBJECT+  | FIELD_DEFINITION+  | ARGUMENT_DEFINITION+  | INTERFACE+  | UNION+  | ENUM+  | ENUM_VALUE+  | INPUT_OBJECT+  | INPUT_FIELD_DEFINITION+  deriving (Show, Eq, Lift)++instance Msg DirectiveLocation where+  msg = msg . show

@@ -48,10 +48,15 @@     where       ls = HM.toList x -instance Foldable (OrderedMap k) where-  foldMap f OrderedMap {mapEntries} = foldMap f mapEntries+instance (Eq k, Hashable k) => Foldable (OrderedMap k) where+  foldMap f = foldMap f . getElements -instance Traversable (OrderedMap k) where+getElements :: (Eq k, Hashable k) => OrderedMap k b -> [b]+getElements OrderedMap {mapKeys, mapEntries} = map takeValue mapKeys+  where+    takeValue key = fromMaybe (error "TODO: invalid Ordered Map") (key `HM.lookup` mapEntries)++instance (Eq k, Hashable k) => Traversable (OrderedMap k) where   traverse f (OrderedMap names values) = OrderedMap names <$> traverse f values  instance (KeyOf a, Hashable k, KEY a ~ k) => Collection a (OrderedMap k a) where@@ -66,9 +71,7 @@  instance (NameCollision a, Eq k, Hashable k, k ~ KEY a) => Listable a (OrderedMap k a) where   fromElems = safeFromList-  elems OrderedMap {mapKeys, mapEntries} = map takeValue mapKeys-    where-      takeValue key = fromMaybe (error "TODO: invalid Ordered Map") (key `HM.lookup` mapEntries)+  elems = getElements  safeFromList ::   ( Failure GQLErrors m,

@@ -58,18 +58,18 @@     msg,     readName,   )-import Data.Morpheus.Types.Internal.AST.Data-  ( Arguments,-    Directives,-    OUT,-    Schema (..),-    TypeDefinition (..),-  ) import Data.Morpheus.Types.Internal.AST.MergeSet   ( MergeSet,   ) import Data.Morpheus.Types.Internal.AST.OrderedMap   ( OrderedMap,+  )+import Data.Morpheus.Types.Internal.AST.TypeSystem+  ( Arguments,+    Directives,+    OUT,+    Schema (..),+    TypeDefinition (..),   ) import Data.Morpheus.Types.Internal.AST.Value   ( ResolvedValue,

@@ -1,31 +1,26 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}  module Data.Morpheus.Types.Internal.AST.TH-  ( TypeD (..),-    ConsD (..),+  ( ConsD (..),     mkCons,-    GQLTypeD (..),     isEnum,     mkConsEnum,+    TypeNameTH (..),   ) where  import Data.Morpheus.Internal.Utils (elems) import Data.Morpheus.Types.Internal.AST.Base-  ( DataTypeKind,-    FieldName,+  ( FieldName,     TypeName,     TypeRef (..),     hsTypeName,   )-import Data.Morpheus.Types.Internal.AST.Data-  ( ANY,-    DataEnumValue (..),+import Data.Morpheus.Types.Internal.AST.TypeSystem+  ( DataEnumValue (..),     FieldDefinition (..),     FieldsDefinition,-    Meta,-    TypeDefinition,   )  toHSFieldDefinition :: FieldDefinition cat -> FieldDefinition cat@@ -34,43 +29,29 @@     { fieldType = tyRef {typeConName = hsTypeName typeConName}     } --- Template Haskell Types--- Document-data GQLTypeD = GQLTypeD-  { typeD :: TypeD,-    typeArgD :: [TypeD],-    typeOriginal :: TypeDefinition ANY+data TypeNameTH = TypeNameTH+  { namespace :: [FieldName],+    typename :: TypeName   }   deriving (Show) ---- Core-data TypeD = TypeD-  { tName :: TypeName,-    tNamespace :: [FieldName],-    tCons :: [ConsD],-    tKind :: DataTypeKind,-    tMeta :: Maybe Meta-  }-  deriving (Show)+-- Template Haskell Types -data ConsD = ConsD+data ConsD cat = ConsD   { cName :: TypeName,-    cFields :: [FieldDefinition ANY]+    cFields :: [FieldDefinition cat]   }   deriving (Show) -mkCons :: TypeName -> FieldsDefinition cat -> ConsD+mkCons :: TypeName -> FieldsDefinition cat -> ConsD cat mkCons typename fields =   ConsD     { cName = hsTypeName typename,-      cFields = map (toHSFieldDefinition . mockFieldDefinition) (elems fields)+      cFields = map toHSFieldDefinition (elems fields)     } -isEnum :: [ConsD] -> Bool+isEnum :: [ConsD cat] -> Bool isEnum = all (null . cFields) -mockFieldDefinition :: FieldDefinition a -> FieldDefinition b-mockFieldDefinition FieldDefinition {..} = FieldDefinition {..}--mkConsEnum :: DataEnumValue -> ConsD+mkConsEnum :: DataEnumValue -> ConsD cat mkConsEnum DataEnumValue {enumName} = ConsD {cName = hsTypeName enumName, cFields = []}

@@ -0,0 +1,790 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Morpheus.Types.Internal.AST.TypeSystem+  ( Arguments,+    ScalarDefinition (..),+    DataEnum,+    FieldsDefinition,+    ArgumentDefinition,+    DataUnion,+    ArgumentsDefinition (..),+    FieldDefinition (..),+    InputFieldsDefinition,+    TypeContent (..),+    TypeDefinition (..),+    Schema (..),+    DataEnumValue (..),+    TypeLib,+    Directive (..),+    TypeUpdater,+    TypeCategory,+    DataInputUnion,+    Argument (..),+    Fields (..),+    createField,+    createArgument,+    createEnumType,+    createScalarType,+    createType,+    createUnionType,+    createAlias,+    createInputUnionFields,+    createEnumValue,+    defineType,+    isTypeDefined,+    initTypeLib,+    isFieldNullable,+    insertType,+    fieldVisibility,+    kindOf,+    toNullableField,+    toListField,+    isEntNode,+    lookupDeprecated,+    lookupDeprecatedReason,+    lookupWith,+    unsafeFromFields,+    __inputname,+    updateSchema,+    OUT,+    IN,+    ANY,+    FromAny (..),+    ToAny (..),+    DirectiveDefinitions,+    DirectiveDefinition (..),+    Directives,+    fieldsToArguments,+    FieldContent (..),+    fieldContentArgs,+    mkField,+    mkObjectField,+    UnionMember (..),+    mkUnionMember,+  )+where++import Data.HashMap.Lazy+  ( HashMap,+    union,+  )+import qualified Data.HashMap.Lazy as HM+import Data.List (find)+-- MORPHEUS++import Data.Morpheus.Error (globalErrorMessage)+import Data.Morpheus.Error.NameCollision+  ( NameCollision (..),+  )+import Data.Morpheus.Error.Schema (nameCollisionError)+import Data.Morpheus.Internal.Utils+  ( Collection (..),+    KeyOf (..),+    Listable (..),+    Merge (..),+    Selectable (..),+    elems,+  )+import Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+    renderIndent,+    renderObject,+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( DataFingerprint (..),+    Description,+    FALSE,+    FieldName,+    FieldName (..),+    GQLError (..),+    Msg (..),+    Position,+    RESOLVED,+    Stage,+    TRUE,+    Token,+    TypeKind (..),+    TypeName,+    TypeRef (..),+    TypeWrapper (..),+    VALID,+    isNullable,+    isSystemTypeName,+    msg,+    sysFields,+    toFieldName,+    toOperationType,+  )+import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation)+import Data.Morpheus.Types.Internal.AST.OrderedMap+  ( OrderedMap,+    unsafeFromValues,+  )+import Data.Morpheus.Types.Internal.AST.Value+  ( ScalarValue (..),+    ValidValue,+    Value (..),+  )+import Data.Morpheus.Types.Internal.Resolving.Core+  ( Failure (..),+    LibUpdater,+    resolveUpdates,+  )+import Data.Semigroup (Semigroup (..))+import Data.Text (intercalate)+import Instances.TH.Lift ()+import Language.Haskell.TH.Syntax (Lift (..))++type DataEnum = [DataEnumValue]++mkUnionMember :: TypeName -> UnionMember cat+mkUnionMember name = UnionMember name True++data UnionMember (cat :: TypeCategory) = UnionMember+  { memberName :: TypeName,+    visibility :: Bool+  }+  deriving (Show, Lift, Eq)++type DataUnion = [UnionMember OUT]++type DataInputUnion = [UnionMember IN]++instance RenderGQL (UnionMember cat) where+  render = render . memberName++-- scalar+------------------------------------------------------------------+newtype ScalarDefinition = ScalarDefinition+  {validateValue :: ValidValue -> Either Token ValidValue}++instance Show ScalarDefinition where+  show _ = "ScalarDefinition"++instance Lift ScalarDefinition where+  lift _ = [|ScalarDefinition pure|]++data Argument (valid :: Stage) = Argument+  { argumentName :: FieldName,+    argumentValue :: Value valid,+    argumentPosition :: Position+  }+  deriving (Show, Eq, Lift)++instance KeyOf (Argument stage) where+  keyOf = argumentName++instance NameCollision (Argument s) where+  nameCollision _ Argument {argumentName, argumentPosition} =+    GQLError+      { message = "There can Be only One Argument Named " <> msg argumentName,+        locations = [argumentPosition]+      }++type Arguments s = OrderedMap FieldName (Argument s)++-- directive+------------------------------------------------------------------+data Directive (s :: Stage) = Directive+  { directiveName :: FieldName,+    directivePosition :: Position,+    directiveArgs :: Arguments s+  }+  deriving (Show, Lift, Eq)++instance KeyOf (Directive s) where+  keyOf = directiveName++type Directives s = [Directive s]++data DirectiveDefinition = DirectiveDefinition+  { directiveDefinitionName :: FieldName,+    directiveDefinitionDescription :: Maybe Description,+    directiveDefinitionLocations :: [DirectiveLocation],+    directiveDefinitionArgs :: ArgumentsDefinition+  }+  deriving (Show, Lift)++type DirectiveDefinitions = [DirectiveDefinition]++instance KeyOf DirectiveDefinition where+  keyOf = directiveDefinitionName++instance Selectable DirectiveDefinition ArgumentDefinition where+  selectOr fb f key DirectiveDefinition {directiveDefinitionArgs} =+    selectOr fb f key directiveDefinitionArgs++lookupDeprecated :: [Directive VALID] -> Maybe (Directive VALID)+lookupDeprecated = find isDeprecation+  where+    isDeprecation Directive {directiveName = "deprecated"} = True+    isDeprecation _ = False++lookupDeprecatedReason :: Directive VALID -> Maybe Description+lookupDeprecatedReason Directive {directiveArgs} =+  selectOr Nothing (Just . maybeString) "reason" directiveArgs+  where+    maybeString :: Argument VALID -> Description+    maybeString Argument {argumentValue = (Scalar (String x))} = x+    maybeString _ = "can't read deprecated Reason Value"++-- ENUM VALUE+data DataEnumValue = DataEnumValue+  { enumName :: TypeName,+    enumDescription :: Maybe Description,+    enumDirectives :: [Directive VALID]+  }+  deriving (Show, Lift)++instance RenderGQL DataEnumValue where+  render DataEnumValue {enumName} = render enumName++-- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema+---------------------------------------------------------------------------+-- SchemaDefinition :+--    schema Directives[Const](opt) { RootOperationTypeDefinition(list)}+--+-- RootOperationTypeDefinition :+--    OperationType: NamedType++data Schema = Schema+  { types :: TypeLib,+    query :: TypeDefinition 'Out,+    mutation :: Maybe (TypeDefinition 'Out),+    subscription :: Maybe (TypeDefinition 'Out)+  }+  deriving (Show)++type TypeLib = HashMap TypeName (TypeDefinition ANY)++instance Selectable Schema (TypeDefinition ANY) where+  selectOr fb f name lib = maybe fb f (lookupDataType name lib)++instance Listable (TypeDefinition ANY) Schema where+  elems = HM.elems . typeRegister+  fromElems types = case popByKey "Query" types of+    (Nothing, _) -> failure (globalErrorMessage "INTERNAL: Query Not Defined")+    (Just query, lib1) -> do+      let (mutation, lib2) = popByKey "Mutation" lib1+      let (subscription, lib3) = popByKey "Subscription" lib2+      pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription}++initTypeLib :: TypeDefinition 'Out -> Schema+initTypeLib query =+  Schema+    { types = empty,+      query = query,+      mutation = Nothing,+      subscription = Nothing+    }++typeRegister :: Schema -> TypeLib+typeRegister Schema {types, query, mutation, subscription} =+  types+    `union` HM.fromList+      (concatMap fromOperation [Just query, mutation, subscription])++lookupDataType :: TypeName -> Schema -> Maybe (TypeDefinition ANY)+lookupDataType name = HM.lookup name . typeRegister++isTypeDefined :: TypeName -> Schema -> Maybe DataFingerprint+isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib++-- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types+-------------------------------------------------------------------------+-- TypeDefinition :+--   ScalarTypeDefinition+--   ObjectTypeDefinition+--   InterfaceTypeDefinition+--   UnionTypeDefinition+--   EnumTypeDefinition+--   InputObjectTypeDefinition++data TypeDefinition (a :: TypeCategory) = TypeDefinition+  { typeName :: TypeName,+    typeFingerprint :: DataFingerprint,+    typeDescription :: Maybe Description,+    typeDirectives :: Directives VALID,+    typeContent :: TypeContent TRUE a+  }+  deriving (Show, Lift)++instance KeyOf (TypeDefinition a) where+  type KEY (TypeDefinition a) = TypeName+  keyOf = typeName++data TypeCategory = In | Out | Any++type IN = 'In++type OUT = 'Out++type ANY = 'Any++class ToAny a where+  toAny :: a (k :: TypeCategory) -> a ANY++instance ToAny TypeDefinition where+  toAny TypeDefinition {typeContent, ..} = TypeDefinition {typeContent = toAny typeContent, ..}++instance ToAny (TypeContent TRUE) where+  toAny DataScalar {..} = DataScalar {..}+  toAny DataEnum {..} = DataEnum {..}+  toAny DataInputObject {..} = DataInputObject {..}+  toAny DataInputUnion {..} = DataInputUnion {..}+  toAny DataObject {..} = DataObject {..}+  toAny DataUnion {..} = DataUnion {..}+  toAny DataInterface {..} = DataInterface {..}++instance ToAny FieldDefinition where+  toAny FieldDefinition {fieldContent, ..} = FieldDefinition {fieldContent = toAny <$> fieldContent, ..}++instance ToAny (FieldContent TRUE) where+  toAny (FieldArgs x) = FieldArgs x+  toAny (DefaultInputValue x) = DefaultInputValue x++class FromAny a (k :: TypeCategory) where+  fromAny :: a ANY -> Maybe (a k)++instance (FromAny (TypeContent TRUE) a) => FromAny TypeDefinition a where+  fromAny TypeDefinition {typeContent, ..} = bla <$> fromAny typeContent+    where+      bla x = TypeDefinition {typeContent = x, ..}++instance FromAny (TypeContent TRUE) IN where+  fromAny DataScalar {..} = Just DataScalar {..}+  fromAny DataEnum {..} = Just DataEnum {..}+  fromAny DataInputObject {..} = Just DataInputObject {..}+  fromAny DataInputUnion {..} = Just DataInputUnion {..}+  fromAny _ = Nothing++instance FromAny (TypeContent TRUE) OUT where+  fromAny DataScalar {..} = Just DataScalar {..}+  fromAny DataEnum {..} = Just DataEnum {..}+  fromAny DataObject {..} = Just DataObject {..}+  fromAny DataUnion {..} = Just DataUnion {..}+  fromAny DataInterface {..} = Just DataInterface {..}+  fromAny _ = Nothing++type family IsSelected (c :: TypeCategory) (a :: TypeCategory) :: Bool++type instance IsSelected ANY a = TRUE++type instance IsSelected OUT OUT = TRUE++type instance IsSelected IN IN = TRUE++type instance IsSelected IN OUT = FALSE++type instance IsSelected OUT IN = FALSE++type instance IsSelected a ANY = TRUE++data TypeContent (b :: Bool) (a :: TypeCategory) where+  DataScalar ::+    { dataScalar :: ScalarDefinition+    } ->+    TypeContent TRUE a+  DataEnum ::+    { enumMembers :: DataEnum+    } ->+    TypeContent TRUE a+  DataInputObject ::+    { inputObjectFields :: FieldsDefinition IN+    } ->+    TypeContent (IsSelected a IN) a+  DataInputUnion ::+    { inputUnionMembers :: DataInputUnion+    } ->+    TypeContent (IsSelected a IN) a+  DataObject ::+    { objectImplements :: [TypeName],+      objectFields :: FieldsDefinition OUT+    } ->+    TypeContent (IsSelected a OUT) a+  DataUnion ::+    { unionMembers :: DataUnion+    } ->+    TypeContent (IsSelected a OUT) a+  DataInterface ::+    { interfaceFields :: FieldsDefinition OUT+    } ->+    TypeContent (IsSelected a OUT) a++deriving instance Show (TypeContent a b)++deriving instance Lift (TypeContent a b)++createType :: TypeName -> TypeContent TRUE a -> TypeDefinition a+createType typeName typeContent =+  TypeDefinition+    { typeName,+      typeDescription = Nothing,+      typeFingerprint = DataFingerprint typeName [],+      typeDirectives = [],+      typeContent+    }++createScalarType :: TypeName -> TypeDefinition a+createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure)++createEnumType :: TypeName -> [TypeName] -> TypeDefinition a+createEnumType typeName typeData = createType typeName (DataEnum enumValues)+  where+    enumValues = map createEnumValue typeData++createEnumValue :: TypeName -> DataEnumValue+createEnumValue enumName =+  DataEnumValue+    { enumName,+      enumDescription = Nothing,+      enumDirectives = []+    }++createUnionType :: TypeName -> [TypeName] -> TypeDefinition OUT+createUnionType typeName typeData = createType typeName (DataUnion $ map mkUnionMember typeData)++isEntNode :: TypeContent TRUE a -> Bool+isEntNode DataScalar {} = True+isEntNode DataEnum {} = True+isEntNode _ = False++kindOf :: TypeDefinition a -> TypeKind+kindOf TypeDefinition {typeName, typeContent} = __kind typeContent+  where+    __kind DataScalar {} = KindScalar+    __kind DataEnum {} = KindEnum+    __kind DataInputObject {} = KindInputObject+    __kind DataObject {} = KindObject (toOperationType typeName)+    __kind DataUnion {} = KindUnion+    __kind DataInputUnion {} = KindInputUnion+    __kind DataInterface {} = KindInterface++fromOperation :: Maybe (TypeDefinition OUT) -> [(TypeName, TypeDefinition ANY)]+fromOperation (Just datatype) = [(typeName datatype, toAny datatype)]+fromOperation Nothing = []++defineType :: TypeDefinition cat -> Schema -> Schema+defineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys, typeFingerprint} lib =+  lib {types = HM.insert name unionTags (HM.insert typeName (toAny dt) (types lib))}+  where+    name = typeName <> "Tags"+    unionTags =+      TypeDefinition+        { typeName = name,+          typeFingerprint,+          typeDescription = Nothing,+          typeDirectives = [],+          typeContent = DataEnum $ map (createEnumValue . memberName) enumKeys+        }+defineType datatype lib =+  lib {types = HM.insert (typeName datatype) (toAny datatype) (types lib)}++insertType ::+  TypeDefinition ANY ->+  TypeUpdater+insertType datatype@TypeDefinition {typeName} lib = case isTypeDefined typeName lib of+  Nothing -> resolveUpdates (defineType datatype lib) []+  Just fingerprint+    | fingerprint == typeFingerprint datatype -> return lib+    -- throw error if 2 different types has same name+    | otherwise -> failure $ nameCollisionError typeName++updateSchema ::+  TypeName ->+  DataFingerprint ->+  [TypeUpdater] ->+  (a -> TypeDefinition cat) ->+  a ->+  TypeUpdater+updateSchema name fingerprint stack f x lib =+  case isTypeDefined name lib of+    Nothing ->+      resolveUpdates+        (defineType (f x) lib)+        stack+    Just fingerprint' | fingerprint' == fingerprint -> return lib+    -- throw error if 2 different types has same name+    Just _ -> failure $ nameCollisionError name++lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a+lookupWith f key = find ((== key) . f)++-- lookups and removes TypeDefinition from hashmap+popByKey :: TypeName -> [TypeDefinition ANY] -> (Maybe (TypeDefinition OUT), [TypeDefinition ANY])+popByKey name types = case lookupWith typeName name types of+  Just dt@TypeDefinition {typeContent = DataObject {}} ->+    (fromAny dt, filter ((/= name) . typeName) types)+  _ -> (Nothing, types)++newtype Fields def = Fields+  {unFields :: OrderedMap FieldName def}+  deriving+    ( Show,+      Lift,+      Functor,+      Foldable,+      Traversable+    )++deriving instance (KEY def ~ FieldName, KeyOf def) => Collection def (Fields def)++instance Merge (FieldsDefinition cat) where+  merge path (Fields x) (Fields y) = Fields <$> merge path x y++instance Selectable (Fields (FieldDefinition cat)) (FieldDefinition cat) where+  selectOr fb f name (Fields lib) = selectOr fb f name lib++unsafeFromFields :: [FieldDefinition cat] -> FieldsDefinition cat+unsafeFromFields = Fields . unsafeFromValues++fieldsToArguments :: FieldsDefinition IN -> ArgumentsDefinition+fieldsToArguments = ArgumentsDefinition Nothing . unFields++instance (KEY def ~ FieldName, KeyOf def, NameCollision def) => Listable def (Fields def) where+  fromElems = fmap Fields . fromElems+  elems = elems . unFields++-- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects+------------------------------------------------------------------------------+--  ObjectTypeDefinition:+--    Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt)+--+--  ImplementsInterfaces+--    implements &(opt) NamedType+--    ImplementsInterfaces & NamedType+--+--  FieldsDefinition+--    { FieldDefinition(list) }+--+type FieldsDefinition cat = Fields (FieldDefinition cat)++--  FieldDefinition+--    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)+--+-- https://spec.graphql.org/June2018/#InputValueDefinition+-- InputValueDefinition+--   Description(opt) Name: Type DefaultValue(opt) Directives[Const](opt)++data FieldDefinition (cat :: TypeCategory) = FieldDefinition+  { fieldName :: FieldName,+    fieldDescription :: Maybe Description,+    fieldType :: TypeRef,+    fieldContent :: Maybe (FieldContent TRUE cat),+    fieldDirectives :: [Directive VALID]+  }+  deriving (Show, Lift)++data FieldContent (bool :: Bool) (cat :: TypeCategory) where+  DefaultInputValue ::+    { defaultInputValue :: Value RESOLVED+    } ->+    FieldContent (IsSelected cat IN) cat+  FieldArgs ::+    { fieldArgsDef :: ArgumentsDefinition+    } ->+    FieldContent (IsSelected cat OUT) cat++fieldContentArgs :: FieldContent b cat -> OrderedMap FieldName ArgumentDefinition+fieldContentArgs (FieldArgs (ArgumentsDefinition _ argsD)) = argsD+fieldContentArgs _ = empty++deriving instance Show (FieldContent bool cat)++deriving instance Lift (FieldContent bool cat)++instance KeyOf (FieldDefinition cat) where+  keyOf = fieldName++instance Selectable (FieldDefinition OUT) ArgumentDefinition where+  selectOr fb f key FieldDefinition {fieldContent = Just (FieldArgs args)} = selectOr fb f key args+  selectOr fb _ _ _ = fb++instance NameCollision (FieldDefinition cat) where+  nameCollision name _ =+    GQLError+      { message = "There can Be only One field Named " <> msg name,+        locations = []+      }++instance RenderGQL (FieldDefinition cat) where+  render FieldDefinition {fieldName = FieldName name, fieldType, fieldContent = Just (FieldArgs args)} =+    name <> render args <> ": " <> render fieldType+  render FieldDefinition {fieldName = FieldName name, fieldType} =+    name <> ": " <> render fieldType++instance RenderGQL (FieldsDefinition OUT) where+  render = renderObject render . ignoreHidden . elems++instance RenderGQL (FieldsDefinition IN) where+  render = renderObject render . ignoreHidden . elems++fieldVisibility :: FieldDefinition cat -> Bool+fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields++isFieldNullable :: FieldDefinition cat -> Bool+isFieldNullable = isNullable . fieldType++createField :: Maybe (FieldContent TRUE cat) -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat+createField fieldContent fieldName (typeWrappers, typeConName) =+  FieldDefinition+    { fieldName,+      fieldContent,+      fieldDescription = Nothing,+      fieldType = TypeRef {typeConName, typeWrappers, typeArgs = Nothing},+      fieldDirectives = []+    }++mkField :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat+mkField = createField Nothing++mkObjectField :: ArgumentsDefinition -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition OUT+mkObjectField args = createField (Just $ FieldArgs args)++toNullableField :: FieldDefinition cat -> FieldDefinition cat+toNullableField dataField+  | isNullable (fieldType dataField) = dataField+  | otherwise = dataField {fieldType = nullable (fieldType dataField)}+  where+    nullable alias@TypeRef {typeWrappers} =+      alias {typeWrappers = TypeMaybe : typeWrappers}++toListField :: FieldDefinition cat -> FieldDefinition cat+toListField dataField = dataField {fieldType = listW (fieldType dataField)}+  where+    listW alias@TypeRef {typeWrappers} =+      alias {typeWrappers = TypeList : typeWrappers}++-- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects+---------------------------------------------------------------------------+-- InputObjectTypeDefinition+-- Description(opt) input Name Directives(const,opt) InputFieldsDefinition(opt)+--+--- InputFieldsDefinition+-- { InputValueDefinition(list) }++type InputFieldsDefinition = Fields InputValueDefinition++type InputValueDefinition = FieldDefinition IN++-- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments+-----------------------------------------------------------------------------------------------+-- ArgumentsDefinition:+--   (InputValueDefinition(list))++data ArgumentsDefinition = ArgumentsDefinition+  { argumentsTypename :: Maybe TypeName,+    arguments :: OrderedMap FieldName ArgumentDefinition+  }+  deriving (Show, Lift)++instance RenderGQL ArgumentsDefinition where+  render ArgumentsDefinition {arguments}+    | null arguments =+      ""+    | otherwise = "(" <> intercalate ", " (map render $ elems arguments) <> ")"++type ArgumentDefinition = FieldDefinition IN++instance Selectable ArgumentsDefinition ArgumentDefinition where+  selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args++instance Collection ArgumentDefinition ArgumentsDefinition where+  empty = ArgumentsDefinition Nothing empty+  singleton = ArgumentsDefinition Nothing . singleton++instance Listable ArgumentDefinition ArgumentsDefinition where+  elems (ArgumentsDefinition _ args) = elems args+  fromElems args = ArgumentsDefinition Nothing <$> fromElems args++createArgument :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition IN+createArgument = mkField++-- https://spec.graphql.org/June2018/#InputValueDefinition+-- InputValueDefinition+--   Description(opt) Name: TypeDefaultValue(opt) Directives[Const](opt)+-- TODO: implement inputValue++__inputname :: FieldName+__inputname = "inputname"++createInputUnionFields :: TypeName -> [UnionMember IN] -> [FieldDefinition IN]+createInputUnionFields name members = fieldTag : map unionField members+  where+    fieldTag =+      FieldDefinition+        { fieldName = __inputname,+          fieldDescription = Nothing,+          fieldContent = Nothing,+          fieldType = createAlias (name <> "Tags"),+          fieldDirectives = []+        }++unionField :: UnionMember IN -> FieldDefinition IN+unionField UnionMember {memberName} =+  FieldDefinition+    { fieldName = toFieldName memberName,+      fieldDescription = Nothing,+      fieldContent = Nothing,+      fieldType =+        TypeRef+          { typeConName = memberName,+            typeWrappers = [TypeMaybe],+            typeArgs = Nothing+          },+      fieldDirectives = []+    }++--+-- OTHER+--------------------------------------------------------------------------------------------------++createAlias :: TypeName -> TypeRef+createAlias typeConName =+  TypeRef {typeConName, typeWrappers = [], typeArgs = Nothing}++type TypeUpdater = LibUpdater Schema++instance RenderGQL Schema where+  render schema = intercalate "\n\n" $ map render visibleTypes+    where+      visibleTypes = filter (not . isSystemTypeName . typeName) (elems schema)++instance RenderGQL (TypeDefinition a) where+  render TypeDefinition {typeName, typeContent} = __render typeContent+    where+      __render DataInterface {interfaceFields} = "interface " <> render typeName <> render interfaceFields+      __render DataScalar {} = "scalar " <> render typeName+      __render (DataEnum tags) = "enum " <> render typeName <> renderObject render tags+      __render (DataUnion members) =+        "union "+          <> render typeName+          <> " =\n    "+          <> intercalate ("\n" <> renderIndent <> "| ") (map render members)+      __render (DataInputObject fields) = "input " <> render typeName <> render fields+      __render (DataInputUnion members) = "input " <> render typeName <> render fieldsDef+        where+          fieldsDef = unsafeFromFields fields+          fields :: [FieldDefinition IN]+          fields = createInputUnionFields typeName members+      __render DataObject {objectFields} = "type " <> render typeName <> render objectFields++ignoreHidden :: [FieldDefinition cat] -> [FieldDefinition cat]+ignoreHidden = filter fieldVisibility

@@ -35,7 +35,6 @@     FromJSON (..),     ToJSON (..),     Value (..),-    encode,     object,     pairs,   )@@ -51,6 +50,7 @@     elems,     mapTuple,   )+import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..)) import Data.Morpheus.Types.Internal.AST.Base   ( FieldName,     FieldName (..),@@ -77,7 +77,6 @@ import Data.Semigroup ((<>)) import Data.Text   ( Text,-    unpack,   ) import qualified Data.Vector as V   ( toList,@@ -95,6 +94,12 @@   | Boolean Bool   deriving (Show, Eq, Generic, Lift) +instance RenderGQL ScalarValue where+  render (Int x) = render x+  render (Float x) = render x+  render (String x) = render x+  render (Boolean x) = render x+ instance A.ToJSON ScalarValue where   toJSON (Float x) = A.toJSON x   toJSON (Int x) = A.toJSON x@@ -156,16 +161,18 @@   Scalar :: ScalarValue -> Value stage   Null :: Value stage +deriving instance Show (Value a)+ deriving instance Eq (Value s)  data ObjectEntry (s :: Stage) = ObjectEntry   { entryName :: FieldName,     entryValue :: Value s   }-  deriving (Eq)+  deriving (Eq, Show) -instance Show (ObjectEntry s) where-  show (ObjectEntry (FieldName name) value) = unpack name <> ":" <> show value+instance RenderGQL (ObjectEntry a) where+  render (ObjectEntry (FieldName name) value) = name <> ": " <> render value  instance NameCollision (ObjectEntry s) where   nameCollision _ ObjectEntry {entryName} =@@ -195,26 +202,30 @@  deriving instance Lift (ObjectEntry a) -instance Show (Value a) where-  show Null = "null"-  show (Enum x) = "" <> unpack (readTypeName x)-  show (Scalar x) = show x-  show (ResolvedVariable Ref {refName} Variable {variableValue}) =-    "($" <> unpack (readName refName) <> ": " <> show variableValue <> ") "-  show (VariableValue Ref {refName}) = "$" <> unpack (readName refName) <> " "-  show (Object keys) = "{" <> foldr toEntry "" keys <> "}"+instance RenderGQL (Value a) where+  -- TODO: fix+  render (ResolvedVariable Ref {refName} _) =+    "$" <> readName refName+  render (VariableValue Ref {refName}) = "$" <> readName refName <> " "+  -- TODO: fix+  render Null = "null"+  render (Enum x) = readTypeName x+  render (Scalar x) = render x+  render (Object keys) = "{" <> foldl toEntry "" (elems keys) <> "}"     where-      toEntry :: ObjectEntry a -> String -> String-      toEntry value "" = show value-      toEntry value txt = txt <> ", " <> show value-  show (List list) = "[" <> foldl toEntry "" list <> "]"+      toEntry :: Text -> ObjectEntry a -> Text+      toEntry "" value = render value+      toEntry txt value = txt <> ", " <> render value+  render (List list) = "[" <> foldl toEntry "" list <> "]"     where-      toEntry :: String -> Value a -> String-      toEntry "" value = show value-      toEntry txt value = txt <> ", " <> show value+      toEntry :: Text -> Value a -> Text+      toEntry "" value = render value+      toEntry txt value = txt <> ", " <> render value +-- render = pack . BS.unpack . A.encode+ instance Msg (Value a) where-  msg = msg . A.encode+  msg = msg . render  instance A.ToJSON (Value a) where   toJSON (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) =

@@ -78,10 +78,6 @@     VALID,     msg,   )-import Data.Morpheus.Types.Internal.AST.Data-  ( Arguments,-    Schema,-  ) import Data.Morpheus.Types.Internal.AST.MergeSet   ( toOrderedMap,   )@@ -92,6 +88,10 @@     SelectionSet,     UnionSelection,     UnionTag (..),+  )+import Data.Morpheus.Types.Internal.AST.TypeSystem+  ( Arguments,+    Schema,   ) import Data.Morpheus.Types.Internal.AST.Value   ( GQLValue (..),

@@ -16,12 +16,8 @@     InputValidator,     BaseValidator,     InputSource (..),-    Context (..),-    SelectionContext (..),+    OperationContext (..),     runValidator,-    askSchema,-    askContext,-    askFragments,     askFieldType,     askTypeMember,     selectRequired,@@ -30,10 +26,9 @@     constraint,     withScope,     withScopeType,-    withScopePosition,-    askScopeTypeName,+    withPosition,+    asks,     selectWithDefaultValue,-    askScopePosition,     askInputFieldType,     askInputMember,     startInput,@@ -44,13 +39,23 @@     constraintInputUnion,     ScopeKind (..),     withDirective,+    inputValueSource,+    askVariables,+    Scope (..),+    MissingRequired (..),+    InputContext,+    GetWith,+    SetWith,+    Unknown,+    askSchema,+    askFragments,+    MonadContext,+    CurrentSelection (..),   ) where  import Control.Monad.Trans.Reader-  ( ReaderT (..),-    ask,-    withReaderT,+  ( ask,   ) -- MORPHEUS @@ -65,22 +70,25 @@   ) import Data.Morpheus.Types.Internal.AST   ( ANY,-    Directive (..),+    FieldContent (..),     FieldDefinition (..),     FieldName,     FieldsDefinition,-    Fragments,+    GQLErrors,     IN,     Message,     OUT,     Object,-    Position,+    ObjectEntry (..),+    RESOLVED,     Ref (..),     Schema,+    TRUE,     TypeContent (..),     TypeDefinition (..),     TypeName (..),     TypeRef (..),+    UnionMember (..),     Value (..),     __inputname,     entryValue,@@ -89,9 +97,6 @@     msg,     toFieldName,   )-import Data.Morpheus.Types.Internal.Resolving-  ( Eventless,-  ) import Data.Morpheus.Types.Internal.Validation.Error   ( InternalError (..),     KindViolation (..),@@ -102,35 +107,50 @@ import Data.Morpheus.Types.Internal.Validation.Validator   ( BaseValidator,     Constraint (..),-    Context (..),-    InputContext (..),+    CurrentSelection (..),+    GetWith (..),+    InputContext,     InputSource (..),     InputValidator,+    MonadContext (..),+    OperationContext (..),     Prop (..),     Resolution,+    Scope (..),     ScopeKind (..),-    SelectionContext (..),     SelectionValidator,+    SetWith (..),     Target (..),     Validator (..),-    renderInputPrefix,+    askFragments,+    askSchema,+    askVariables,+    asks,+    inputMessagePrefix,+    inputValueSource,+    runValidator,+    startInput,+    withDirective,+    withInputScope,+    withPosition,+    withScope,+    withScopeType,   ) import Data.Semigroup   ( (<>),-    Semigroup (..),   )  getUnused :: (KeyOf b, KEY a ~ KEY b, Selectable ca a) => ca -> [b] -> [b] getUnused uses = filter (not . (`member` uses) . keyOf) -failOnUnused :: Unused b => [b] -> Validator ctx ()+failOnUnused :: Unused ctx b => [b] -> Validator ctx () failOnUnused x   | null x = return ()   | otherwise = do-    (gctx, _) <- Validator ask-    failure $ map (unused gctx) x+    ctx <- Validator ask+    failure $ map (unused ctx) x -checkUnused :: (KeyOf b, KEY a ~ KEY b, Selectable ca a, Unused b) => ca -> [b] -> Validator ctx ()+checkUnused :: (KeyOf b, KEY a ~ KEY b, Selectable ca a, Unused ctx b) => ca -> [b] -> Validator ctx () checkUnused uses = failOnUnused . getUnused uses  constraint ::@@ -155,39 +175,48 @@   Validator ctx value selectRequired selector container =   do-    (gctx, ctx) <- Validator ask+    ctx <- Validator ask     selectBy-      [missingRequired gctx ctx selector container]+      [missingRequired ctx selector container]       (keyOf selector)       container  selectWithDefaultValue ::+  forall ctx values value.   ( Selectable values value,     MissingRequired values ctx,-    KEY value ~ FieldName+    KEY value ~ FieldName,+    GetWith ctx Scope,+    MonadContext Validator ctx   ) =>-  value ->+  (Value RESOLVED -> value) ->   FieldDefinition IN ->   values ->   Validator ctx value selectWithDefaultValue-  fallbackValue-  field@FieldDefinition {fieldName}+  f+  field@FieldDefinition+    { fieldName,+      fieldContent+    }   values =     selectOr-      handleNullable+      (handeNull fieldContent)       pure       fieldName       values     where       -------------------      handleNullable-        | isFieldNullable field = pure fallbackValue+      handeNull :: Maybe (FieldContent TRUE IN) -> Validator ctx value+      handeNull (Just (DefaultInputValue value)) = pure $ f value+      handeNull Nothing+        | isFieldNullable field = pure $ f Null         | otherwise = failSelection       -----------------       failSelection = do-        (gctx, ctx) <- Validator ask-        failure [missingRequired gctx ctx (Ref fieldName (scopePosition gctx)) values]+        ctx <- Validator ask+        position <- asks position+        failure [missingRequired ctx (Ref fieldName position) values]  selectKnown ::   ( Selectable c a,@@ -201,9 +230,9 @@   Validator ctx a selectKnown selector lib =   do-    (gctx, ctx) <- Validator ask+    ctx <- Validator ask     selectBy-      (unknown gctx ctx lib selector)+      (unknown ctx lib selector)       (keyOf selector)       lib @@ -227,18 +256,18 @@             <> "\" must be an OUTPUT_TYPE."  askTypeMember ::-  TypeName ->+  UnionMember OUT ->   SelectionValidator (TypeName, FieldsDefinition OUT)-askTypeMember name =+askTypeMember UnionMember {memberName} =   askSchema-    >>= selectOr notFound pure name+    >>= selectOr notFound pure memberName     >>= constraintOBJECT   where     notFound = do-      scopeType <- askScopeTypeName+      scopeType <- asks typename       failure $         "Type \""-          <> msg name+          <> msg memberName           <> "\" referenced by union \""           <> msg scopeType           <> "\" can't found in Schema."@@ -248,7 +277,7 @@       where         con DataObject {objectFields} = pure (typeName, objectFields)         con _ = do-          scopeType <- askScopeTypeName+          scopeType <- asks typename           failure $             "Type \"" <> msg typeName               <> "\" referenced by union \""@@ -256,8 +285,14 @@               <> "\" must be an OBJECT."  askInputFieldType ::+  ( Failure GQLErrors (m c),+    Failure Message (m c),+    Monad (m c),+    GetWith c Schema,+    MonadContext m c+  ) =>   FieldDefinition IN ->-  InputValidator (TypeDefinition IN)+  m c (TypeDefinition IN) askInputFieldType field@FieldDefinition {fieldName, fieldType = TypeRef {typeConName}} =   askSchema     >>= selectBy@@ -265,7 +300,12 @@       typeConName     >>= constraintINPUT   where-    constraintINPUT :: TypeDefinition ANY -> InputValidator (TypeDefinition IN)+    constraintINPUT ::+      ( Failure Message m,+        Monad m+      ) =>+      TypeDefinition ANY ->+      m (TypeDefinition IN)     constraintINPUT x = case (fromAny x :: Maybe (TypeDefinition IN)) of       Just inputType -> pure inputType       Nothing ->@@ -277,8 +317,14 @@             <> "\" must be an input type."  askInputMember ::+  ( GetWith c Schema,+    GetWith c Scope,+    Failure Message (m c),+    Monad (m c),+    MonadContext m c+  ) =>   TypeName ->-  InputValidator (TypeDefinition IN)+  m c (TypeDefinition IN) askInputMember name =   askSchema     >>= selectOr notFound pure name@@ -287,105 +333,42 @@     typeInfo tName =       "Type \"" <> msg tName <> "\" referenced by inputUnion "     notFound = do-      scopeType <- askScopeTypeName+      scopeType <- asks typename       failure $         typeInfo name           <> msg scopeType           <> "\" can't found in Schema."     ---------------------------------------    constraintINPUT_OBJECT :: TypeDefinition ANY -> InputValidator (TypeDefinition IN)+    constraintINPUT_OBJECT ::+      ( Monad (m c),+        GetWith c Scope,+        Failure Message (m c),+        MonadContext m c+      ) =>+      TypeDefinition ANY ->+      m c (TypeDefinition IN)     constraintINPUT_OBJECT TypeDefinition {typeContent, ..} = con (fromAny typeContent)       where-        con :: Maybe (TypeContent a IN) -> InputValidator (TypeDefinition IN)+        con ::+          ( Monad (m c),+            GetWith c Scope,+            Failure Message (m c),+            MonadContext m c+          ) =>+          Maybe (TypeContent a IN) ->+          m c (TypeDefinition IN)         con (Just content@DataInputObject {}) = pure TypeDefinition {typeContent = content, ..}         con _ = do-          scopeType <- askScopeTypeName+          scopeType <- asks typename           failure $             typeInfo typeName               <> "\""               <> msg scopeType               <> "\" must be an INPUT_OBJECT." -startInput :: InputSource -> InputValidator a -> Validator ctx a-startInput inputSource =-  setContext $-    const-      InputContext-        { inputSource,-          inputPath = []-        }--withDirective :: Directive s -> Validator ctx a -> Validator ctx a-withDirective-  Directive-    { directiveName,-      directivePosition-    } = setGlobalContext update-    where-      update ctx =-        ctx-          { scopePosition = directivePosition,-            scopeSelectionName = directiveName,-            scopeKind = DIRECTIVE-          }--withInputScope :: Prop -> InputValidator a -> InputValidator a-withInputScope prop = setContext update-  where-    update ctx@InputContext {inputPath = old} =-      ctx {inputPath = old <> [prop]}--runValidator :: Validator ctx a -> Context -> ctx -> Eventless a-runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX, ctx)--askContext :: Validator ctx ctx-askContext = snd <$> Validator ask--askSchema :: Validator ctx Schema-askSchema = schema . fst <$> Validator ask--askFragments :: Validator ctx Fragments-askFragments = fragments . fst <$> Validator ask--askScopeTypeName :: Validator ctx TypeName-askScopeTypeName = scopeTypeName . fst <$> Validator ask--askScopePosition :: Validator ctx Position-askScopePosition = scopePosition . fst <$> Validator ask--setContext ::-  (c' -> c) ->-  Validator c a ->-  Validator c' a-setContext f = Validator . withReaderT (\(x, y) -> (x, f y)) . _runValidator--setGlobalContext ::-  (Context -> Context) ->-  Validator c a ->-  Validator c a-setGlobalContext f = Validator . withReaderT (\(x, y) -> (f x, y)) . _runValidator--withScope :: TypeName -> Ref -> Validator ctx a -> Validator ctx a-withScope scopeTypeName (Ref scopeSelectionName scopePosition) = setGlobalContext update-  where-    update ctx = ctx {scopeTypeName, scopePosition, scopeSelectionName}--withScopePosition :: Position -> Validator ctx a -> Validator ctx a-withScopePosition scopePosition = setGlobalContext update-  where-    update ctx = ctx {scopePosition}--withScopeType :: TypeName -> Validator ctx a -> Validator ctx a-withScopeType scopeTypeName = setGlobalContext update-  where-    update ctx = ctx {scopeTypeName}--inputMessagePrefix :: InputValidator Message-inputMessagePrefix = renderInputPrefix <$> askContext- constraintInputUnion ::   forall stage.-  [(TypeName, Bool)] ->+  [UnionMember IN] ->   Object stage ->   Either Message (TypeName, Maybe (Value stage)) constraintInputUnion tags hm = do@@ -414,16 +397,8 @@       pure (tyName, Just value)     _ -> failure ("input union can have only one variant." :: Message) -isPosibeInputUnion :: [(TypeName, Bool)] -> Value stage -> Either Message TypeName-isPosibeInputUnion tags (Enum name) = case lookup name tags of-  Nothing ->-    failure-      ( msg name-          <> " is not posible union type"-      )-  _ -> pure name-isPosibeInputUnion _ _ =-  failure $-    "\""-      <> msg __inputname-      <> "\" must be Enum"+isPosibeInputUnion :: [UnionMember IN] -> Value stage -> Either Message TypeName+isPosibeInputUnion tags (Enum name)+  | name `elem` map memberName tags = pure name+  | otherwise = failure $ msg name <> " is not posible union type"+isPosibeInputUnion _ _ = failure $ "\"" <> msg __inputname <> "\" must be Enum"

@@ -46,9 +46,14 @@     getOperationName,     msg,   )+import Data.Morpheus.Types.Internal.Validation.SchemaValidator+  ( TypeSystemContext,+  ) import Data.Morpheus.Types.Internal.Validation.Validator-  ( Context (..),+  ( CurrentSelection (..),     InputContext (..),+    OperationContext (..),+    Scope (..),     ScopeKind (..),     Target (..),     renderInputPrefix,@@ -73,13 +78,13 @@           locations = []         } -class Unused c where-  unused :: Context -> c -> GQLError+class Unused ctx c where+  unused :: ctx -> c -> GQLError  -- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".",-instance Unused (Variable s) where+instance Unused (OperationContext v) (Variable s) where   unused-    Context {operationName}+    OperationContext {selection = CurrentSelection {operationName}}     Variable {variableName, variablePosition} =       GQLError         { message =@@ -90,7 +95,7 @@           locations = [variablePosition]         } -instance Unused Fragment where+instance Unused (OperationContext v) Fragment where   unused     _     Fragment {fragmentName, fragmentPosition} =@@ -102,45 +107,66 @@         }  class MissingRequired c ctx where-  missingRequired :: Context -> ctx -> Ref -> c -> GQLError+  missingRequired :: ctx -> Ref -> c -> GQLError -instance MissingRequired (Arguments s) ctx where+instance MissingRequired (Arguments s) (OperationContext v) where   missingRequired-    Context {scopePosition, scopeSelectionName, scopeKind}-    _+    OperationContext+      { scope = Scope {position, kind},+        selection = CurrentSelection {selectionName}+      }     Ref {refName}     _ =       GQLError         { message =-            inScope scopeKind+            inScope kind               <> " argument "               <> msg refName               <> " is required but not provided.",-          locations = [scopePosition]+          locations = [position]         }       where-        inScope SELECTION = "Field " <> msg scopeSelectionName-        inScope DIRECTIVE = "Directive " <> msg ("@" <> scopeSelectionName)+        inScope DIRECTIVE = "Directive " <> msg ("@" <> selectionName)+        inScope _ = "Field " <> msg selectionName -instance MissingRequired (Object s) InputContext where+instance MissingRequired (Object s) (InputContext (OperationContext v)) where   missingRequired-    Context {scopePosition}-    inputCTX+    input@InputContext+      { sourceContext =+          OperationContext+            { scope = Scope {position}+            }+      }     Ref {refName}     _ =       GQLError         { message =-            renderInputPrefix inputCTX+            renderInputPrefix input               <> "Undefined Field "               <> msg refName               <> ".",-          locations = [scopePosition]+          locations = [position]         } -instance MissingRequired (VariableDefinitions s) ctx where+instance MissingRequired (Object s) (InputContext (TypeSystemContext ctx)) where   missingRequired-    Context {operationName}-    _+    input+    Ref {refName}+    _ =+      GQLError+        { message =+            renderInputPrefix input+              <> "Undefined Field "+              <> msg refName+              <> ".",+          locations = []+        }++instance MissingRequired (VariableDefinitions s) (OperationContext v) where+  missingRequired+    OperationContext+      { selection = CurrentSelection {operationName}+      }     Ref {refName, refPosition}     _ =       GQLError@@ -155,55 +181,70 @@  class Unknown c ctx where   type UnknownSelector c-  unknown :: Context -> ctx -> c -> UnknownSelector c -> GQLErrors+  unknown :: ctx -> c -> UnknownSelector c -> GQLErrors  -- {...H} -> "Unknown fragment \"H\"." instance Unknown Fragments ctx where   type UnknownSelector Fragments = Ref-  unknown _ _ _ (Ref name pos) =+  unknown _ _ (Ref name pos) =     errorMessage       pos       ("Unknown Fragment " <> msg name <> ".")  instance Unknown Schema ctx where   type UnknownSelector Schema = TypeNameRef-  unknown _ _ _ TypeNameRef {typeNameRef, typeNamePosition} =+  unknown _ _ TypeNameRef {typeNameRef, typeNamePosition} =     errorMessage typeNamePosition ("Unknown type " <> msg typeNameRef <> ".")  instance Unknown (FieldDefinition OUT) ctx where   type UnknownSelector (FieldDefinition OUT) = Argument RESOLVED-  unknown _ _ FieldDefinition {fieldName} Argument {argumentName, argumentPosition} =+  unknown _ FieldDefinition {fieldName} Argument {argumentName, argumentPosition} =     errorMessage       argumentPosition       ("Unknown Argument " <> msg argumentName <> " on Field " <> msg fieldName <> ".") -instance Unknown (FieldsDefinition IN) InputContext where+instance Unknown (FieldsDefinition IN) (InputContext (OperationContext v)) where   type UnknownSelector (FieldsDefinition IN) = ObjectEntry RESOLVED-  unknown Context {scopePosition} ctx _ ObjectEntry {entryName} =-    [ GQLError-        { message = renderInputPrefix ctx <> "Unknown Field " <> msg entryName <> ".",-          locations = [scopePosition]-        }-    ]+  unknown+    input@InputContext {sourceContext = OperationContext {scope = Scope {position}}}+    _+    ObjectEntry {entryName} =+      [ GQLError+          { message = renderInputPrefix input <> "Unknown Field " <> msg entryName <> ".",+            locations = [position]+          }+      ] +instance Unknown (FieldsDefinition IN) (InputContext (TypeSystemContext ctx)) where+  type UnknownSelector (FieldsDefinition IN) = ObjectEntry RESOLVED+  unknown+    input+    _+    ObjectEntry {entryName} =+      [ GQLError+          { message = renderInputPrefix input <> "Unknown Field " <> msg entryName <> ".",+            locations = []+          }+      ]+ instance Unknown DirectiveDefinition ctx where   type UnknownSelector DirectiveDefinition = Argument RESOLVED-  unknown _ _ DirectiveDefinition {directiveDefinitionName} Argument {argumentName, argumentPosition} =+  unknown _ DirectiveDefinition {directiveDefinitionName} Argument {argumentName, argumentPosition} =     errorMessage       argumentPosition       ("Unknown Argument " <> msg argumentName <> " on Directive " <> msg directiveDefinitionName <> ".")  instance Unknown DirectiveDefinitions ctx where   type UnknownSelector DirectiveDefinitions = Directive RAW-  unknown _ _ _ Directive {directiveName, directivePosition} =+  unknown _ _ Directive {directiveName, directivePosition} =     errorMessage       directivePosition       ("Unknown Directive " <> msg directiveName <> ".") -instance Unknown (FieldsDefinition OUT) ctx where+instance Unknown (FieldsDefinition OUT) (OperationContext v) where   type UnknownSelector (FieldsDefinition OUT) = Ref-  unknown Context {scopeTypeName} _ _ =-    unknownSelectionField scopeTypeName+  unknown OperationContext {scope = Scope {typename}} _ =+    unknownSelectionField typename  class KindViolation (t :: Target) ctx where   kindViolation :: c t -> ctx -> GQLError

@@ -0,0 +1,144 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Types.Internal.Validation.SchemaValidator+  ( SchemaValidator,+    selectType,+    TypeSystemContext (..),+    constraintInterface,+    inField,+    inType,+    inArgument,+    inInterface,+    Field (..),+    Interface (..),+    renderField,+  )+where++import Control.Monad.Reader (asks)+--import Data.Morpheus.Error.Document.Interface (unknownInterface)+import Data.Morpheus.Error.Utils (globalErrorMessage)+-- MORPHEUS++import Data.Morpheus.Internal.Utils+  ( Failure (..),+    fromElems,+    selectBy,+  )+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    FieldName,+    FieldsDefinition,+    OUT,+    Position (..),+    Schema,+    TypeContent (..),+    TypeDefinition (..),+    TypeName,+    msg,+  )+import Data.Morpheus.Types.Internal.Resolving (Result (..))+import Data.Morpheus.Types.Internal.Validation.Validator+  ( GetWith (..),+    Scope (..),+    ScopeKind (..),+    SetWith (..),+    Validator (..),+    renderField,+    withContext,+  )+import Data.Semigroup+  ( (<>),+    Semigroup (..),+  )++data TypeSystemContext c = TypeSystemContext+  { types :: [TypeDefinition ANY],+    local :: c+  }+  deriving (Show)++instance GetWith (TypeSystemContext ctx) Schema where+  getWith ctx = case fromElems (types ctx) of+    Success {result} -> result+    Failure {errors} -> error (show errors)++instance GetWith (TypeSystemContext a) Scope where+  getWith _ =+    Scope+      { position = Position {line = 0, column = 0},+        typename = "TODO:",+        kind = TYPE+      }++instance SetWith (TypeSystemContext a) Scope where+  setWith _ = id --TODO:++selectType :: TypeName -> SchemaValidator ctx (TypeDefinition ANY)+selectType name =+  asks types+    >>= selectBy err name+  where+    err = globalErrorMessage $ "Unknown Type " <> msg name <> "."++inType ::+  TypeName ->+  SchemaValidator TypeName v ->+  SchemaValidator () v+inType name = withLocalContext (const name)++inInterface ::+  TypeName ->+  SchemaValidator Interface v ->+  SchemaValidator TypeName v+inInterface interfaceName = withLocalContext (Interface interfaceName)++inField ::+  FieldName ->+  SchemaValidator (t, FieldName) v ->+  SchemaValidator t v+inField fname = withLocalContext (,fname)++inArgument ::+  FieldName ->+  SchemaValidator (t, Field) v ->+  SchemaValidator (t, FieldName) v+inArgument aname = withLocalContext (\(t1, f1) -> (t1, Field f1 aname))++data Interface = Interface+  { interfaceName :: TypeName,+    typeName :: TypeName+  }++data Field = Field+  { fieldName :: FieldName,+    fieldArgument :: FieldName+  }++withLocalContext :: (a -> b) -> Validator (TypeSystemContext b) v -> Validator (TypeSystemContext a) v+withLocalContext = withContext . updateLocal++updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b+updateLocal f ctx = ctx {local = f (local ctx)}++type SchemaValidator c = Validator (TypeSystemContext c)++constraintInterface :: TypeDefinition ANY -> SchemaValidator ctx (TypeName, FieldsDefinition OUT)+constraintInterface+  TypeDefinition+    { typeName,+      typeContent = DataInterface fields+    } = pure (typeName, fields)+constraintInterface TypeDefinition {typeName} =+  failure $ globalErrorMessage $ "type " <> msg typeName <> " must be an interface"

@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -7,6 +8,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -16,29 +18,38 @@     InputValidator,     BaseValidator,     runValidator,-    askSchema,-    askContext,-    askFragments,     Constraint (..),     withScope,     withScopeType,-    withScopePosition,-    askScopeTypeName,-    askScopePosition,+    withPosition,     withInputScope,     inputMessagePrefix,-    Context (..),     InputSource (..),     InputContext (..),-    SelectionContext (..),+    OperationContext (..),+    CurrentSelection (..),     renderInputPrefix,     Target (..),     Prop (..),     Resolution,     ScopeKind (..),+    inputValueSource,+    Scope (..),+    withDirective,+    startInput,+    GetWith (..),+    SetWith (..),+    MonadContext (..),+    withContext,+    renderField,+    asks,+    askSchema,+    askVariables,+    askFragments,   ) where +import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Reader   ( ReaderT (..),@@ -46,13 +57,13 @@     withReaderT,   ) -- MORPHEUS- import Data.Morpheus.Internal.Utils   ( Failure (..),   ) import Data.Morpheus.Types.Internal.AST   ( Argument (..),-    FieldName,+    Directive (..),+    FieldName (..),     FieldsDefinition,     Fragments,     GQLError (..),@@ -63,9 +74,10 @@     Position,     RAW,     RESOLVED,+    Ref (..),     Schema,-    TypeDefinition (..),-    TypeName,+    TypeDefinition,+    TypeName (..),     VALID,     Variable (..),     VariableDefinitions,@@ -77,7 +89,6 @@   ) import Data.Semigroup   ( (<>),-    Semigroup (..),   )  data Prop = Prop@@ -92,48 +103,73 @@ renderPath [] = "" renderPath path = "in field " <> msg (intercalateName "." $ map propName path) <> ": " -renderInputPrefix :: InputContext -> Message+renderInputPrefix :: InputContext c -> Message renderInputPrefix InputContext {inputPath, inputSource} =   renderSource inputSource <> renderPath inputPath  renderSource :: InputSource -> Message renderSource (SourceArgument Argument {argumentName}) =   "Argument " <> msg argumentName <> " got invalid value. "-renderSource (SourceVariable Variable {variableName}) =+renderSource (SourceVariable Variable {variableName} _) =   "Variable " <> msg ("$" <> variableName) <> " got invalid value. "+renderSource SourceInputField {sourceTypeName, sourceFieldName, sourceArgumentName} =+  "Field " <> renderField sourceTypeName sourceFieldName sourceArgumentName <> " got invalid default value. " +renderField :: TypeName -> FieldName -> Maybe FieldName -> Message+renderField (TypeName tname) (FieldName fname) arg =+  msg (tname <> "." <> fname <> renderArg arg)+  where+    renderArg (Just (FieldName argName)) = "(" <> argName <> ":)"+    renderArg Nothing = ""+ data ScopeKind   = DIRECTIVE   | SELECTION+  | TYPE   deriving (Show) -data Context = Context+data OperationContext vars = OperationContext   { schema :: Schema,+    scope :: Scope,     fragments :: Fragments,-    scopePosition :: Position,-    scopeTypeName :: TypeName,-    operationName :: Maybe FieldName,-    scopeSelectionName :: FieldName,-    scopeKind :: ScopeKind+    selection :: CurrentSelection,+    variables :: vars   }   deriving (Show) -data InputContext = InputContext-  { inputSource :: InputSource,-    inputPath :: [Prop]+data CurrentSelection = CurrentSelection+  { operationName :: Maybe FieldName,+    selectionName :: FieldName   }   deriving (Show) -data InputSource-  = SourceArgument (Argument RESOLVED)-  | SourceVariable (Variable RAW)+data Scope = Scope+  { position :: Position,+    typename :: TypeName,+    kind :: ScopeKind+  }   deriving (Show) -newtype SelectionContext = SelectionContext-  { variables :: VariableDefinitions VALID+data InputContext ctx = InputContext+  { inputSource :: InputSource,+    inputPath :: [Prop],+    sourceContext :: ctx   }   deriving (Show) +data InputSource+  = SourceArgument (Argument RESOLVED)+  | SourceVariable+      { sourceVariable :: Variable RAW,+        isDefaultValue :: Bool+      }+  | SourceInputField+      { sourceTypeName :: TypeName,+        sourceFieldName :: FieldName,+        sourceArgumentName :: Maybe FieldName+      }+  deriving (Show)+ data Target   = TARGET_OBJECT   | TARGET_INPUT@@ -150,85 +186,251 @@  type instance Resolution 'TARGET_INPUT = TypeDefinition IN ---type instance Resolution 'TARGET_UNION = DataUnion--withInputScope :: Prop -> InputValidator a -> InputValidator a-withInputScope prop = setContext update+withInputScope :: Prop -> InputValidator c a -> InputValidator c a+withInputScope prop = withContext update   where-    update ctx@InputContext {inputPath = old} =-      ctx {inputPath = old <> [prop]}+    update+      InputContext+        { inputPath = old,+          ..+        } =+        InputContext+          { inputPath = old <> [prop],+            ..+          } -askContext :: Validator ctx ctx-askContext = snd <$> Validator ask+inputValueSource ::+  forall m c.+  ( GetWith c InputSource,+    MonadContext m c+  ) =>+  m c InputSource+inputValueSource = get -askSchema :: Validator ctx Schema-askSchema = schema . fst <$> Validator ask+asks ::+  ( MonadContext m c,+    GetWith c t+  ) =>+  (t -> a) ->+  m c a+asks f = f <$> get -askFragments :: Validator ctx Fragments-askFragments = fragments . fst <$> Validator ask+setSelectionName ::+  ( MonadContext m c,+    SetWith c CurrentSelection+  ) =>+  FieldName ->+  m c a ->+  m c a+setSelectionName selectionName = set update+  where+    update ctx = ctx {selectionName} -askScopeTypeName :: Validator ctx TypeName-askScopeTypeName = scopeTypeName . fst <$> Validator ask+askSchema ::+  ( MonadContext m c,+    GetWith c Schema+  ) =>+  m c Schema+askSchema = get -askScopePosition :: Validator ctx Position-askScopePosition = scopePosition . fst <$> Validator ask+askVariables ::+  ( MonadContext m c,+    GetWith c (VariableDefinitions VALID)+  ) =>+  m c (VariableDefinitions VALID)+askVariables = get -setContext ::+askFragments ::+  ( MonadContext m c,+    GetWith c Fragments+  ) =>+  m c Fragments+askFragments = get++runValidator :: Validator ctx a -> ctx -> Eventless a+runValidator (Validator x) = runReaderT x++withContext ::   (c' -> c) ->   Validator c a ->   Validator c' a-setContext f = Validator . withReaderT (\(x, y) -> (x, f y)) . _runValidator+withContext f = Validator . withReaderT f . _runValidator -setGlobalContext ::-  (Context -> Context) ->-  Validator c a ->-  Validator c a-setGlobalContext f = Validator . withReaderT (\(x, y) -> (f x, y)) . _runValidator+withDirective ::+  ( SetWith c CurrentSelection,+    SetWith c Scope,+    MonadContext m c+  ) =>+  Directive s ->+  m c a ->+  m c a+withDirective+  Directive+    { directiveName,+      directivePosition+    } = setSelectionName directiveName . set update+    where+      update Scope {..} =+        Scope+          { position = directivePosition,+            kind = DIRECTIVE,+            ..+          } -withScope :: TypeName -> Position -> Validator ctx a -> Validator ctx a-withScope scopeTypeName scopePosition = setGlobalContext update+withScope ::+  ( SetWith c CurrentSelection,+    MonadContext m c,+    SetWith c Scope+  ) =>+  TypeName ->+  Ref ->+  m c a ->+  m c a+withScope typeName (Ref selName pos) =+  setSelectionName selName . set update   where-    update ctx = ctx {scopeTypeName, scopePosition}+    update Scope {..} = Scope {typename = typeName, position = pos, ..} -withScopePosition :: Position -> Validator ctx a -> Validator ctx a-withScopePosition scopePosition = setGlobalContext update+withPosition ::+  ( MonadContext m c,+    SetWith c Scope+  ) =>+  Position ->+  m c a ->+  m c a+withPosition pos = set update   where-    update ctx = ctx {scopePosition}+    update Scope {..} = Scope {position = pos, ..} -withScopeType :: TypeName -> Validator ctx a -> Validator ctx a-withScopeType scopeTypeName = setGlobalContext update+withScopeType ::+  ( MonadContext m c,+    SetWith c Scope+  ) =>+  TypeName ->+  m c a ->+  m c a+withScopeType name = set update   where-    update ctx = ctx {scopeTypeName}+    update Scope {..} = Scope {typename = name, ..} -inputMessagePrefix :: InputValidator Message-inputMessagePrefix = renderInputPrefix <$> askContext+inputMessagePrefix :: InputValidator ctx Message+inputMessagePrefix = renderInputPrefix <$> Validator ask -runValidator :: Validator ctx a -> Context -> ctx -> Eventless a-runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX, ctx)+startInput ::+  InputSource ->+  InputValidator ctx a ->+  Validator ctx a+startInput inputSource = withContext update+  where+    update sourceContext =+      InputContext+        { inputSource,+          inputPath = [],+          sourceContext+        }  newtype Validator ctx a = Validator   { _runValidator ::       ReaderT-        (Context, ctx)+        ctx         Eventless         a   }-  deriving+  deriving newtype     ( Functor,       Applicative,-      Monad+      Monad,+      MonadReader ctx     ) -type BaseValidator = Validator ()+type BaseValidator = Validator (OperationContext ()) -type SelectionValidator = Validator SelectionContext+type SelectionValidator = Validator (OperationContext (VariableDefinitions VALID)) -type InputValidator = Validator InputContext+type InputValidator ctx = Validator (InputContext ctx) +-- Helpers+get :: (MonadContext m ctx, GetWith ctx a) => m ctx a+get = getContext getWith++set ::+  ( MonadContext m c,+    SetWith c a+  ) =>+  (a -> a) ->+  m c b ->+  m c b+set f = setContext (setWith f)++class+  Monad (m c) =>+  MonadContext m c+  where+  getContext :: (c -> a) -> m c a+  setContext :: (c -> c) -> m c b -> m c b++instance MonadContext Validator c where+  getContext f = f <$> Validator ask+  setContext = withContext++class GetWith (c :: *) (v :: *) where+  getWith :: c -> v++instance GetWith (OperationContext v) Scope where+  getWith = scope++instance GetWith c Scope => GetWith (InputContext c) Scope where+  getWith = getWith . sourceContext++instance GetWith (OperationContext c) Schema where+  getWith = schema++instance GetWith c Schema => GetWith (InputContext c) Schema where+  getWith = getWith . sourceContext++instance GetWith (OperationContext (VariableDefinitions VALID)) (VariableDefinitions VALID) where+  getWith = variables++instance GetWith (InputContext ctx) InputSource where+  getWith = inputSource++instance GetWith (OperationContext v) Fragments where+  getWith = fragments++-- Setters+class SetWith (c :: *) (v :: *) where+  setWith :: (v -> v) -> c -> c++instance SetWith (OperationContext v) CurrentSelection where+  setWith f OperationContext {selection = selection, ..} =+    OperationContext+      { selection = f selection,+        ..+      }++instance SetWith (OperationContext v) Scope where+  setWith f OperationContext {..} =+    OperationContext+      { scope = f scope,+        ..+      }++instance SetWith c Scope => SetWith (InputContext c) Scope where+  setWith f InputContext {..} =+    InputContext+      { sourceContext = setWith f sourceContext,+        ..+      }+ -- can be only used for internal errors-instance Failure Message (Validator ctx) where+instance+  ( MonadContext Validator ctx,+    GetWith ctx Scope+  ) =>+  Failure Message (Validator ctx)+  where   failure inputMessage = do-    position <- askScopePosition+    position <- asks position     failure       [ GQLError           { message = "INTERNAL: " <> inputMessage,

@@ -1,4 +1,8 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}  module Data.Morpheus.Validation.Document.Validation@@ -7,73 +11,242 @@   ) where +import Control.Monad ((>=>))+import Control.Monad.Reader (asks)+import Data.Foldable (traverse_) import Data.Functor (($>)) -- -- Morpheus+ import Data.Morpheus.Error.Document.Interface   ( ImplementsError (..),-    partialImplements,-    unknownInterface,+    PartialImplements (..),   ) import Data.Morpheus.Internal.Utils-  ( Selectable (..),+  ( KeyOf (..),+    Selectable (..),     elems,+    empty,+    failure,   )+import Data.Morpheus.Schema.Schema (systemTypes) import Data.Morpheus.Types.Internal.AST   ( ANY,+    ArgumentDefinition,+    ArgumentsDefinition (..),+    FieldContent (..),     FieldDefinition (..),     FieldName (..),     FieldsDefinition,+    IN,     OUT,+    ObjectEntry (..),     Schema,+    TRUE,     TypeContent (..),     TypeDefinition (..),     TypeName,     TypeRef (..),     isWeaker,-    lookupWith,   ) import Data.Morpheus.Types.Internal.Resolving   ( Eventless,-    Failure (..),   )+import Data.Morpheus.Types.Internal.Validation+  ( InputSource (..),+    InputValidator,+    askInputFieldType,+    runValidator,+    startInput,+  )+import Data.Morpheus.Types.Internal.Validation.SchemaValidator+  ( Field (..),+    Interface (..),+    SchemaValidator,+    TypeSystemContext (..),+    constraintInterface,+    inArgument,+    inField,+    inInterface,+    inType,+    selectType,+  )+import Data.Morpheus.Validation.Internal.Value (validateInput)+import Data.Semigroup ((<>))  validateSchema :: Schema -> Eventless Schema validateSchema schema = validatePartialDocument (elems schema) $> schema  validatePartialDocument :: [TypeDefinition ANY] -> Eventless [TypeDefinition ANY]-validatePartialDocument lib = traverse validateType lib-  where-    validateType :: TypeDefinition ANY -> Eventless (TypeDefinition ANY)-    validateType dt@TypeDefinition {typeName, typeContent = DataObject {objectImplements, objectFields}} = do-      interface <- traverse getInterfaceByKey objectImplements-      case concatMap (mustBeSubset objectFields) interface of-        [] -> pure dt-        errors -> failure $ partialImplements typeName errors-    validateType x = pure x-    mustBeSubset ::-      FieldsDefinition OUT -> (TypeName, FieldsDefinition OUT) -> [(TypeName, FieldName, ImplementsError)]-    mustBeSubset objFields (typeName, fields) = concatMap checkField (elems fields)-      where-        checkField :: FieldDefinition OUT -> [(TypeName, FieldName, ImplementsError)]-        checkField FieldDefinition {fieldName, fieldType = interfaceT@TypeRef {typeConName = interfaceTypeName, typeWrappers = interfaceWrappers}} =-          selectOr err checkTypeEq fieldName objFields-          where-            err = [(typeName, fieldName, UndefinedField)]-            checkTypeEq FieldDefinition {fieldType = objT@TypeRef {typeConName, typeWrappers}}-              | typeConName == interfaceTypeName && not (isWeaker typeWrappers interfaceWrappers) =-                []-              | otherwise =-                [ ( typeName,-                    fieldName,-                    UnexpectedType-                      { expectedType = interfaceT,-                        foundType = objT-                      }-                  )-                ]-    --------------------------------    getInterfaceByKey :: TypeName -> Eventless (TypeName, FieldsDefinition OUT)-    getInterfaceByKey interfaceName = case lookupWith typeName interfaceName lib of-      Just TypeDefinition {typeContent = DataInterface {interfaceFields}} -> pure (interfaceName, interfaceFields)-      _ -> failure $ unknownInterface interfaceName+validatePartialDocument types =+  runValidator+    (traverse validateType types)+    TypeSystemContext+      { types = systemTypes <> types,+        local = ()+      }++validateType ::+  TypeDefinition ANY ->+  SchemaValidator () (TypeDefinition ANY)+validateType+  dt@TypeDefinition+    { typeName,+      typeContent =+        DataObject+          { objectImplements,+            objectFields+          }+    } = inType typeName $+    do+      validateImplements objectImplements objectFields+      traverse_ checkFieldArgsuments objectFields+      pure dt+validateType+  dt@TypeDefinition+    { typeContent = DataInputObject {inputObjectFields},+      typeName+    } = inType typeName $ do+    traverse_ validateFieldDefaultValue inputObjectFields+    pure dt+validateType x = pure x++-- INETRFACE+----------------------------+validateImplements ::+  [TypeName] ->+  FieldsDefinition OUT ->+  SchemaValidator TypeName ()+validateImplements objectImplements objectFields = do+  interface <- traverse selectInterface objectImplements+  traverse_ (mustBeSubset objectFields) interface++mustBeSubset ::+  FieldsDefinition OUT -> (TypeName, FieldsDefinition OUT) -> SchemaValidator TypeName ()+mustBeSubset objFields (typeName, fields) =+  inInterface typeName $+    traverse_ (checkInterfaceField objFields) (elems fields)++checkInterfaceField ::+  FieldsDefinition OUT ->+  FieldDefinition OUT ->+  SchemaValidator Interface ()+checkInterfaceField+  objFields+  interfaceField@FieldDefinition+    { fieldName+    } =+    inField fieldName $+      selectOr err (isSuptype interfaceField) fieldName objFields+    where+      err = failImplements Missing++class PartialImplements ctx => TypeEq a ctx where+  isSuptype :: a -> a -> SchemaValidator ctx ()++instance TypeEq (FieldDefinition OUT) (Interface, FieldName) where+  FieldDefinition+    { fieldType,+      fieldContent = args1+    }+    `isSuptype` FieldDefinition+      { fieldType = fieldType',+        fieldContent = args2+      } = (fieldType `isSuptype` fieldType') *> (args1 `isSuptype` args2)++instance TypeEq (Maybe (FieldContent TRUE OUT)) (Interface, FieldName) where+  f1 `isSuptype` f2 = toARgs f1 `isSuptype` toARgs f2+    where+      toARgs :: Maybe (FieldContent TRUE OUT) -> ArgumentsDefinition+      toARgs (Just (FieldArgs args)) = args+      toARgs _ = empty++instance (PartialImplements ctx) => TypeEq TypeRef ctx where+  t1@TypeRef+    { typeConName,+      typeWrappers = w1+    }+    `isSuptype` t2@TypeRef+      { typeConName = name',+        typeWrappers = w2+      }+      | typeConName == name' && not (isWeaker w2 w1) = pure ()+      | otherwise =+        failImplements UnexpectedType {expectedType = t1, foundType = t2}++elemIn ::+  ( KeyOf a,+    Selectable c a,+    TypeEq a ctx+  ) =>+  a ->+  c ->+  SchemaValidator ctx ()+elemIn el = selectOr (failImplements Missing) (isSuptype el) (keyOf el)++instance TypeEq ArgumentsDefinition (Interface, FieldName) where+  args1 `isSuptype` args2 = traverse_ validateArg (elems args1)+    where+      validateArg arg = inArgument (keyOf arg) $ elemIn arg args2++instance TypeEq ArgumentDefinition (Interface, Field) where+  arg1 `isSuptype` arg2 = fieldType arg1 `isSuptype` fieldType arg2++-------------------------------+selectInterface ::+  TypeName ->+  SchemaValidator ctx (TypeName, FieldsDefinition OUT)+selectInterface = selectType >=> constraintInterface++failImplements ::+  PartialImplements ctx =>+  ImplementsError ->+  SchemaValidator ctx a+failImplements err = do+  x <- asks local+  failure $ partialImplements x err++checkFieldArgsuments ::+  FieldDefinition OUT ->+  SchemaValidator TypeName ()+checkFieldArgsuments FieldDefinition {fieldContent = Nothing} = pure ()+checkFieldArgsuments FieldDefinition {fieldContent = Just (FieldArgs args), fieldName} = do+  typeName <- asks local+  traverse_ (validateArgumentDefaultValue typeName fieldName) (elems args)++validateArgumentDefaultValue ::+  TypeName ->+  FieldName ->+  ArgumentDefinition ->+  SchemaValidator TypeName ()+validateArgumentDefaultValue _ _ FieldDefinition {fieldContent = Nothing} = pure ()+validateArgumentDefaultValue+  typeName+  fName+  inputField@FieldDefinition {fieldName = argName} =+    startInput (SourceInputField typeName fName (Just argName)) $+      validateDefaultValue inputField++-- DEFAULT VALUE+-- TODO: implement default value validation+validateFieldDefaultValue ::+  FieldDefinition IN ->+  SchemaValidator TypeName ()+validateFieldDefaultValue inputField@FieldDefinition {fieldName} = do+  typeName <- asks local+  startInput (SourceInputField typeName fieldName Nothing) $+    validateDefaultValue inputField++validateDefaultValue ::+  FieldDefinition IN ->+  InputValidator (TypeSystemContext TypeName) ()+validateDefaultValue FieldDefinition {fieldContent = Nothing} = pure ()+validateDefaultValue+  inputField@FieldDefinition+    { fieldName,+      fieldType = TypeRef {typeWrappers},+      fieldContent = Just DefaultInputValue {defaultInputValue}+    } = do+    datatype <- askInputFieldType inputField+    _ <- validateInput typeWrappers datatype (ObjectEntry fieldName defaultInputValue)+    pure ()

@@ -1,10 +1,15 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Data.Morpheus.Validation.Internal.Value (validateInput) where  import Data.Foldable (traverse_)+import Data.Function ((&)) import Data.List (elem) import Data.Maybe (maybe) -- MORPHEUS@@ -15,18 +20,23 @@ import Data.Morpheus.Internal.Utils   ( Failure (..),     elems,+    fromElems,   ) import Data.Morpheus.Types.Internal.AST   ( DataEnumValue (..),+    DataInputUnion,     FieldDefinition (..),+    FieldsDefinition,     IN,     Message,+    Object,     ObjectEntry (..),     RESOLVED,     Ref (..),     ResolvedValue,     ScalarDefinition (..),     ScalarValue (..),+    Schema,     TRUE,     TypeContent (..),     TypeDefinition (..),@@ -49,13 +59,24 @@   ( unsafeFromValues,   ) import Data.Morpheus.Types.Internal.Validation-  ( InputValidator,+  ( GetWith,+    InputContext,+    InputSource (..),+    InputValidator,+    MissingRequired,+    MonadContext,     Prop (..),+    Scope (..),+    ScopeKind (..),+    SetWith,+    Unknown,+    Validator,     askInputFieldType,     askInputMember,-    askScopePosition,+    asks,     constraintInputUnion,     inputMessagePrefix,+    inputValueSource,     selectKnown,     selectWithDefaultValue,     withInputScope,@@ -63,9 +84,16 @@   ) import Data.Semigroup ((<>)) -castFailure :: TypeRef -> Maybe Message -> ResolvedValue -> InputValidator a+castFailure ::+  ( GetWith ctx Schema,+    GetWith ctx Scope+  ) =>+  TypeRef ->+  Maybe Message ->+  ResolvedValue ->+  InputValidator ctx a castFailure expected message value = do-  pos <- askScopePosition+  pos <- asks position   prefix <- inputMessagePrefix   failure     $ errorMessage pos@@ -75,7 +103,7 @@   (TypeName, [TypeWrapper]) ->   Ref ->   Variable VALID ->-  InputValidator ValidValue+  InputValidator ctx ValidValue checkTypeEquality (tyConName, tyWrappers) ref var@Variable {variableValue = ValidVariableValue value, variableType}   | typeConName variableType == tyConName       && not@@ -92,31 +120,45 @@             typeArgs = Nothing           } --- Validate Variable Argument or all Possible input Values+type InputConstraints ctx =+  ( GetWith ctx Schema,+    GetWith ctx Scope,+    GetWith (InputContext ctx) InputSource,+    SetWith ctx Scope,+    MissingRequired (Object RESOLVED) (InputContext ctx),+    Unknown (FieldsDefinition IN) (InputContext ctx)+  )++-- Validate input Values validateInput ::+  forall ctx.+  ( InputConstraints ctx+  ) =>   [TypeWrapper] ->   TypeDefinition IN ->   ObjectEntry RESOLVED ->-  InputValidator ValidValue+  InputValidator ctx ValidValue validateInput tyWrappers TypeDefinition {typeContent = tyCont, typeName} =   withScopeType typeName     . validateWrapped tyWrappers tyCont   where-    mismatchError :: [TypeWrapper] -> ResolvedValue -> InputValidator ValidValue-    mismatchError wrappers = castFailure (TypeRef typeName Nothing wrappers) Nothing+    mismatchError :: [TypeWrapper] -> Maybe Message -> ResolvedValue -> InputValidator ctx ValidValue+    mismatchError wrappers = castFailure (TypeRef typeName Nothing wrappers)     -- VALIDATION     validateWrapped ::       [TypeWrapper] ->       TypeContent TRUE IN ->       ObjectEntry RESOLVED ->-      InputValidator ValidValue+      InputValidator ctx ValidValue     -- Validate Null. value = null ?     validateWrapped wrappers _ ObjectEntry {entryValue = ResolvedVariable ref variable} =       checkTypeEquality (typeName, wrappers) ref variable     validateWrapped wrappers _ ObjectEntry {entryValue = Null}-      | isNullableWrapper wrappers = return Null-      | otherwise = mismatchError wrappers Null+      | isNullableWrapper wrappers = pure Null+      | otherwise = mismatchError wrappers Nothing Null     -- Validate LIST+    validateWrapped [TypeMaybe] dt ObjectEntry {entryValue} =+      validateUnwrapped (mismatchError [TypeMaybe]) dt entryValue     validateWrapped (TypeMaybe : wrappers) _ value =       validateWrapped wrappers tyCont value     validateWrapped (TypeList : wrappers) _ (ObjectEntry key (List list)) =@@ -125,60 +167,137 @@         validateElement = validateWrapped wrappers tyCont . ObjectEntry key     {-- 2. VALIDATE TYPES, all wrappers are already Processed --}     {-- VALIDATE OBJECT--}-    validateWrapped [] dt v = validate dt v-      where-        validate ::-          TypeContent TRUE IN -> ObjectEntry RESOLVED -> InputValidator ValidValue-        validate (DataInputObject parentFields) ObjectEntry {entryValue = Object fields} = do-          traverse_ requiredFieldsDefined (elems parentFields)-          Object <$> traverse validateField fields-          where-            requiredFieldsDefined :: FieldDefinition IN -> InputValidator (ObjectEntry RESOLVED)-            requiredFieldsDefined fieldDef@FieldDefinition {fieldName} =-              selectWithDefaultValue (ObjectEntry fieldName Null) fieldDef fields-            validateField ::-              ObjectEntry RESOLVED -> InputValidator (ObjectEntry VALID)-            validateField entry@ObjectEntry {entryName} = do-              inputField@FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}} <- getField-              inputTypeDef <- askInputFieldType inputField-              withInputScope (Prop entryName typeConName) $-                ObjectEntry entryName-                  <$> validateInput-                    typeWrappers-                    inputTypeDef-                    entry-              where-                getField = selectKnown entry parentFields-        -- VALIDATE INPUT UNION-        -- TODO: enhance input union Validation-        validate (DataInputUnion inputUnion) ObjectEntry {entryValue = Object rawFields} =-          case constraintInputUnion inputUnion rawFields of-            Left message -> castFailure (TypeRef typeName Nothing []) (Just message) (Object rawFields)-            Right (name, Nothing) -> return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name)])-            Right (name, Just value) -> do-              inputDef <- askInputMember name-              validValue <--                validateInput-                  [TypeMaybe]-                  inputDef-                  (ObjectEntry (toFieldName name) value)-              return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name), ObjectEntry (toFieldName name) validValue])-        {-- VALIDATE ENUM --}-        validate (DataEnum tags) ObjectEntry {entryValue} =-          validateEnum (castFailure (TypeRef typeName Nothing []) Nothing) tags entryValue-        {-- VALIDATE SCALAR --}-        validate (DataScalar dataScalar) ObjectEntry {entryValue} =-          validateScalar typeName dataScalar entryValue (castFailure (TypeRef typeName Nothing []))-        validate _ ObjectEntry {entryValue} = mismatchError [] entryValue+    validateWrapped [] dt ObjectEntry {entryValue} =+      validateUnwrapped (mismatchError []) dt entryValue     {-- 3. THROW ERROR: on invalid values --}-    validateWrapped wrappers _ ObjectEntry {entryValue} = mismatchError wrappers entryValue+    validateWrapped wrappers _ ObjectEntry {entryValue} = mismatchError wrappers Nothing entryValue+    validateUnwrapped ::+      -- error+      (Maybe Message -> ResolvedValue -> InputValidator ctx ValidValue) ->+      TypeContent TRUE IN ->+      Value RESOLVED ->+      InputValidator ctx ValidValue+    validateUnwrapped _ (DataInputObject parentFields) (Object fields) =+      Object <$> validateInputObject parentFields fields+    validateUnwrapped _ (DataInputUnion inputUnion) (Object rawFields) =+      validatInputUnion typeName inputUnion rawFields+    validateUnwrapped err (DataEnum tags) value =+      validateEnum (err Nothing) tags value+    validateUnwrapped err (DataScalar dataScalar) value =+      validateScalar typeName dataScalar value err+    validateUnwrapped err _ value = err Nothing value +-- INPUT UNION+validatInputUnion ::+  ( InputConstraints ctx+  ) =>+  TypeName ->+  DataInputUnion ->+  Object RESOLVED ->+  InputValidator ctx (Value VALID)+validatInputUnion typeName inputUnion rawFields =+  case constraintInputUnion inputUnion rawFields of+    Left message -> castFailure (TypeRef typeName Nothing []) (Just message) (Object rawFields)+    Right (name, Nothing) -> pure (mkInputObject name [])+    Right (name, Just value) -> validatInputUnionMember name value++validatInputUnionMember ::+  ( InputConstraints ctx+  ) =>+  TypeName ->+  Value RESOLVED ->+  InputValidator ctx (Value VALID)+validatInputUnionMember name value = do+  inputDef <- askInputMember name+  validValue <-+    validateInput+      [TypeMaybe]+      inputDef+      (ObjectEntry (toFieldName name) value)+  pure $ mkInputObject name [ObjectEntry (toFieldName name) validValue]++mkInputObject :: TypeName -> [ObjectEntry s] -> Value s+mkInputObject name xs = Object $ unsafeFromValues $ ObjectEntry "__typename" (Enum name) : xs++-- INUT Object+validateInputObject ::+  ( InputConstraints ctx+  ) =>+  FieldsDefinition IN ->+  Object RESOLVED ->+  InputValidator ctx (Object VALID)+validateInputObject fieldsDef object =+  do+    kind <- asks kind+    case kind of+      TYPE ->+        traverse_ (`requiredFieldIsDefined` object) fieldsDef+          *> traverse (`validateField` fieldsDef) object+      _ ->+        traverse_ (`selectKnown` fieldsDef) object+          *> validateObjectWithDefaultValue object fieldsDef++validateField ::+  ( InputConstraints ctx+  ) =>+  ObjectEntry RESOLVED ->+  FieldsDefinition IN ->+  InputValidator ctx (ObjectEntry VALID)+validateField entry parentFields = do+  field <- selectKnown entry parentFields+  validateInputField field entry++validateObjectWithDefaultValue ::+  (InputConstraints c) =>+  Object RESOLVED ->+  FieldsDefinition IN ->+  Validator (InputContext c) (Object VALID)+validateObjectWithDefaultValue object fieldsDef =+  traverse (validateFieldWithDefaultValue object) (elems fieldsDef)+    >>= fromElems++validateFieldWithDefaultValue ::+  (InputConstraints c) =>+  Object RESOLVED ->+  FieldDefinition IN ->+  Validator (InputContext c) (ObjectEntry VALID)+validateFieldWithDefaultValue object fieldDef@FieldDefinition {fieldName} = do+  entry <- selectWithDefaultValue (ObjectEntry fieldName) fieldDef object+  validateInputField fieldDef entry++validateInputField ::+  (InputConstraints c) =>+  FieldDefinition IN ->+  ObjectEntry RESOLVED ->+  Validator (InputContext c) (ObjectEntry VALID)+validateInputField fieldDef@FieldDefinition {fieldName, fieldType = TypeRef {typeConName, typeWrappers}} entry = do+  inputTypeDef <- askInputFieldType fieldDef+  withInputScope (Prop fieldName typeConName) $+    ObjectEntry fieldName+      <$> validateInput+        typeWrappers+        inputTypeDef+        entry++requiredFieldIsDefined ::+  ( MissingRequired (Object RESOLVED) (InputContext ctx),+    GetWith ctx Scope+  ) =>+  FieldDefinition IN ->+  Object RESOLVED ->+  InputValidator ctx (ObjectEntry RESOLVED)+requiredFieldIsDefined fieldDef@FieldDefinition {fieldName} =+  selectWithDefaultValue (ObjectEntry fieldName) fieldDef++-- Leaf Validations validateScalar ::+  forall m.+  (Monad m) =>   TypeName ->   ScalarDefinition ->   ResolvedValue ->-  (Maybe Message -> ResolvedValue -> InputValidator ValidValue) ->-  InputValidator ValidValue+  (Maybe Message -> ResolvedValue -> m ValidValue) ->+  m ValidValue validateScalar typeName ScalarDefinition {validateValue} value err = do   scalarValue <- toScalar value   case validateValue scalarValue of@@ -186,16 +305,20 @@     Left "" -> err Nothing value     Left message -> err (Just $ msg message) value   where-    toScalar :: ResolvedValue -> InputValidator ValidValue+    toScalar :: ResolvedValue -> m ValidValue     toScalar (Scalar x) | isValidDefault typeName x = pure (Scalar x)     toScalar _ = err Nothing value     isValidDefault :: TypeName -> ScalarValue -> Bool     isValidDefault "Boolean" = isBoolean     isValidDefault "String" = isString-    isValidDefault "Float" = \x -> isFloat x || isInt x+    isValidDefault "Float" = oneOf [isFloat, isInt]     isValidDefault "Int" = isInt+    isValidDefault "ID" = oneOf [isInt, isFloat, isString]     isValidDefault _ = const True +oneOf :: [a -> Bool] -> a -> Bool+oneOf ls v = any (v &) ls+ isBoolean :: ScalarValue -> Bool isBoolean Boolean {} = True isBoolean _ = False@@ -212,11 +335,27 @@ isInt Int {} = True isInt _ = False +isVariableValue :: (MonadContext m c, GetWith c InputSource) => m c Bool+isVariableValue =+  \case+    SourceVariable {isDefaultValue} -> not isDefaultValue+    _ -> False+    <$> inputValueSource+ validateEnum ::-  (ResolvedValue -> InputValidator ValidValue) ->+  (MonadContext m c, GetWith c InputSource) =>+  (ResolvedValue -> m c ValidValue) ->   [DataEnumValue] ->   ResolvedValue ->-  InputValidator ValidValue+  m c ValidValue+validateEnum err enumValues value@(Scalar (String enumValue))+  | TypeName enumValue `elem` tags = do+    isFromVariable <- isVariableValue+    if isFromVariable+      then pure (Enum (TypeName enumValue))+      else err value+  where+    tags = map enumName enumValues validateEnum err enumValues value@(Enum enumValue)   | enumValue `elem` tags = pure (Enum enumValue)   | otherwise = err value

@@ -30,19 +30,20 @@     TypeRef (..),     VALID,     Value (..),+    fieldContentArgs,   ) import Data.Morpheus.Types.Internal.Validation   ( InputSource (..),-    SelectionContext (..),+    Scope (..),     SelectionValidator,-    askContext,     askInputFieldType,-    askScopePosition,+    askVariables,+    asks,     selectKnown,     selectRequired,     selectWithDefaultValue,     startInput,-    withScopePosition,+    withPosition,   ) import Data.Morpheus.Validation.Internal.Value   ( validateInput,@@ -62,7 +63,7 @@     resolve (List x) = List <$> traverse resolve x     resolve (Object obj) = Object <$> traverse resolveEntry obj     resolve (VariableValue ref) =-      variables <$> askContext+      askVariables         >>= fmap (ResolvedVariable ref)           . selectRequired ref @@ -88,10 +89,10 @@       fieldType = TypeRef {typeWrappers}     } =     do-      argumentPosition <- askScopePosition+      argumentPosition <- asks position       argument <-         selectWithDefaultValue-          Argument {argumentName = fieldName, argumentValue = Null, argumentPosition}+          (\argumentValue -> Argument {argumentName = fieldName, argumentValue, argumentPosition})           argumentDef           requestArgs       validateArgumentValue argument@@ -99,7 +100,7 @@       -------------------------------------------------------------------------       validateArgumentValue :: Argument RESOLVED -> SelectionValidator (Argument VALID)       validateArgumentValue arg@Argument {argumentValue = value, ..} =-        withScopePosition argumentPosition+        withPosition argumentPosition           $ startInput (SourceArgument arg)           $ do             datatype <- askInputFieldType argumentDef@@ -115,16 +116,14 @@   Arguments RAW ->   SelectionValidator (Arguments VALID) validateFieldArguments-  fieldDef@FieldDefinition {fieldArgs}+  fieldDef@FieldDefinition {fieldContent}   rawArgs =     do       args <- resolveArgumentVariables rawArgs       traverse_ checkUnknown (elems args)       traverse (validateArgument args) argsDef     where-      argsDef = case fieldArgs of-        (ArgumentsDefinition _ argsD) -> argsD-        NoArguments -> empty+      argsDef = maybe empty fieldContentArgs fieldContent       -------------------------------------------------       checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition       checkUnknown = (`selectKnown` fieldDef)@@ -134,16 +133,15 @@   Arguments RAW ->   SelectionValidator (Arguments VALID) validateDirectiveArguments-  directiveDef@DirectiveDefinition {directiveDefinitionArgs}+  directiveDef@DirectiveDefinition+    { directiveDefinitionArgs = ArgumentsDefinition _ argsDef+    }   rawArgs =     do       args <- resolveArgumentVariables rawArgs       traverse_ checkUnknown (elems args)       traverse (validateArgument args) argsDef     where-      argsDef = case directiveDefinitionArgs of-        (ArgumentsDefinition _ argsD) -> argsD-        NoArguments -> empty       -------------------------------------------------       checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition       checkUnknown = (`selectKnown` directiveDef)

@@ -37,6 +37,7 @@ import Data.Morpheus.Types.Internal.Validation   ( BaseValidator,     Constraint (..),+    OperationContext,     Validator,     askFragments,     askSchema,@@ -65,7 +66,7 @@   | fragmentType `elem` typeMembers = pure fragment   | otherwise = failure $ cannotBeSpreadOnType key fragmentType position typeMembers -resolveSpread :: [TypeName] -> Ref -> Validator ctx Fragment+resolveSpread :: [TypeName] -> Ref -> Validator (OperationContext v) Fragment resolveSpread allowedTargets ref@Ref {refName, refPosition} =   askFragments     >>= selectKnown ref

@@ -35,6 +35,7 @@     SelectionSet,     SelectionSet,     TypeName,+    UnionMember (..),     UnionTag (..),     VALID,   )@@ -42,9 +43,10 @@   ( join,   ) import Data.Morpheus.Types.Internal.Validation-  ( SelectionValidator,-    askScopeTypeName,+  ( Scope (..),+    SelectionValidator,     askTypeMember,+    asks,   ) import Data.Morpheus.Validation.Query.Fragment   ( castFragmentType,@@ -55,7 +57,7 @@  -- returns all Fragments used in Union exploreUnionFragments ::-  [TypeName] ->+  [UnionMember OUT] ->   Selection RAW ->   SelectionValidator [Fragment] exploreUnionFragments unionTags = splitFrag@@ -63,14 +65,14 @@     packFragment fragment = [fragment]     splitFrag ::       Selection RAW -> SelectionValidator [Fragment]-    splitFrag (Spread _ ref) = packFragment <$> resolveSpread unionTags ref+    splitFrag (Spread _ ref) = packFragment <$> resolveSpread (map memberName unionTags) ref     splitFrag Selection {selectionName = "__typename", selectionContent = SelectionField} = pure []     splitFrag Selection {selectionName, selectionPosition} = do-      typeName <- askScopeTypeName+      typeName <- asks typename       failure $ unknownSelectionField typeName (Ref selectionName selectionPosition)     splitFrag (InlineFragment fragment) =       packFragment-        <$> castFragmentType Nothing (fragmentPosition fragment) unionTags fragment+        <$> castFragmentType Nothing (fragmentPosition fragment) (map memberName unionTags) fragment  -- sorts Fragment by contitional Types -- [

@@ -22,9 +22,10 @@   ( Eventless,   ) import Data.Morpheus.Types.Internal.Validation-  ( Context (..),+  ( CurrentSelection (..),+    OperationContext (..),+    Scope (..),     ScopeKind (..),-    SelectionContext (..),     runValidator,   ) import Data.Morpheus.Validation.Query.Fragment@@ -56,23 +57,16 @@           }     } =     do-      variables <- runValidator validateHelpers ctx ()-      runValidator-        (validateOperation operation)-        ctx-        SelectionContext-          { variables-          }+      variables <- runValidator validateHelpers (ctx ())+      runValidator (validateOperation operation) (ctx variables)     where-      ctx =-        Context+      ctx variables =+        OperationContext           { schema,             fragments,-            scopeTypeName = "Root",-            scopeSelectionName = "Root",-            scopePosition = operationPosition,-            operationName,-            scopeKind = SELECTION+            scope = Scope {typename = "Root", position = operationPosition, kind = SELECTION},+            selection = CurrentSelection {operationName, selectionName = "Root"},+            variables           }       validateHelpers =         validateFragments operationSelection

@@ -56,7 +56,7 @@     constraint,     selectKnown,     startInput,-    withScopePosition,+    withPosition,   ) import Data.Morpheus.Validation.Internal.Value   ( validateInput,@@ -138,7 +138,7 @@       variablePosition,       variableValue = DefaultValue defaultValue     } =-    withScopePosition variablePosition $+    withPosition variablePosition $       toVariable         <$> ( askSchema                 >>= selectKnown (TypeNameRef (typeConName variableType) variablePosition)@@ -156,10 +156,10 @@         DefaultValue ->         TypeDefinition IN ->         BaseValidator ValidValue-      checkType (Just variable) Nothing varType = validator varType variable+      checkType (Just variable) Nothing varType = validator varType False variable       checkType (Just variable) (Just defValue) varType =-        validator varType defValue >> validator varType variable-      checkType Nothing (Just defValue) varType = validator varType defValue+        validator varType True defValue >> validator varType False variable+      checkType Nothing (Just defValue) varType = validator varType True defValue       checkType Nothing Nothing varType         | validationMode /= WITHOUT_VARIABLES && not (isNullable variableType) =           failure $ uninitializedVariable var@@ -167,11 +167,11 @@           returnNull         where           returnNull =-            maybe (pure Null) (validator varType) (M.lookup variableName bodyVariables)+            maybe (pure Null) (validator varType False) (M.lookup variableName bodyVariables)       ------------------------------------------------------------------------------------------------      validator :: TypeDefinition IN -> ResolvedValue -> BaseValidator ValidValue-      validator varType varValue =-        startInput (SourceVariable var) $+      validator :: TypeDefinition IN -> Bool -> ResolvedValue -> BaseValidator ValidValue+      validator varType isDefaultValue varValue =+        startInput (SourceVariable var isDefaultValue) $           validateInput             (typeWrappers variableType)             varType

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Lib   ( getGQLBody,@@ -6,6 +7,10 @@     getCases,     maybeVariables,     readSource,+    scanSchemaTests,+    FileUrl (..),+    CaseTree (..),+    toString,   ) where @@ -15,7 +20,9 @@ import Data.ByteString.Lazy.Char8 (ByteString) import Data.Maybe (fromMaybe) import Data.Morpheus.Types.Internal.AST (FieldName (..))+import Data.Semigroup ((<>)) import Data.Text (Text, unpack)+import System.Directory (doesDirectoryExist, listDirectory)  readSource :: FieldName -> IO ByteString readSource = L.readFile . path . readName@@ -28,6 +35,52 @@  resLib :: Text -> String resLib x = path x ++ "/response.json"++data FileUrl = FileUrl+  { filePath :: [FilePath],+    fileName :: FilePath+  }+  deriving (Show)++data CaseTree = CaseTree+  { caseUrl :: FileUrl,+    children :: Either [String] [CaseTree]+  }+  deriving (Show)++prefix :: FileUrl -> FilePath -> FileUrl+prefix FileUrl {..} x =+  FileUrl+    { filePath = fileName : filePath,+      fileName = x+    }++toString :: FileUrl -> FilePath+toString FileUrl {..} = foldl (\y x -> x <> "/" <> y) fileName filePath++scanSchemaTests :: FilePath -> IO CaseTree+scanSchemaTests = deepScan++deepScan :: FilePath -> IO CaseTree+deepScan = shouldScan . FileUrl []+  where+    shouldScan :: FileUrl -> IO CaseTree+    shouldScan caseUrl@FileUrl {..} = do+      children <- prefixed caseUrl+      pure CaseTree {..}+    isDirectory :: FileUrl -> IO Bool+    isDirectory = doesDirectoryExist . toString+    prefixed :: FileUrl -> IO (Either [String] [CaseTree])+    prefixed p = do+      dir <- isDirectory p+      if dir+        then do+          list <- map (prefix p) <$> listDirectory (toString p)+          areDirectories <- traverse isDirectory list+          if and areDirectories+            then Right <$> traverse shouldScan list+            else pure $ Left []+        else pure $ Left []  maybeVariables :: FieldName -> IO (Maybe Value) maybeVariables (FieldName x) = decode <$> (L.readFile (path x ++ "/variables.json") <|> return "{}")

@@ -10,12 +10,13 @@  import Control.Monad ((<=<)) import Data.Aeson ((.:), (.=), FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, object)+import qualified Data.ByteString.Lazy as L (readFile) import qualified Data.ByteString.Lazy.Char8 as LB (unpack)+import Data.ByteString.Lazy.Char8 (ByteString) import Data.Either (either) import Data.Morpheus.Core (parseFullGQLDocument, validateSchema) import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    GQLErrors,+  ( GQLErrors,     Schema,   ) import Data.Morpheus.Types.Internal.Resolving@@ -25,16 +26,24 @@ import Data.Semigroup ((<>)) import Data.Text (pack) import GHC.Generics (Generic)-import Lib (readSource)+import Lib+  ( CaseTree (..),+    FileUrl (..),+    scanSchemaTests,+    toString,+  ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase) -readSchema :: FieldName -> IO (Eventless Schema)-readSchema = fmap (validateSchema <=< parseFullGQLDocument) . readSource . ("schema/" <>) . (<> "/schema.gql")+readSource :: String -> IO ByteString+readSource = L.readFile -readResponse :: FieldName -> IO Response-readResponse = fmap (either AesonError id . eitherDecode) . readSource . ("schema/" <>) . (<> "/response.json")+readSchema :: String -> IO (Eventless Schema)+readSchema = fmap (validateSchema <=< parseFullGQLDocument) . readSource . (<> "/schema.gql") +readResponse :: String -> IO Response+readResponse = fmap (either AesonError id . eitherDecode) . readSource . (<> "/response.json")+ data Response   = OK   | Errors {errors :: GQLErrors}@@ -52,23 +61,20 @@   toJSON (Errors err) = object ["errors" .= toJSON err]   toJSON (AesonError err) = String (pack err) -testSchema :: TestTree-testSchema =+toTests :: CaseTree -> TestTree+toTests CaseTree {caseUrl, children = Left {}} = schemaCase caseUrl+toTests CaseTree {caseUrl = FileUrl {fileName}, children = Right children} =   testGroup-    "Test Schema"-    [ testGroup-        "Validation"-        $ map-          (uncurry schemaCase)-          [ ("validation/interface/ok", "interface validation success"),-            ("validation/interface/fail", "interface validation fails")-          ]-    ]+    fileName+    (map toTests children) -schemaCase :: FieldName -> String -> TestTree-schemaCase path description = testCase description $ do-  schema <- readSchema path-  expected <- readResponse path+testSchema :: IO TestTree+testSchema = toTests <$> scanSchemaTests "test/schema"++schemaCase :: FileUrl -> TestTree+schemaCase url = testCase (fileName url) $ do+  schema <- readSchema (toString url)+  expected <- readResponse (toString url)   assertion expected schema  assertion :: Response -> Eventless Schema -> IO ()

@@ -109,16 +109,17 @@       ]  main :: IO ()-main =+main = do+  schema <- testSchema   defaultMain     $ testGroup       "core tests"     $ map       (uncurry basicTest)-      [ ("basic Test", "simple"),-        ("test interface", "interface")+      [ ("basic Test", "api/simple"),+        ("test interface", "api/interface")       ]-      <> [testSchema]+      <> [schema]  basicTest :: String -> FieldName -> TestTree basicTest description path = testCase description $ do

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

@@ -0,0 +1,65 @@+{+  "interface": {+    "kind": "INTERFACE",+    "name": "Character",+    "fields": [+      {+        "name": "name",+        "args": [],+        "type": { "kind": "SCALAR", "name": "String", "ofType": null },+        "isDeprecated": false,+        "deprecationReason": null+      }+    ],+    "inputFields": null,+    "interfaces": null,+    "enumValues": null,+    "possibleTypes": [+      { "kind": "OBJECT", "name": "Deity", "ofType": null },+      { "kind": "OBJECT", "name": "Hero", "ofType": null }+    ]+  },+  "deity": {+    "kind": "OBJECT",+    "name": "Deity",+    "fields": [+      {+        "name": "name",+        "args": [],+        "type": {+          "kind": "NON_NULL",+          "name": null,+          "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }+        },+        "isDeprecated": false,+        "deprecationReason": null+      },+      {+        "name": "power",+        "args": [],+        "type": {+          "kind": "NON_NULL",+          "name": null,+          "ofType": {+            "kind": "LIST",+            "name": null,+            "ofType": {+              "kind": "NON_NULL",+              "name": null,+              "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }+            }+          }+        },+        "isDeprecated": false,+        "deprecationReason": null+      }+    ],+    "inputFields": null,+    "interfaces": [+      { "kind": "INTERFACE", "name": "Character", "ofType": null },+      { "kind": "INTERFACE", "name": "Supernatural", "ofType": null }+    ],+    "enumValues": null,+    "possibleTypes": null+  }+}

@@ -0,0 +1,6 @@+{+  deity {+    name+    power+  }+}

@@ -0,0 +1,6 @@+{+  "deity": {+    "name": "Morpheus",+    "power": ["Shapeshifting"]+  }+}

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

@@ -1,65 +0,0 @@-{-  "interface": {-    "kind": "INTERFACE",-    "name": "Character",-    "fields": [-      {-        "name": "name",-        "args": [],-        "type": { "kind": "SCALAR", "name": "String", "ofType": null },-        "isDeprecated": false,-        "deprecationReason": null-      }-    ],-    "inputFields": null,-    "interfaces": null,-    "enumValues": null,-    "possibleTypes": [-      { "kind": "OBJECT", "name": "Deity", "ofType": null },-      { "kind": "OBJECT", "name": "Hero", "ofType": null }-    ]-  },-  "deity": {-    "kind": "OBJECT",-    "name": "Deity",-    "fields": [-      {-        "name": "name",-        "args": [],-        "type": {-          "kind": "NON_NULL",-          "name": null,-          "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }-        },-        "isDeprecated": false,-        "deprecationReason": null-      },-      {-        "name": "power",-        "args": [],-        "type": {-          "kind": "NON_NULL",-          "name": null,-          "ofType": {-            "kind": "LIST",-            "name": null,-            "ofType": {-              "kind": "NON_NULL",-              "name": null,-              "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }-            }-          }-        },-        "isDeprecated": false,-        "deprecationReason": null-      }-    ],-    "inputFields": null,-    "interfaces": [-      { "kind": "INTERFACE", "name": "Character", "ofType": null },-      { "kind": "INTERFACE", "name": "Supernatural", "ofType": null }-    ],-    "enumValues": null,-    "possibleTypes": null-  }-}

@@ -0,0 +1,1 @@+"OK"

@@ -0,0 +1,35 @@+enum TestEnum {+  EnumA+  EnumB+  EnumC+}++input InputSimple {+  fieldWithDefault: ID! = "value from fieldWithDefault"+  simpleField: TestEnum+}++input InputCompound {+  inputField2: String! = "value from inputField2"+  inputField3: [InputSimple]! = [+    { fieldWithDefault: "value2 from inputField3", simpleField: EnumA }+    { simpleField: EnumA }+  ]+  inputField4: [InputSimple]! = [{ simpleField: EnumB }]+}++type User {+  inputs(+    inputCompound: InputCompound! = {+      inputField2: "value from argument inputCompound"+    }+    input: InputSimple+    comment: String = "test string"+    input3: InputSimple!+    i3: Int+  ): String!+}++type Query {+  user: User+}

@@ -0,0 +1,24 @@+{+  "errors": [+    {+      "message": "Field Query.field(i1:) got invalid default value. in field \"field\": Undefined Field \"field\".",+      "locations": []+    },+    {+      "message": "Field Query.field(i1:) got invalid default value. in field \"field\": Undefined Field \"field2\".",+      "locations": []+    },+    {+      "message": "Field Query.field(i2:) got invalid default value. Undefined Field \"field\".",+      "locations": []+    },+    {+      "message": "Field Query.field(i3:) got invalid default value. in field \"field\": Undefined Field \"field2\".",+      "locations": []+    },+    {+      "message": "Field Query.field(i3:) got invalid default value. in field \"field.field\": Undefined Field \"field\".",+      "locations": []+    }+  ]+}

@@ -0,0 +1,22 @@+input Input1 {+  field: Int!+}++input Input2 {+  field: Input1!+  field2: Int!+  field3: Int+  field4: Int! = 123+}++input Input3 {+  field: Input2!+}++type Query {+  field(+    i1: Input3 = { field: {} }+    i2: Input3 = {}+    i3: Input3 = { field: { field: {} } }+  ): Int+}

@@ -0,0 +1,32 @@+{+  "errors": [+    {+      "message": "Field Query.field(i1:) got invalid default value. in field \"field1.field2\": Expected type \"String\" found 1.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Query.field(i1:) got invalid default value. in field \"field2\": Expected type \"String\" found true.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Query.field(i2:) got invalid default value. in field \"field1\": Expected type \"ID\" found {field3: 2344}.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Query.field(i2:) got invalid default value. in field \"field2\": Expected type \"String\" found 123.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Query.field(i3:) got invalid default value. Expected type \"TestEnum\" found EnumBB.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Query.field(i4:) got invalid default value. Expected type \"ID\" found true.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Query.field(i5:) got invalid default value. Expected type \"Int\" found \"some text\".",+      "locations": [{ "line": 0, "column": 0 }]+    }+  ]+}

@@ -0,0 +1,25 @@+enum TestEnum {+  EnumA+  EnumB+}++input Input1 {+  field1: ID = 1+  field2: String = "some text"+  field3: TestEnum = EnumB+}++input Input2 {+  field1: Input1+  field2: String+}++type Query {+  field(+    i1: Input2 = { field1: { field2: 1 }, field2: true }+    i2: Input1 = { field1: { field3: 2344 }, field2: 123 }+    i3: TestEnum = EnumBB+    i4: ID = true+    i5: Int = "some text"+  ): Int+}

@@ -0,0 +1,16 @@+{+  "errors": [+    {+      "message": "Field Query.field(i1:) got invalid default value. in field \"field.field\": Unknown Field \"field3\".",+      "locations": []+    },+    {+      "message": "Field Query.field(i1:) got invalid default value. in field \"field\": Unknown Field \"field2\".",+      "locations": []+    },+    {+      "message": "Field Query.field(i1:) got invalid default value. Unknown Field \"field2\".",+      "locations": []+    }+  ]+}

@@ -0,0 +1,20 @@+input Input1 {+  field: Int = 123+}++input Input2 {+  field: Input1 = {}+}++input Input3 {+  field: Input2 = {}+}++type Query {+  field(+    i1: Input3 = {+      field: { field2: null, field: { field3: null } }+      field2: null+    }+  ): Int+}

@@ -0,0 +1,1 @@+"OK"

@@ -0,0 +1,23 @@+enum TestEnum {+  EnumA+  EnumB+  EnumC+}++input InputSimple {+  fieldWithDefault: ID! = "value from fieldWithDefault"+  simpleField: TestEnum+}++input InputCompound {+  inputField2: String! = "value from inputField2"+  inputField3: [InputSimple]! = [+    { fieldWithDefault: "value2 from inputField3", simpleField: EnumA }+    { simpleField: EnumA }+  ]+  inputField4: [InputSimple]! = [{ simpleField: EnumB }]+}++type Query {+  field: String!+}

@@ -0,0 +1,12 @@+{+  "errors": [+    {+      "message": "Field Input3.field1 got invalid default value. Undefined Field \"field2\".",+      "locations": []+    },+    {+      "message": "Field Input3.field1 got invalid default value. in field \"field\": Undefined Field \"field\".",+      "locations": []+    }+  ]+}

@@ -0,0 +1,18 @@+input Input1 {+  field: Int!+}++input Input2 {+  field: Input1!+  field2: Int!+  field3: Int+  field4: Int! = 123+}++input Input3 {+  field1: Input2! = { field: {} }+}++type Query {+  field: Int+}

@@ -0,0 +1,36 @@+{+  "errors": [+    {+      "message": "Field Input2.objectField got invalid default value. in field \"field1\": Expected type \"ID!\" found true.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Input2.objectField got invalid default value. in field \"field2\": Expected type \"String!\" found true.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Input2.objectField got invalid default value. in field \"field3\": Expected type \"TestEnum\" found true.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Input1.field1 got invalid default value. Expected type \"ID!\" found EnumA.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Input1.field2 got invalid default value. Expected type \"String!\" found EnumA.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Input1.field3 got invalid default value. Expected type \"TestEnum\" found UnknownEnum.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Input1.field4 got invalid default value. Expected type \"TestEnum!\" found 1.",+      "locations": [{ "line": 0, "column": 0 }]+    },+    {+      "message": "Field Input1.field5 got invalid default value. Expected type \"TestEnum\" found \"some text\".",+      "locations": [{ "line": 0, "column": 0 }]+    }+  ]+}

@@ -0,0 +1,22 @@+enum TestEnum {+  EnumA+  EnumB+  EnumC+}++input Input1 {+  field1: ID! = EnumA+  field2: String! = EnumA+  field3: TestEnum = UnknownEnum+  field4: TestEnum! = 1+  field5: TestEnum = "some text"+}++input Input2 {+  objectField: Input1 = { field1: true, field2: true, field3: true }+  fieldString: String+}++type Query {+  field: Int+}

@@ -0,0 +1,16 @@+{+  "errors": [+    {+      "message": "Field Input3.field got invalid default value. in field \"field\": Unknown Field \"field2\".",+      "locations": []+    },+    {+      "message": "Field Input3.field got invalid default value. in field \"field\": Unknown Field \"field3\".",+      "locations": []+    },+    {+      "message": "Field Input3.field got invalid default value. Unknown Field \"field2\".",+      "locations": []+    }+  ]+}

@@ -0,0 +1,18 @@+input Input1 {+  field: Int+}++input Input2 {+  field: Input1+}++input Input3 {+  field: Input2 = {+    field: { field: null, field2: null, field3: null }+    field2: null+  }+}++type Query {+  field: Int+}

@@ -1,16 +0,0 @@-{-  "errors": [-    {-      "message": "type \"Deity\" implements Interface \"Character\" Partially, on key \"name\" expected type \"String\" found \"Int\".",-      "locations": []-    },-    {-      "message": "type \"Deity\" implements Interface \"Supernatural\" Partially, on key \"power\" expected type \"[String!]!\" found \"[String!]\".",-      "locations": []-    },-    {-      "message": "type \"Hero\" implements Interface \"Character\" Partially, key \"name\" not found .",-      "locations": []-    }-  ]-}

@@ -1,33 +0,0 @@-type Query {-  deity(name: String): Deity!-}--interface Character {-  name: String-}--interface Supernatural {-  power: [String!]!-}--type Hero implements Character {-  field: String-}--type Deity implements Character & Supernatural {-  name: Int-  power: [String!]-}--# TODO: validate arguments-# interface Aged {-#   age(num: Int): String!-# }--# type Human implements Aged {-#   age(num: Int!): String-# }--# type God implements Aged {-#   age(date: String!): String-# }

@@ -0,0 +1,16 @@+{+  "errors": [+    {+      "message": "Interface field argument Character.name(id:) expected but Deity.name does not provide it.",+      "locations": []+    },+    {+      "message": "Interface field argument Supernatural.power(id:) expects type\"ID!\" but Deity.power(id:) is type \"String!\".",+      "locations": []+    },+    {+      "message": "Interface field argument Supernatural.power(id:) expects type\"ID!\" but Hero.power(id:) is type \"ID\".",+      "locations": []+    }+  ]+}

@@ -0,0 +1,23 @@+type Query {+  deity(name: String): Deity!+}++interface Character {+  name(id: ID): String!+}++interface Supernatural {+  power(id: ID!): [String!]!+}++type Deity implements Character & Supernatural {+  # undefined args (id: String)+  name: String!+  # arg: id has different type+  power(id: String!): [String!]!+}++type Hero implements Supernatural {+  # arg: id has weeker type+  power(id: ID): String!+}

@@ -0,0 +1,1 @@+"OK"

@@ -0,0 +1,18 @@+type Query {+  deity(name: String): Deity!+}++interface Character {+  name(id: ID): String!+}++interface Supernatural {+  power(id: ID!): [String!]!+}++type Deity implements Character & Supernatural {+  # arg id has stronger type+  name(id: ID!): String!+  # arg: has same type+  power(id: ID!, age: Int!): [String!]!+}

@@ -0,0 +1,16 @@+{+  "errors": [+    {+      "message": "Interface field Character.name expects type \"String\" but Deity.name is type \"Int\".",+      "locations": []+    },+    {+      "message": "Interface field Supernatural.power expects type \"[String!]!\" but Deity.power is type \"[String!]\".",+      "locations": []+    },+    {+      "message": "Interface field Character.name expected but \"Hero\" does not provide it.",+      "locations": []+    }+  ]+}

@@ -0,0 +1,20 @@+type Query {+  deity(name: String): Deity!+}++interface Character {+  name: String+}++interface Supernatural {+  power: [String!]!+}++type Hero implements Character {+  field: String+}++type Deity implements Character & Supernatural {+  name: Int+  power: [String!]+}

@@ -0,0 +1,1 @@+"OK"

@@ -0,0 +1,20 @@+type Query {+  deity(name: String): Deity!+}++interface Character {+  name: String+}++interface Supernatural {+  power: [String!]!+}++type Hero implements Character {+  name: String+}++type Deity implements Character & Supernatural {+  name: String!+  power: [String!]!+}

@@ -1,1 +0,0 @@-"OK"

@@ -1,20 +0,0 @@-type Query {-  deity(name: String): Deity!-}--interface Character {-  name: String-}--interface Supernatural {-  power: [String!]!-}--type Hero implements Character {-  name: String-}--type Deity implements Character & Supernatural {-  name: String!-  power: [String!]!-}

@@ -1,6 +0,0 @@-{-  deity {-    name-    power-  }-}

@@ -1,6 +0,0 @@-{-  "deity": {-    "name": "Morpheus",-    "power": ["Shapeshifting"]-  }-}