packages feed

morpheus-graphql-core (empty) → 0.12.0

raw patch · 74 files changed

+9615/−0 lines, 74 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, hashable, megaparsec, morpheus-graphql-core, scientific, tasty, tasty-hunit, template-haskell, text, th-lift-instances, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Daviti Nalchevanidze++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,51 @@+# Morpheus GraphQL Core++core Functionalities of Morpheus GraphQL, can be used to build GraphQL server, client ..++- parser+- validar+- api++## Build GraphQL api with Core++```hs+getSchema :: Monad m => ResponseStream e m Schema+getSchema =+  fromList+    [dsl|+  type Query {+    deity(name: String): Deity!+  }++  type Deity {+    name: String!+    power: [String!]!+  }+|]++resolver :: Monad m => RootResModel e m+resolver =+  RootResModel+    { query =+        pure $+          mkObject+            "Query"+            [("deity", resolveDeity)],+      mutation = pure mkNull,+      subscription = pure mkNull+    }++resolveDeity :: (WithOperation o, Monad m) => Resolver o e m (ResModel o e m)+resolveDeity =+  pure $+    mkObject+      "Deity"+      [ ("name", pure $ mkString "Morpheus"),+        ("power", pure $ mkList [mkString "Shapeshifting"])+      ]++api :: GQLRequest -> ResponseStream e Identity (Value VALID)+api request = do+  schema <- getSchema+  runApi schema resolver request+```
+ changelog.md view
@@ -0,0 +1,13 @@+# Changelog++## 0.12.0 - 21.05.2020++## New features++- parser supports implemnets interfaces seperated with empty spaces++  ```gql+  type T implements A , B C & D {+  ```++- introspection can render interfaces
+ morpheus-graphql-core.cabal view
@@ -0,0 +1,146 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4a337fa1d88f2e1ca1eb76ec72c4bd0e5e91ef67626a02682384994f6731d446++name:           morpheus-graphql-core+version:        0.12.0+synopsis:       Morpheus GraphQL Core+description:    Build GraphQL APIs with your favourite functional language!+category:       web, graphql+homepage:       https://morpheusgraphql.com+bug-reports:    https://github.com/nalchevanidze/morpheus-graphql/issues+author:         Daviti Nalchevanidze+maintainer:     d.nalchevanidze@gmail.com+copyright:      (c) 2019 Daviti Nalchevanidze+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    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++source-repository head+  type: git+  location: https://github.com/nalchevanidze/morpheus-graphql++library+  exposed-modules:+      Data.Morpheus.Core+      Data.Morpheus.QuasiQuoter+      Data.Morpheus.Error+      Data.Morpheus.Internal.TH+      Data.Morpheus.Internal.Utils+      Data.Morpheus.Types.Internal.AST+      Data.Morpheus.Types.IO+      Data.Morpheus.Types.Internal.Resolving+  other-modules:+      Data.Morpheus.Error.Document.Interface+      Data.Morpheus.Error.Fragment+      Data.Morpheus.Error.Input+      Data.Morpheus.Error.Internal+      Data.Morpheus.Error.NameCollision+      Data.Morpheus.Error.Operation+      Data.Morpheus.Error.Schema+      Data.Morpheus.Error.Selection+      Data.Morpheus.Error.Utils+      Data.Morpheus.Error.Variable+      Data.Morpheus.Error.Warning+      Data.Morpheus.Parser+      Data.Morpheus.Parsing.Document.TypeSystem+      Data.Morpheus.Parsing.Internal.Arguments+      Data.Morpheus.Parsing.Internal.Internal+      Data.Morpheus.Parsing.Internal.Pattern+      Data.Morpheus.Parsing.Internal.Terms+      Data.Morpheus.Parsing.Internal.Value+      Data.Morpheus.Parsing.JSONSchema.Parse+      Data.Morpheus.Parsing.JSONSchema.Types+      Data.Morpheus.Parsing.Request.Operation+      Data.Morpheus.Parsing.Request.Parser+      Data.Morpheus.Parsing.Request.Selection+      Data.Morpheus.Rendering.RenderGQL+      Data.Morpheus.Rendering.RenderIntrospection+      Data.Morpheus.Schema.Directives+      Data.Morpheus.Schema.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.MergeSet+      Data.Morpheus.Types.Internal.AST.OrderedMap+      Data.Morpheus.Types.Internal.AST.Selection+      Data.Morpheus.Types.Internal.AST.TH+      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.Validator+      Data.Morpheus.Types.SelectionTree+      Data.Morpheus.Validation.Document.Validation+      Data.Morpheus.Validation.Internal.Directive+      Data.Morpheus.Validation.Internal.Value+      Data.Morpheus.Validation.Query.Arguments+      Data.Morpheus.Validation.Query.Fragment+      Data.Morpheus.Validation.Query.Selection+      Data.Morpheus.Validation.Query.UnionSelection+      Data.Morpheus.Validation.Query.Validation+      Data.Morpheus.Validation.Query.Variable+      Paths_morpheus_graphql_core+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson >=1.4.4.0 && <=1.6+    , base >=4.7 && <5+    , bytestring >=0.10.4 && <0.11+    , hashable >=1.0.0+    , megaparsec >=7.0.0 && <9.0.0+    , scientific >=0.3.6.2 && <0.4+    , template-haskell >=2.0 && <=3.0+    , text >=1.2.3.0 && <1.3+    , th-lift-instances >=0.1.1 && <=0.3+    , transformers >=0.3.0.0 && <0.6+    , unordered-containers >=0.2.8.0 && <0.3+    , vector >=0.12.0.1 && <0.13+  default-language: Haskell2010++test-suite morpheus-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Lib+      Schema+      Paths_morpheus_graphql_core+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring >=0.10.4 && <0.11+    , hashable >=1.0.0+    , megaparsec >=7.0.0 && <9.0.0+    , morpheus-graphql-core+    , scientific >=0.3.6.2 && <0.4+    , tasty+    , tasty-hunit+    , template-haskell >=2.0 && <=3.0+    , text >=1.2.3.0 && <1.3+    , th-lift-instances >=0.1.1 && <=0.3+    , transformers >=0.3.0.0 && <0.6+    , unordered-containers >=0.2.8.0 && <0.3+    , vector >=0.12.0.1 && <0.13+  default-language: Haskell2010
+ src/Data/Morpheus/Core.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Morpheus.Core+  ( runApi,+    EventCon,+    parseDSL,+    parseFullGQLDocument,+    parseGQLDocument,+    decodeIntrospection,+    parseTypeSystemDefinition,+    parseTypeDefinitions,+    validateRequest,+    parseRequestWith,+    validateSchema,+    parseRequest,+    RenderGQL (..),+    SelectionTree (..),+  )+where++-- MORPHEUS+import Control.Monad ((>=>))+import Data.ByteString.Lazy.Char8+  ( ByteString,+  )+import Data.Morpheus.Internal.Utils+  ( empty,+  )+import Data.Morpheus.Parser+  ( parseRequest,+    parseRequestWith,+    parseTypeDefinitions,+    parseTypeSystemDefinition,+  )+import Data.Morpheus.Parsing.JSONSchema.Parse+  ( decodeIntrospection,+  )+import Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+  )+import Data.Morpheus.Schema.Schema (withSystemTypes)+import Data.Morpheus.Schema.SchemaAPI (withSystemFields)+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( Operation (..),+    Schema (..),+    Selection (..),+    SelectionContent (..),+    VALID,+    Value,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Context (..),+    Eventless,+    GQLChannel (..),+    ResponseStream,+    ResultT (..),+    RootResModel,+    cleanEvents,+    resultOr,+    runRootResModel,+  )+import Data.Morpheus.Types.SelectionTree (SelectionTree (..))+import Data.Morpheus.Validation.Document.Validation (validateSchema)+import Data.Morpheus.Validation.Query.Validation+  ( validateRequest,+  )+import qualified Data.Text.Lazy as LT+  ( toStrict,+  )+import Data.Text.Lazy.Encoding (decodeUtf8)+import Data.Typeable (Typeable)++type EventCon event =+  (Eq (StreamChannel event), Typeable event, GQLChannel event)++runApi ::+  forall event m.+  (Monad m) =>+  Schema ->+  RootResModel event m ->+  GQLRequest ->+  ResponseStream event m (Value VALID)+runApi inputSchema resModel request = do+  ctx <- validRequest+  model <- withSystemFields (schema ctx) resModel+  runRootResModel model ctx+  where+    validRequest ::+      Monad m => ResponseStream event m Context+    validRequest = cleanEvents $ ResultT $ pure $ do+      validSchema <- validateSchema inputSchema+      schema <- withSystemTypes validSchema+      operation <- parseRequestWith schema request+      pure $+        Context+          { schema,+            operation,+            currentTypeName = "Root",+            currentSelection =+              Selection+                { selectionName = "Root",+                  selectionArguments = empty,+                  selectionPosition = operationPosition operation,+                  selectionAlias = Nothing,+                  selectionContent = SelectionSet (operationSelection operation),+                  selectionDirectives = []+                }+          }++parseDSL :: ByteString -> Either String Schema+parseDSL = resultOr (Left . show) pure . parseGQLDocument++parseGQLDocument :: ByteString -> Eventless Schema+parseGQLDocument = parseTypeSystemDefinition . LT.toStrict . decodeUtf8++parseFullGQLDocument :: ByteString -> Eventless Schema+parseFullGQLDocument = parseGQLDocument >=> withSystemTypes
+ src/Data/Morpheus/Error.hs view
@@ -0,0 +1,18 @@+module Data.Morpheus.Error+  ( errorMessage,+    globalErrorMessage,+    internalError,+    internalTypeMismatch,+    gqlWarnings,+    renderGQLErrors,+    deprecatedField,+  )+where++import Data.Morpheus.Error.Internal+import Data.Morpheus.Error.Utils+import Data.Morpheus.Error.Warning+  ( deprecatedField,+    gqlWarnings,+    renderGQLErrors,+  )
+ src/Data/Morpheus/Error/Document/Interface.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Document.Interface+  ( unknownInterface,+    partialImplements,+    ImplementsError (..),+  )+where++import Data.Morpheus.Error.Utils (globalErrorMessage)+import Data.Morpheus.Types.Internal.AST.Base+  ( FieldName,+    GQLError (..),+    GQLErrors,+    TypeName,+    TypeRef,+    msg,+  )+import Data.Semigroup ((<>))++unknownInterface :: TypeName -> GQLErrors+unknownInterface name = globalErrorMessage message+  where+    message = "Unknown Interface " <> msg name <> "."++data ImplementsError+  = UnexpectedType+      { expectedType :: TypeRef,+        foundType :: TypeRef+      }+  | UndefinedField++partialImplements :: TypeName -> [(TypeName, FieldName, ImplementsError)] -> GQLErrors+partialImplements name = map impError+  where+    impError (interfaceName, key, 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 ."
+ src/Data/Morpheus/Error/Fragment.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Fragment+  ( cannotSpreadWithinItself,+    cannotBeSpreadOnType,+  )+where++-- MORPHEUS+import Data.Morpheus.Error.Utils (errorMessage)+import Data.Morpheus.Types.Internal.AST.Base+  ( FieldName,+    GQLError (..),+    GQLErrors,+    Position,+    Ref (..),+    TypeName,+    msg,+    msgSepBy,+  )+import Data.Semigroup ((<>))++{-+  FRAGMENT:+    type Experience {+        experience ( lang: LANGUAGE ) : String ,+        date: String+    }+    fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."+    fragment H on T1 { ...A} , fragment A on T { ...H } -> "Cannot spread fragment \"H\" within itself via A."+    fragment H on D {...}  ->  "Unknown type \"D\"."+    {...H} -> "Unknown fragment \"H\"."+-}++cannotSpreadWithinItself :: [Ref] -> GQLErrors+cannotSpreadWithinItself fragments = [GQLError {message = text, locations = map refPosition fragments}]+  where+    text =+      "Cannot spread fragment "+        <> msg (refName $ head fragments)+        <> " within itself via "+        <> msgSepBy ", " (map refName fragments)+        <> "."++-- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."+cannotBeSpreadOnType :: Maybe FieldName -> TypeName -> Position -> [TypeName] -> GQLErrors+cannotBeSpreadOnType key fragmentType position typeMembers =+  errorMessage+    position+    text+  where+    text =+      "Fragment "+        <> getName key+        <> "cannot be spread here as objects of type "+        <> msgSepBy ", " typeMembers+        <> " can never be of type "+        <> msg fragmentType+        <> "."+    getName (Just x) = msg x <> " "+    getName Nothing = ""
+ src/Data/Morpheus/Error/Input.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Input+  ( typeViolation,+  )+where++import Data.Morpheus.Types.Internal.AST+  ( Message,+    ResolvedValue,+    TypeRef (..),+    msg,+  )+import Data.Semigroup ((<>))++typeViolation :: TypeRef -> ResolvedValue -> Message+typeViolation expected found =+  "Expected type "+    <> msg expected+    <> " found "+    <> msg found+    <> "."++{-+  ARGUMENTS:+    type Experience {+        experience ( lang: LANGUAGE ) : String ,+        date: String+    }++  - required field !?+  - experience( lang: "bal" ) -> "Expected type LANGUAGE, found \"a\"."+  - experience( lang: Bla ) -> "Expected type LANGUAGE, found Bla."+  - experience( lang: 1 ) -> "Expected type LANGUAGE, found 1."+  - experience( a1 : 1 ) -> "Unknown argument \"a1\" on field \"experience\" of type \"Experience\".",+  - date(name: "name") -> "Unknown argument \"name\" on field \"date\" of type \"Experience\"."+-}
+ src/Data/Morpheus/Error/Internal.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Internal+  ( internalTypeMismatch,+    internalError,+    internalResolvingError,+  )+where++-- MORPHEUS+import Data.Morpheus.Error.Utils (globalErrorMessage)+import Data.Morpheus.Types.Internal.AST.Base+  ( GQLErrors,+    Message,+    msg,+  )+import Data.Morpheus.Types.Internal.AST.Value+  ( ValidValue,+  )+import Data.Morpheus.Types.Internal.Resolving.Core+  ( Eventless,+    Failure (..),+  )+import Data.Semigroup ((<>))++-- GQL:: if no mutation defined -> "Schema is not configured for mutations."+-- all kind internal error in development+internalError :: Message -> Eventless a+internalError x = failure $ globalErrorMessage $ "INTERNAL ERROR: " <> x++internalResolvingError :: Message -> GQLErrors+internalResolvingError = globalErrorMessage . ("INTERNAL ERROR:" <>)++-- if value is already validated but value has different type+internalTypeMismatch :: Message -> ValidValue -> Eventless a+internalTypeMismatch text jsType =+  internalError $ "Type mismatch " <> text <> msg jsType
+ src/Data/Morpheus/Error/NameCollision.hs view
@@ -0,0 +1,12 @@+module Data.Morpheus.Error.NameCollision+  ( NameCollision (..),+  )+where++import Data.Morpheus.Internal.Utils (KeyOf (..))+import Data.Morpheus.Types.Internal.AST.Base+  ( GQLError (..),+  )++class NameCollision a where+  nameCollision :: KEY a -> a -> GQLError
+ src/Data/Morpheus/Error/Operation.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Operation+  ( mutationIsNotDefined,+    subscriptionIsNotDefined,+  )+where++import Data.Morpheus.Error.Utils (errorMessage)+import Data.Morpheus.Types.Internal.AST.Base+  ( GQLErrors,+    Position,+  )++mutationIsNotDefined :: Position -> GQLErrors+mutationIsNotDefined position =+  errorMessage position "Schema is not configured for mutations."++subscriptionIsNotDefined :: Position -> GQLErrors+subscriptionIsNotDefined position =+  errorMessage position "Schema is not configured for subscriptions."
+ src/Data/Morpheus/Error/Schema.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Schema+  ( nameCollisionError,+    schemaValidationError,+  )+where++import Data.Morpheus.Error.Utils (globalErrorMessage)+import Data.Morpheus.Types.Internal.AST.Base+  ( GQLErrors,+    Message,+    TypeName,+    msg,+  )+import Data.Semigroup ((<>))++schemaValidationError :: Message -> GQLErrors+schemaValidationError error' =+  globalErrorMessage $ "Schema Validation Error, " <> error'++nameCollisionError :: TypeName -> GQLErrors+nameCollisionError typeName =+  schemaValidationError $+    "Name collision: "+      <> msg typeName+      <> " is used for different dataTypes in two separate modules"
+ src/Data/Morpheus/Error/Selection.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Selection+  ( unknownSelectionField,+    subfieldsNotSelected,+    hasNoSubfields,+  )+where++import Data.Morpheus.Error.Utils (errorMessage)+import Data.Morpheus.Types.Internal.AST.Base+  ( FieldName,+    GQLErrors,+    Position,+    Ref (..),+    TypeName,+    msg,+  )+import Data.Semigroup ((<>))++-- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields."+hasNoSubfields :: Ref -> TypeName -> GQLErrors+hasNoSubfields (Ref selectionName position) typeName = errorMessage position text+  where+    text =+      "Field "+        <> msg selectionName+        <> " must not have a selection since type "+        <> msg typeName+        <> " has no subfields."++unknownSelectionField :: TypeName -> Ref -> GQLErrors+unknownSelectionField typeName Ref {refName, refPosition} = errorMessage refPosition text+  where+    text =+      "Cannot query field " <> msg refName+        <> " on type "+        <> msg typeName+        <> "."++-- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"?+subfieldsNotSelected :: FieldName -> TypeName -> Position -> GQLErrors+subfieldsNotSelected fieldName typeName position = errorMessage position text+  where+    text =+      "Field " <> msg fieldName <> " of type "+        <> msg typeName+        <> " must have a selection of subfields"
+ src/Data/Morpheus/Error/Utils.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Utils+  ( errorMessage,+    globalErrorMessage,+    badRequestError,+  )+where++import Data.ByteString.Lazy.Char8+  ( ByteString,+    pack,+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( GQLError (..),+    GQLErrors,+    Message,+    Position (..),+  )+import Data.Semigroup ((<>))++errorMessage :: Position -> Message -> GQLErrors+errorMessage position message = [GQLError {message, locations = [position]}]++globalErrorMessage :: Message -> GQLErrors+globalErrorMessage message = [GQLError {message, locations = []}]++badRequestError :: String -> ByteString+badRequestError = ("Bad Request. Could not decode Request body: " <>) . pack
+ src/Data/Morpheus/Error/Variable.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Variable+  ( uninitializedVariable,+    incompatibleVariableType,+  )+where++import Data.Morpheus.Error.Utils (errorMessage)+import Data.Morpheus.Types.Internal.AST+  ( GQLErrors,+    Ref (..),+    TypeRef,+    Variable (..),+    msg,+  )+import Data.Semigroup ((<>))++-- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"."+incompatibleVariableType :: Ref -> Variable s -> TypeRef -> GQLErrors+incompatibleVariableType+  (Ref variableName argPosition)+  Variable {variableType}+  argumentType =+    errorMessage argPosition text+    where+      text =+        "Variable "+          <> msg ("$" <> variableName)+          <> " of type "+          <> msg variableType+          <> " used in position expecting type "+          <> msg argumentType+          <> "."++uninitializedVariable :: Variable s -> GQLErrors+uninitializedVariable Variable {variableName, variableType, variablePosition} =+  errorMessage+    variablePosition+    $ "Variable "+      <> msg ("$" <> variableName)+      <> " of required type "+      <> msg variableType+      <> " was not provided."
+ src/Data/Morpheus/Error/Warning.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Warning+  ( renderGQLErrors,+    deprecatedEnum,+    deprecatedField,+    gqlWarnings,+  )+where++import Data.Aeson (encode)+import Data.ByteString.Lazy.Char8 (unpack)+import Data.Foldable (traverse_)+-- MORPHEUS+import Data.Morpheus.Error.Utils (errorMessage)+import Data.Morpheus.Types.Internal.AST.Base+  ( Description,+    FieldName,+    GQLErrors,+    Ref (..),+    msg,+  )+import Data.Semigroup ((<>))+import Language.Haskell.TH+  ( Q,+    reportWarning,+  )++renderGQLErrors :: GQLErrors -> String+renderGQLErrors = unpack . encode++deprecatedEnum :: FieldName -> Ref -> Maybe Description -> GQLErrors+deprecatedEnum typeName Ref {refPosition, refName} reason =+  errorMessage refPosition $+    "the enum value "+      <> msg typeName+      <> "."+      <> msg refName+      <> " is deprecated."+      <> msg (maybe "" (" " <>) reason)++deprecatedField :: FieldName -> Ref -> Maybe Description -> GQLErrors+deprecatedField typeName Ref {refPosition, refName} reason =+  errorMessage refPosition $+    "the field "+      <> msg typeName+      <> "."+      <> msg refName+      <> " is deprecated."+      <> msg (maybe "" (" " <>) reason)++gqlWarnings :: GQLErrors -> Q ()+gqlWarnings [] = pure ()+gqlWarnings warnings = traverse_ handleWarning warnings+  where+    handleWarning warning =+      reportWarning ("Morpheus GraphQL Warning: " <> (unpack . encode) warning)
+ src/Data/Morpheus/Internal/TH.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeApplications #-}++module Data.Morpheus.Internal.TH+  ( declareType,+    tyConArgs,+    Scope (..),+    apply,+    applyT,+    typeT,+    instanceHeadT,+    instanceProxyFunD,+    instanceFunD,+    instanceHeadMultiT,+    destructRecord,+    typeInstanceDec,+    infoTyVars,+    decArgs,+    nameLitP,+    nameStringE,+    nameStringL,+    nameConT,+    nameVarE,+    nameVarT,+    nameConType,+    nameConE,+    nameVarP,+    mkTypeName,+  )+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 (..),+    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_++m_ :: TypeName+m_ = "m"++declareTypeRef :: Bool -> TypeRef -> Type+declareTypeRef isSub TypeRef {typeConName, typeWrappers, typeArgs} =+  wrappedT+    typeWrappers+  where+    wrappedT :: [TypeWrapper] -> Type+    wrappedT (TypeList : xs) = AppT (ConT ''[]) $ wrappedT xs+    wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs+    wrappedT [] = decType typeArgs+    ------------------------------------------------------+    typeName = nameConType typeConName+    --------------------------------------------+    decType _+      | isSub =+        AppT typeName (AppT (ConT ''UnSubResolver) m')+    decType (Just par) = AppT typeName (VarT $ mkTypeName par)+    decType _ = typeName++tyConArgs :: DataTypeKind -> [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)++applyT :: Name -> [Q Type] -> Q Type+applyT name = foldl appT (conT name)++typeT :: Name -> [TypeName] -> Q Type+typeT name li = applyT name (map (varT . mkTypeName) li)++instanceHeadT :: Name -> TypeName -> [TypeName] -> Q Type+instanceHeadT cName iType tArgs = applyT cName [applyT (mkTypeName iType) (map (varT . mkTypeName) tArgs)]++instanceProxyFunD :: (Name, ExpQ) -> DecQ+instanceProxyFunD (name, body) = instanceFunD name ["_"] body++instanceFunD :: Name -> [TypeName] -> ExpQ -> Q Dec+instanceFunD name args body = funD name [clause (map (varP . mkTypeName) args) (normalB body) []]++instanceHeadMultiT :: Name -> Q Type -> [Q Type] -> Q Type+instanceHeadMultiT className iType li = applyT className (iType : li)++-- "User" -> ["name","id"] -> (User name id)+destructRecord :: TypeName -> [FieldName] -> PatQ+destructRecord conName fields = conP (mkTypeName conName) (map (varP . mkFieldName) fields)++typeInstanceDec :: Name -> Type -> Type -> Dec++nameLitP :: TypeName -> PatQ+nameLitP = litP . nameStringL++nameStringL :: TypeName -> Lit+nameStringL = stringL . unpack . readTypeName++nameStringE :: TypeName -> ExpQ+nameStringE = stringE . (unpack . readTypeName)++#if MIN_VERSION_template_haskell(2,15,0)+-- fix breaking changes+typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res)+#else+--+typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res)+#endif++infoTyVars :: Info -> [TyVarBndr]+infoTyVars (TyConI x) = decArgs x+infoTyVars _ = []++decArgs :: Dec -> [TyVarBndr]+decArgs (DataD _ _ args _ _ _) = args+decArgs (NewtypeD _ _ args _ _ _) = args+decArgs (TySynD _ args _) = args+decArgs _ = []++mkTypeName :: TypeName -> Name+mkTypeName = mkName . unpack . readTypeName++mkFieldName :: FieldName -> Name+mkFieldName = mkName . unpack . readName . convertToHaskellName++nameConT :: TypeName -> Q Type+nameConT = conT . mkTypeName++nameConType :: TypeName -> Type+nameConType = ConT . mkTypeName++nameVarT :: TypeName -> Q Type+nameVarT = varT . mkTypeName++nameVarE :: FieldName -> ExpQ+nameVarE = varE . mkFieldName++nameConE :: TypeName -> ExpQ+nameConE = conE . mkTypeName++nameVarP :: FieldName -> PatQ+nameVarP = varP . mkFieldName
+ src/Data/Morpheus/Internal/Utils.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Internal.Utils+  ( capital,+    nonCapital,+    nameSpaceField,+    nameSpaceType,+    capitalTypeName,+    Collection (..),+    Selectable (..),+    Listable (..),+    Merge (..),+    Failure (..),+    KeyOf (..),+    toPair,+    selectBy,+    member,+    keys,+    size,+    (<:>),+    mapFst,+    mapSnd,+    mapTuple,+  )+where++import Data.Char+  ( toLower,+    toUpper,+  )+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HM+import Data.Hashable (Hashable)+import Data.List (find)+import Data.Morpheus.Types.Internal.AST.Base+  ( FieldName,+    FieldName (..),+    GQLErrors,+    Ref (..),+    Token,+    TypeName (..),+    TypeNameRef (..),+  )+import Data.Semigroup ((<>))+import qualified Data.Text as T+  ( concat,+    pack,+    unpack,+  )+import Instances.TH.Lift ()+import Text.Megaparsec.Internal (ParsecT (..))+import Text.Megaparsec.Stream (Stream)++mapText :: (String -> String) -> Token -> Token+mapText f = T.pack . f . T.unpack++nameSpaceType :: [FieldName] -> TypeName -> TypeName+nameSpaceType list (TypeName name) = TypeName . T.concat $ map capital (map readName list <> [name])++nameSpaceField :: TypeName -> FieldName -> FieldName+nameSpaceField nSpace (FieldName name) = FieldName (nonCapital nSpace <> capital name)++nonCapital :: TypeName -> Token+nonCapital = mapText __nonCapital . readTypeName+  where+    __nonCapital [] = []+    __nonCapital (x : xs) = toLower x : xs++capital :: Token -> Token+capital = mapText __capital+  where+    __capital [] = []+    __capital (x : xs) = toUpper x : xs++capitalTypeName :: FieldName -> TypeName+capitalTypeName = TypeName . capital . readName++--(KEY v ~ k) =>+class Collection a coll | coll -> a where+  empty :: coll+  singleton :: a -> coll++instance Collection a [a] where+  empty = []+  singleton x = [x]++instance (Hashable k, KeyOf v, k ~ KEY v) => Collection v (HashMap k v) where+  empty = HM.empty+  singleton x = HM.singleton (keyOf x) x++class Selectable c a | c -> a where+  selectOr :: d -> (a -> d) -> KEY a -> c -> d++instance KeyOf a => Selectable [a] a where+  selectOr fb f key lib = maybe fb f (find ((key ==) . keyOf) lib)++instance (KEY a ~ k, Eq k, Hashable k) => Selectable (HashMap k a) a where+  selectOr fb f key lib = maybe fb f (HM.lookup key lib)++selectBy :: (Failure e m, Selectable c a, Monad m) => e -> KEY a -> c -> m a+selectBy err = selectOr (failure err) pure++member :: forall a c. Selectable c a => KEY a -> c -> Bool+member = selectOr False toTrue+  where+    toTrue :: a -> Bool+    toTrue _ = True++class Eq (KEY a) => KeyOf a where+  type KEY a :: *+  type KEY a = FieldName+  keyOf :: a -> KEY a++instance KeyOf Ref where+  keyOf = refName++instance KeyOf TypeNameRef where+  type KEY TypeNameRef = TypeName+  keyOf = typeNameRef++toPair :: KeyOf a => a -> (KEY a, a)+toPair x = (keyOf x, x)++-- list Like Collections+class Listable a coll | coll -> a where+  elems :: coll -> [a]+  fromElems :: (KeyOf a, Monad m, Failure GQLErrors m) => [a] -> m coll++keys :: (KeyOf a, Listable a coll) => coll -> [KEY a]+keys = map keyOf . elems++size :: Listable a coll => coll -> Int+size = length . elems++-- Merge Object with of Failure as an Option+class Merge a where+  merge :: (Monad m, Failure GQLErrors m) => [Ref] -> a -> a -> m a++(<:>) :: (Monad m, Merge a, Failure GQLErrors m) => a -> a -> m a+(<:>) = merge []++-- Failure: for custome Morpheus GrapHQL errors+class Applicative f => Failure error (f :: * -> *) where+  failure :: error -> f v++instance Failure error (Either error) where+  failure = Left++instance (Stream s, Ord e, Failure [a] m) => Failure [a] (ParsecT e s m) where+  failure x = ParsecT $ \_ _ _ _ _ -> failure x++mapFst :: (a -> a') -> (a, b) -> (a', b)+mapFst f (a, b) = (f a, b)++mapSnd :: (b -> b') -> (a, b) -> (a, b')+mapSnd f (a, b) = (a, f b)++mapTuple :: (a -> a') -> (b -> b') -> (a, b) -> (a', b')+mapTuple f1 f2 (a, b) = (f1 a, f2 b)
+ src/Data/Morpheus/Parser.hs view
@@ -0,0 +1,52 @@+module Data.Morpheus.Parser+  ( parseTypeDefinitions,+    parseTypeSystemDefinition,+    parseRequest,+    parseRequestWith,+  )+where++import Control.Monad ((>=>))+import Data.Morpheus.Internal.Utils+  ( fromElems,+  )+import Data.Morpheus.Parsing.Document.TypeSystem (parseSchema)+import Data.Morpheus.Parsing.Request.Parser (parseGQL)+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    GQLQuery (..),+    Operation,+    Schema (..),+    TypeDefinition (..),+    VALID,+    VALIDATION_MODE (..),+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+  )+import Data.Morpheus.Validation.Document.Validation+  ( validatePartialDocument,+  )+import Data.Morpheus.Validation.Query.Validation+  ( validateRequest,+  )+import Data.Text (Text)++parseTypeSystemDefinition ::+  Text -> Eventless Schema+parseTypeSystemDefinition =+  parseSchema >=> fromElems++parseTypeDefinitions ::+  Text -> Eventless [TypeDefinition ANY]+parseTypeDefinitions =+  parseSchema >=> validatePartialDocument++parseRequest :: GQLRequest -> Eventless GQLQuery+parseRequest = parseGQL++parseRequestWith :: Schema -> GQLRequest -> Eventless (Operation VALID)+parseRequestWith schema = parseRequest >=> validateRequest schema FULL_VALIDATION
+ src/Data/Morpheus/Parsing/Document/TypeSystem.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Document.TypeSystem+  ( parseSchema,+  )+where++-- MORPHEUS+import Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+    processParser,+  )+import Data.Morpheus.Parsing.Internal.Pattern+  ( enumValueDefinition,+    fieldsDefinition,+    inputFieldsDefinition,+    optionalDirectives,+    typeDeclaration,+  )+import Data.Morpheus.Parsing.Internal.Terms+  ( collection,+    keyword,+    operator,+    optDescription,+    parseTypeName,+    pipeLiteral,+    sepByAnd,+    spaceAndComments,+  )+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    DataFingerprint (..),+    Description,+    IN,+    Meta (..),+    OUT,+    ScalarDefinition (..),+    TypeContent (..),+    TypeDefinition (..),+    TypeName,+    toAny,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+  )+import Data.Text (Text)+import Text.Megaparsec+  ( (<|>),+    eof,+    label,+    manyTill,+    sepBy1,+  )++-- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars+--+--  ScalarTypeDefinition:+--    Description(opt) scalar Name Directives(Const)(opt)+--+scalarTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY)+scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do+  typeName <- typeDeclaration "scalar"+  metaDirectives <- optionalDirectives+  pure+    TypeDefinition+      { typeName,+        typeMeta = Just Meta {metaDescription, metaDirectives},+        typeFingerprint = DataFingerprint typeName [],+        typeContent = DataScalar $ ScalarDefinition pure+      }++-- 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) }+--+--  FieldDefinition+--    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)+--+objectTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)+objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do+  typeName <- typeDeclaration "type"+  objectImplements <- optionalImplementsInterfaces+  metaDirectives <- optionalDirectives+  objectFields <- fieldsDefinition+  -- build object+  pure+    TypeDefinition+      { typeName,+        typeMeta = Just Meta {metaDescription, metaDirectives},+        typeFingerprint = DataFingerprint typeName [],+        typeContent = DataObject {objectImplements, objectFields}+      }++optionalImplementsInterfaces :: Parser [TypeName]+optionalImplementsInterfaces = implements <|> pure []+  where+    implements =+      label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseTypeName++-- Interfaces: https://graphql.github.io/graphql-spec/June2018/#sec-Interfaces+--+--  InterfaceTypeDefinition+--    Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt)+--+interfaceTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)+interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do+  typeName <- typeDeclaration "interface"+  metaDirectives <- optionalDirectives+  fields <- fieldsDefinition+  -- build interface+  pure+    TypeDefinition+      { typeName,+        typeMeta = Just Meta {metaDescription, metaDirectives},+        typeFingerprint = DataFingerprint typeName [],+        typeContent = DataInterface fields+      }++-- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions+--+--  UnionTypeDefinition:+--    Description(opt) union Name Directives(Const)(opt) UnionMemberTypes(opt)+--+--  UnionMemberTypes:+--    = |(opt) NamedType+--      UnionMemberTypes | NamedType+--+unionTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT)+unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do+  typeName <- typeDeclaration "union"+  metaDirectives <- optionalDirectives+  memberTypes <- unionMemberTypes+  -- build union+  pure+    TypeDefinition+      { typeName,+        typeMeta = Just Meta {metaDescription, metaDirectives},+        typeFingerprint = DataFingerprint typeName [],+        typeContent = DataUnion memberTypes+      }+  where+    unionMemberTypes = operator '=' *> parseTypeName `sepBy1` pipeLiteral++-- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums+--+--  EnumTypeDefinition+--    Description(opt) enum Name Directives(Const)(opt) EnumValuesDefinition(opt)+--+--  EnumValuesDefinition+--    { EnumValueDefinition(list) }+--+--  EnumValueDefinition+--    Description(opt) EnumValue Directives(Const)(opt)+--+enumTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY)+enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do+  typeName <- typeDeclaration "enum"+  metaDirectives <- optionalDirectives+  enumValuesDefinitions <- collection enumValueDefinition+  -- build enum+  pure+    TypeDefinition+      { typeName,+        typeContent = DataEnum enumValuesDefinitions,+        typeFingerprint = DataFingerprint typeName [],+        typeMeta = Just Meta {metaDescription, metaDirectives}+      }++-- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects+--+--   InputObjectTypeDefinition+--     Description(opt) input Name  Directives(Const)(opt) InputFieldsDefinition(opt)+--+--   InputFieldsDefinition:+--     { InputValueDefinition(list) }+--+inputObjectTypeDefinition :: Maybe Description -> Parser (TypeDefinition IN)+inputObjectTypeDefinition metaDescription =+  label "InputObjectTypeDefinition" $ do+    typeName <- typeDeclaration "input"+    metaDirectives <- optionalDirectives+    fields <- inputFieldsDefinition+    -- build input+    pure+      TypeDefinition+        { typeName,+          typeContent = DataInputObject fields,+          typeFingerprint = DataFingerprint typeName [],+          typeMeta = Just Meta {metaDescription, metaDirectives}+        }++parseDataType :: Parser (TypeDefinition ANY)+parseDataType = label "TypeDefinition" $ do+  description <- optDescription+  -- scalar | enum |  input | object | union | interface+  (toAny <$> inputObjectTypeDefinition description)+    <|> (toAny <$> unionTypeDefinition description)+    <|> enumTypeDefinition description+    <|> scalarTypeDefinition description+    <|> (toAny <$> objectTypeDefinition description)+    <|> (toAny <$> interfaceTypeDefinition description)++parseSchema :: Text -> Eventless [TypeDefinition ANY]+parseSchema = processParser request+  where+    request = label "DocumentTypes" $ do+      spaceAndComments+      manyTill parseDataType eof
+ src/Data/Morpheus/Parsing/Internal/Arguments.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Parsing.Internal.Arguments (maybeArguments) where++-- MORPHEUS+import Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+    getLocation,+  )+import Data.Morpheus.Parsing.Internal.Terms+  ( parseAssignment,+    parseName,+    uniqTupleOpt,+  )+import Data.Morpheus.Parsing.Internal.Value+  ( Parse (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    Arguments,+    Value,+  )+import Text.Megaparsec (label)++-- Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments+--+-- Arguments[Const]+-- ( Argument[Const](list) )+--+-- Argument[Const]+--  Name : Value[Const]+valueArgument :: Parse (Value s) => Parser (Argument s)+valueArgument =+  label "Argument" $ do+    argumentPosition <- getLocation+    (argumentName, argumentValue) <- parseAssignment parseName parse+    pure $ Argument {argumentName, argumentValue, argumentPosition}++maybeArguments :: Parse (Value s) => Parser (Arguments s)+maybeArguments =+  label "Arguments" $+    uniqTupleOpt valueArgument
+ src/Data/Morpheus/Parsing/Internal/Internal.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+    Position,+    getLocation,+    processParser,+  )+where++import qualified Data.List.NonEmpty as NonEmpty+import Data.Morpheus.Types.Internal.AST+  ( GQLError (..),+    GQLErrors,+    Position (..),+    msg,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+    Result (..),+    failure,+  )+import Data.Text+  ( Text,+  )+import Data.Void (Void)+import Text.Megaparsec+  ( ParseError,+    ParseErrorBundle+      ( ParseErrorBundle+      ),+    ParsecT,+    SourcePos,+    SourcePos (..),+    attachSourcePos,+    bundleErrors,+    bundlePosState,+    errorOffset,+    getSourcePos,+    parseErrorPretty,+    runParserT,+    unPos,+  )++getLocation :: Parser Position+getLocation = fmap toLocation getSourcePos++toLocation :: SourcePos -> Position+toLocation SourcePos {sourceLine, sourceColumn} =+  Position {line = unPos sourceLine, column = unPos sourceColumn}++type MyError = Void++type Parser = ParsecT MyError Text Eventless++type ErrorBundle = ParseErrorBundle Text MyError++processParser :: Parser a -> Text -> Eventless a+processParser parser txt = case runParserT parser [] txt of+  Success {result} -> case result of+    Right root -> pure root+    Left parseError -> failure (processErrorBundle parseError)+  Failure {errors} -> failure errors++processErrorBundle :: ErrorBundle -> GQLErrors+processErrorBundle = map parseErrorToGQLError . bundleToErrors+  where+    parseErrorToGQLError :: (ParseError Text MyError, SourcePos) -> GQLError+    parseErrorToGQLError (err, position) =+      GQLError+        { message = msg (parseErrorPretty err),+          locations = [toLocation position]+        }+    bundleToErrors ::+      ErrorBundle -> [(ParseError Text MyError, SourcePos)]+    bundleToErrors ParseErrorBundle {bundleErrors, bundlePosState} =+      NonEmpty.toList $ fst $+        attachSourcePos+          errorOffset+          bundleErrors+          bundlePosState
+ src/Data/Morpheus/Parsing/Internal/Pattern.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Data.Morpheus.Parsing.Internal.Pattern+  ( inputValueDefinition,+    fieldsDefinition,+    typeDeclaration,+    optionalDirectives,+    enumValueDefinition,+    inputFieldsDefinition,+  )+where++-- MORPHEUS++import Data.Morpheus.Parsing.Internal.Arguments+  ( maybeArguments,+  )+import Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+  )+import Data.Morpheus.Parsing.Internal.Internal+  ( getLocation,+  )+import Data.Morpheus.Parsing.Internal.Terms+  ( keyword,+    litAssignment,+    operator,+    optDescription,+    parseName,+    parseType,+    parseTypeName,+    setOf,+    uniqTuple,+  )+import Data.Morpheus.Parsing.Internal.Value+  ( Parse (..),+    parseDefaultValue,+  )+import Data.Morpheus.Types.Internal.AST+  ( ArgumentsDefinition (..),+    DataEnumValue (..),+    Directive (..),+    FieldDefinition (..),+    FieldName,+    FieldsDefinition,+    IN,+    InputFieldsDefinition,+    Meta (..),+    OUT,+    TypeName,+    Value,+  )+import Text.Megaparsec+  ( (<|>),+    label,+    many,+  )++--  EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition+--+--  EnumValueDefinition+--    Description(opt) EnumValue Directives(Const)(opt)+--+enumValueDefinition :: Parser DataEnumValue+enumValueDefinition = label "EnumValueDefinition" $ do+  metaDescription <- optDescription+  enumName <- parseTypeName+  metaDirectives <- optionalDirectives+  return $+    DataEnumValue+      { enumName,+        enumMeta = Just Meta {metaDescription, metaDirectives}+      }++-- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition+--+-- InputValueDefinition+--   Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt)+--+inputValueDefinition :: Parser (FieldDefinition IN)+inputValueDefinition = label "InputValueDefinition" $ do+  metaDescription <- optDescription+  fieldName <- parseName+  litAssignment -- ':'+  fieldType <- parseType+  _ <- parseDefaultValue+  metaDirectives <- optionalDirectives+  pure+    FieldDefinition+      { fieldArgs = NoArguments,+        fieldName,+        fieldType,+        fieldMeta = Just Meta {metaDescription, metaDirectives}+      }++-- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments+--+-- ArgumentsDefinition:+--   ( InputValueDefinition(list) )+--+argumentsDefinition :: Parser ArgumentsDefinition+argumentsDefinition =+  label "ArgumentsDefinition" $+    uniqTuple inputValueDefinition+      <|> pure NoArguments++--  FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition+--+--  FieldsDefinition :+--    { FieldDefinition(list) }+--+fieldsDefinition :: Parser (FieldsDefinition OUT)+fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition++--  FieldDefinition+--    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)+--+fieldDefinition :: Parser (FieldDefinition OUT)+fieldDefinition = label "FieldDefinition" $ do+  metaDescription <- optDescription+  fieldName <- parseName+  fieldArgs <- argumentsDefinition+  litAssignment -- ':'+  fieldType <- parseType+  metaDirectives <- optionalDirectives+  pure+    FieldDefinition+      { fieldName,+        fieldArgs,+        fieldType,+        fieldMeta = Just Meta {metaDescription, metaDirectives}+      }++-- InputFieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives+--   InputFieldsDefinition:+--     { InputValueDefinition(list) }+--+inputFieldsDefinition :: Parser InputFieldsDefinition+inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition++-- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives+--+-- example: @directive ( arg1: "value" , .... )+--+-- Directives[Const]+-- Directive[Const](list)+--+optionalDirectives :: Parse (Value s) => Parser [Directive s]+optionalDirectives = label "Directives" $ many directive++-- Directive[Const]+--+-- @ Name Arguments[Const](opt)+directive :: Parse (Value s) => Parser (Directive s)+directive = label "Directive" $ do+  directivePosition <- getLocation+  operator '@'+  directiveName <- parseName+  directiveArgs <- maybeArguments+  pure Directive {..}++-- typDeclaration : Not in spec ,start part of type definitions+--+--  typDeclaration+--   Description(opt) scalar Name+--+typeDeclaration :: FieldName -> Parser TypeName+typeDeclaration kind = do+  keyword kind+  parseTypeName
+ src/Data/Morpheus/Parsing/Internal/Terms.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Data.Morpheus.Parsing.Internal.Terms+  ( token,+    qualifier,+    variable,+    spaceAndComments,+    spaceAndComments1,+    pipeLiteral,+    -------------+    collection,+    setOf,+    uniqTuple,+    uniqTupleOpt,+    parseTypeCondition,+    spreadLiteral,+    parseNonNull,+    parseAssignment,+    parseWrappedType,+    litEquals,+    litAssignment,+    parseTuple,+    parseAlias,+    sepByAnd,+    parseName,+    parseType,+    keyword,+    operator,+    optDescription,+    optionalList,+    parseNegativeSign,+    parseTypeName,+  )+where++import Control.Monad ((>=>))+import Data.Functor (($>))+-- MORPHEUS++import Data.Morpheus.Internal.Utils+  ( KeyOf,+    Listable (..),+    fromElems,+  )+import Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+    Position,+    getLocation,+  )+import Data.Morpheus.Types.Internal.AST+  ( DataTypeWrapper (..),+    Description,+    FieldName (..),+    Ref (..),+    Token,+    TypeName (..),+    TypeRef (..),+    toHSWrappers,+  )+import Data.Text+  ( pack,+    strip,+  )+import Text.Megaparsec+  ( (<?>),+    (<|>),+    between,+    label,+    many,+    manyTill,+    optional,+    sepBy,+    sepEndBy,+    skipMany,+    skipManyTill,+    try,+    try,+  )+import Text.Megaparsec.Char+  ( char,+    digitChar,+    letterChar,+    newline,+    printChar,+    space,+    space1,+    string,+  )++-- Name : https://graphql.github.io/graphql-spec/June2018/#sec-Names+--+-- Name :: /[_A-Za-z][_0-9A-Za-z]*/+--++parseNegativeSign :: Parser Bool+parseNegativeSign = (char '-' $> True <* spaceAndComments) <|> pure False++parseName :: Parser FieldName+parseName = FieldName <$> token++parseTypeName :: Parser TypeName+parseTypeName = TypeName <$> token++keyword :: FieldName -> Parser ()+keyword (FieldName word) = string word *> space1 *> spaceAndComments++operator :: Char -> Parser ()+operator x = char x *> spaceAndComments++-- LITERALS+braces :: Parser [a] -> Parser [a]+braces =+  between+    (char '{' *> spaceAndComments)+    (char '}' *> spaceAndComments)++pipeLiteral :: Parser ()+pipeLiteral = char '|' *> spaceAndComments++litEquals :: Parser ()+litEquals = char '=' *> spaceAndComments++litAssignment :: Parser ()+litAssignment = char ':' *> spaceAndComments++-- PRIMITIVE+------------------------------------+token :: Parser Token+token = label "token" $ do+  firstChar <- letterChar <|> char '_'+  restToken <- many $ letterChar <|> char '_' <|> digitChar+  spaceAndComments+  return $ pack $ firstChar : restToken++qualifier :: Parser (FieldName, Position)+qualifier = label "qualifier" $ do+  position <- getLocation+  value <- parseName+  return (value, position)++-- Variable : https://graphql.github.io/graphql-spec/June2018/#Variable+--+-- Variable :  $Name+--+variable :: Parser Ref+variable = label "variable" $ do+  refPosition <- getLocation+  _ <- char '$'+  refName <- parseName+  spaceAndComments+  pure $ Ref {refName, refPosition}++spaceAndComments1 :: Parser ()+spaceAndComments1 = space1 *> spaceAndComments++-- Descriptions: https://graphql.github.io/graphql-spec/June2018/#Description+--+-- Description:+--   StringValue+-- TODO: should support """ and "+--+optDescription :: Parser (Maybe Description)+optDescription = optional parseDescription++parseDescription :: Parser Description+parseDescription =+  strip . pack <$> (blockDescription <|> singleLine) <* spaceAndComments+  where+    blockDescription =+      blockQuotes+        *> manyTill (printChar <|> newline) blockQuotes+        <* spaceAndComments+      where+        blockQuotes = string "\"\"\""+    ----------------------------+    singleLine =+      stringQuote *> manyTill printChar stringQuote <* spaceAndComments+      where+        stringQuote = char '"'++-- Ignored Tokens : https://graphql.github.io/graphql-spec/June2018/#sec-Source-Text.Ignored-Tokens+--  Ignored:+--    UnicodeBOM+--    WhiteSpace+--    LineTerminator+--    Comment+--    Comma+-- TODO: implement as in specification+spaceAndComments :: Parser ()+spaceAndComments = ignoredTokens++ignoredTokens :: Parser ()+ignoredTokens =+  label "IgnoredTokens" $ space *> skipMany inlineComment *> space+  where+    inlineComment = char '#' *> skipManyTill printChar newline *> space++------------------------------------------------------------------------++-- COMPLEX+sepByAnd :: Parser a -> Parser [a]+sepByAnd entry = entry `sepBy` (optional (char '&') *> spaceAndComments)++-----------------------------+collection :: Parser a -> Parser [a]+collection entry = braces (entry `sepEndBy` many (char ',' *> spaceAndComments))++setOf :: (Listable a coll, KeyOf a) => Parser a -> Parser coll+setOf = collection >=> fromElems++parseNonNull :: Parser [DataTypeWrapper]+parseNonNull = do+  wrapper <- (char '!' $> [NonNullType]) <|> pure []+  spaceAndComments+  return wrapper++optionalList :: Parser [a] -> Parser [a]+optionalList x = x <|> pure []++parseTuple :: Parser a -> Parser [a]+parseTuple parser =+  label "Tuple" $+    between+      (char '(' *> spaceAndComments)+      (char ')' *> spaceAndComments)+      ( parser `sepBy` (many (char ',') *> spaceAndComments) <?> "empty Tuple value!"+      )++uniqTuple :: (Listable a coll, KeyOf a) => Parser a -> Parser coll+uniqTuple = parseTuple >=> fromElems++uniqTupleOpt :: (Listable a coll, KeyOf a) => Parser a -> Parser coll+uniqTupleOpt = optionalList . parseTuple >=> fromElems++parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b)+parseAssignment nameParser valueParser = label "assignment" $ do+  name' <- nameParser+  litAssignment+  value' <- valueParser+  pure (name', value')++-- Type Conditions: https://graphql.github.io/graphql-spec/June2018/#sec-Type-Conditions+--+--  TypeCondition:+--    on NamedType+--+parseTypeCondition :: Parser TypeName+parseTypeCondition = do+  _ <- string "on"+  space1+  parseTypeName++spreadLiteral :: Parser Position+spreadLiteral = do+  index <- getLocation+  _ <- string "..."+  space+  return index++parseWrappedType :: Parser ([DataTypeWrapper], TypeName)+parseWrappedType = (unwrapped <|> wrapped) <* spaceAndComments+  where+    unwrapped :: Parser ([DataTypeWrapper], TypeName)+    unwrapped = ([],) <$> parseTypeName <* spaceAndComments+    ----------------------------------------------+    wrapped :: Parser ([DataTypeWrapper], TypeName)+    wrapped =+      between+        (char '[' *> spaceAndComments)+        (char ']' *> spaceAndComments)+        ( do+            (wrappers, name) <- unwrapped <|> wrapped+            nonNull' <- parseNonNull+            return ((ListType : nonNull') ++ wrappers, name)+        )++-- Field Alias : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Alias+-- Alias+--  Name:+parseAlias :: Parser (Maybe FieldName)+parseAlias = try (optional alias) <|> pure Nothing+  where+    alias = label "alias" $ parseName <* char ':' <* spaceAndComments++parseType :: Parser TypeRef+parseType = do+  (wrappers, typeConName) <- parseWrappedType+  nonNull <- parseNonNull+  pure+    TypeRef+      { typeConName,+        typeArgs = Nothing,+        typeWrappers = toHSWrappers $ nonNull ++ wrappers+      }
+ src/Data/Morpheus/Parsing/Internal/Value.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Parsing.Internal.Value+  ( enumValue,+    parseDefaultValue,+    Parse (..),+  )+where++import Data.Functor (($>))+--+-- MORPHEUS+import Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+  )+import Data.Morpheus.Parsing.Internal.Terms+  ( litEquals,+    parseAssignment,+    parseName,+    parseNegativeSign,+    parseTypeName,+    setOf,+    spaceAndComments,+    variable,+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    ObjectEntry (..),+    OrderedMap,+    RAW,+    ResolvedValue,+    ScalarValue (..),+    VALID,+    Value (..),+    decodeScientific,+  )+import Data.Text (pack)+import Text.Megaparsec+  ( (<|>),+    anySingleBut,+    between,+    choice,+    label,+    many,+    optional,+    sepBy,+  )+import Text.Megaparsec.Char+  ( char,+    string,+  )+import Text.Megaparsec.Char.Lexer (scientific)++valueNull :: Parser (Value a)+valueNull = string "null" $> Null++booleanValue :: Parser (Value a)+booleanValue = boolTrue <|> boolFalse+  where+    boolTrue = string "true" $> Scalar (Boolean True)+    boolFalse = string "false" $> Scalar (Boolean False)++valueNumber :: Parser (Value a)+valueNumber = do+  isNegative <- parseNegativeSign+  Scalar . decodeScientific . signedNumber isNegative <$> scientific+  where+    signedNumber isNegative number+      | isNegative = - number+      | otherwise = number++enumValue :: Parser (Value a)+enumValue = do+  enum <- Enum <$> parseTypeName+  spaceAndComments+  return enum++escaped :: Parser Char+escaped = label "escaped" $ do+  x <- anySingleBut '\"'+  if x == '\\' then choice (zipWith escapeChar codes replacements) else pure x+  where+    replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']+    codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']+    escapeChar code replacement = char code >> return replacement++stringValue :: Parser (Value a)+stringValue =+  label "stringValue" $+    Scalar . String . pack+      <$> between+        (char '"')+        (char '"')+        (many escaped)++listValue :: Parser a -> Parser [a]+listValue parser =+  label "ListValue" $+    between+      (char '[' *> spaceAndComments)+      (char ']' *> spaceAndComments)+      (parser `sepBy` (many (char ',') *> spaceAndComments))++objectEntry :: Parser (Value a) -> Parser (ObjectEntry a)+objectEntry parser = label "ObjectEntry" $ do+  (entryName, entryValue) <- parseAssignment parseName parser+  pure ObjectEntry {entryName, entryValue}++objectValue :: Parser (Value a) -> Parser (OrderedMap FieldName (ObjectEntry a))+objectValue = label "ObjectValue" . setOf . objectEntry++parsePrimitives :: Parser (Value a)+parsePrimitives =+  valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue++parseDefaultValue :: Parser (Maybe ResolvedValue)+parseDefaultValue = optional $ do+  litEquals+  parseV+  where+    parseV :: Parser ResolvedValue+    parseV = structValue parseV++class Parse a where+  parse :: Parser a++instance Parse (Value RAW) where+  parse = (VariableValue <$> variable) <|> structValue parse++instance Parse (Value VALID) where+  parse = structValue parse++structValue :: Parser (Value a) -> Parser (Value a)+structValue parser =+  label "Value" $+    ( parsePrimitives+        <|> (Object <$> objectValue parser)+        <|> (List <$> listValue parser)+    )+      <* spaceAndComments
+ src/Data/Morpheus/Parsing/JSONSchema/Parse.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Parsing.JSONSchema.Parse+  ( decodeIntrospection,+  )+where++import Data.Aeson+import Data.ByteString.Lazy (ByteString)+import Data.Morpheus.Error.Internal (internalError)+import Data.Morpheus.Internal.Utils+  ( fromElems,+  )+import Data.Morpheus.Parsing.JSONSchema.Types+  ( EnumValue (..),+    Field (..),+    InputValue (..),+    Introspection (..),+    Schema (..),+    Type (..),+  )+import Data.Morpheus.Schema.TypeKind (TypeKind (..))+import Data.Morpheus.Types.IO (JSONResponse (..))+import qualified Data.Morpheus.Types.Internal.AST as AST+  ( Schema,+  )+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    ArgumentsDefinition (..),+    DataTypeWrapper (..),+    FieldDefinition,+    IN,+    OUT,+    TypeContent (..),+    TypeDefinition (..),+    TypeName,+    TypeWrapper,+    createArgument,+    createEnumType,+    createField,+    createScalarType,+    createType,+    createUnionType,+    msg,+    toAny,+    toHSWrappers,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+  )+import Data.Semigroup ((<>))++decodeIntrospection :: ByteString -> Eventless AST.Schema+decodeIntrospection jsonDoc = case jsonSchema of+  Left errors -> internalError $ msg errors+  Right JSONResponse {responseData = Just Introspection {__schema = Schema {types}}} ->+    traverse parse types >>= fromElems . concat+  Right res -> internalError (msg $ show res)+  where+    jsonSchema :: Either String (JSONResponse Introspection)+    jsonSchema = eitherDecode jsonDoc++class ParseJSONSchema a b where+  parse :: a -> Eventless b++instance ParseJSONSchema Type [TypeDefinition ANY] where+  parse Type {name = Just typeName, kind = SCALAR} =+    pure [createScalarType typeName]+  parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} =+    pure [createEnumType typeName (map enumName enums)]+  parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} =+    case traverse name unions of+      Nothing -> internalError "ERROR: GQL ERROR"+      Just uni -> pure [toAny $ createUnionType typeName uni]+  parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} =+    do+      (fields :: [FieldDefinition IN]) <- traverse parse iFields+      fs <- fromElems fields+      pure [createType typeName $ DataInputObject fs]+  parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} =+    do+      (fields :: [FieldDefinition OUT]) <- traverse parse oFields+      fs <- fromElems fields+      pure [createType typeName $ DataObject [] fs]+  parse _ = pure []++instance ParseJSONSchema Field (FieldDefinition OUT) where+  parse Field {fieldName, fieldArgs, fieldType} = do+    fType <- fieldTypeFromJSON fieldType+    args <- traverse genArg fieldArgs >>= fromElems+    pure $ createField (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++fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], TypeName)+fieldTypeFromJSON = fmap toHs . fieldTypeRec []+  where+    toHs (w, t) = (toHSWrappers w, t)+    fieldTypeRec ::+      [DataTypeWrapper] -> Type -> Eventless ([DataTypeWrapper], TypeName)+    fieldTypeRec acc Type {kind = LIST, ofType = Just ofType} =+      fieldTypeRec (ListType : acc) ofType+    fieldTypeRec acc Type {kind = NON_NULL, ofType = Just ofType} =+      fieldTypeRec (NonNullType : acc) ofType+    fieldTypeRec acc Type {name = Just name} = pure (acc, name)+    fieldTypeRec _ x = internalError $ "Unsuported Field" <> msg (show x)
+ src/Data/Morpheus/Parsing/JSONSchema/Types.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Parsing.JSONSchema.Types+  ( Introspection (..),+    Schema (..),+    Type (..),+    Field (..),+    InputValue (..),+    EnumValue (..),+  )+where++import Data.Aeson+--+-- MORPHEUS+import Data.Morpheus.Schema.TypeKind (TypeKind)+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    TypeName,+  )+import GHC.Generics (Generic)++-- TYPES FOR DECODING JSON INTROSPECTION+--+newtype Introspection = Introspection+  { __schema :: Schema+  }+  deriving (Generic, Show, FromJSON)++newtype Schema = Schema+  { types :: [Type]+  }+  deriving (Generic, Show, FromJSON)++-- TYPE+data Type = Type+  { kind :: TypeKind,+    name :: Maybe TypeName,+    fields :: Maybe [Field],+    interfaces :: Maybe [Type],+    possibleTypes :: Maybe [Type],+    enumValues :: Maybe [EnumValue],+    inputFields :: Maybe [InputValue],+    ofType :: Maybe Type+  }+  deriving (Generic, Show, FromJSON)++-- FIELD+data Field = Field+  { fieldName :: FieldName,+    fieldArgs :: [InputValue],+    fieldType :: Type+  }+  deriving (Show, Generic)++instance FromJSON Field where+  parseJSON = withObject "Field" objectParser+    where+      objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type"++-- INPUT+data InputValue = InputValue+  { inputName :: FieldName,+    inputType :: Type+  }+  deriving (Show, Generic)++instance FromJSON InputValue where+  parseJSON = withObject "InputValue" objectParser+    where+      objectParser o = InputValue <$> o .: "name" <*> o .: "type"++-- ENUM+newtype EnumValue = EnumValue+  { enumName :: TypeName+  }+  deriving (Generic, Show)++instance FromJSON EnumValue where+  parseJSON = withObject "EnumValue" objectParser+    where+      objectParser o = EnumValue <$> o .: "name"
+ src/Data/Morpheus/Parsing/Request/Operation.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Data.Morpheus.Parsing.Request.Operation+  ( parseOperation,+  )+where++import Data.Functor (($>))+--+-- MORPHEUS++import Data.Morpheus.Internal.Utils+  ( empty,+  )+import Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+    getLocation,+  )+import Data.Morpheus.Parsing.Internal.Pattern+  ( optionalDirectives,+  )+import Data.Morpheus.Parsing.Internal.Terms+  ( operator,+    parseName,+    parseType,+    spaceAndComments1,+    uniqTupleOpt,+    variable,+  )+import Data.Morpheus.Parsing.Internal.Value+  ( parseDefaultValue,+  )+import Data.Morpheus.Parsing.Request.Selection+  ( parseSelectionSet,+  )+import Data.Morpheus.Types.Internal.AST+  ( Operation (..),+    OperationType (..),+    RAW,+    Ref (..),+    Variable (..),+    VariableContent (..),+  )+import Text.Megaparsec+  ( (<?>),+    (<|>),+    label,+    optional,+  )+import Text.Megaparsec.Char (string)++-- Variables :  https://graphql.github.io/graphql-spec/June2018/#VariableDefinition+--+--  VariableDefinition+--    Variable : Type DefaultValue(opt)+--+variableDefinition :: Parser (Variable RAW)+variableDefinition = label "VariableDefinition" $ do+  (Ref variableName variablePosition) <- variable+  operator ':'+  variableType <- parseType+  variableValue <- DefaultValue <$> parseDefaultValue+  pure Variable {..}++-- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations+--+-- OperationDefinition+--   OperationType Name(opt) VariableDefinitions(opt) Directives(opt) SelectionSet+--+--   OperationType: one of+--     query, mutation,    subscription+parseOperationDefinition :: Parser (Operation RAW)+parseOperationDefinition = label "OperationDefinition" $ do+  operationPosition <- getLocation+  operationType <- parseOperationType+  operationName <- optional parseName+  operationArguments <- uniqTupleOpt variableDefinition+  operationDirectives <- optionalDirectives+  operationSelection <- parseSelectionSet+  pure Operation {..}++parseOperationType :: Parser OperationType+parseOperationType = label "OperationType" $ do+  kind <-+    (string "query" $> Query)+      <|> (string "mutation" $> Mutation)+      <|> (string "subscription" $> Subscription)+  spaceAndComments1+  return kind++parseAnonymousQuery :: Parser (Operation RAW)+parseAnonymousQuery = label "AnonymousQuery" $ do+  operationPosition <- getLocation+  operationSelection <- parseSelectionSet+  pure+    ( Operation+        { operationName = Nothing,+          operationType = Query,+          operationArguments = empty,+          operationDirectives = empty,+          ..+        }+    )+    <?> "can't parse AnonymousQuery"++parseOperation :: Parser (Operation RAW)+parseOperation = parseAnonymousQuery <|> parseOperationDefinition
+ src/Data/Morpheus/Parsing/Request/Parser.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Parsing.Request.Parser (parseGQL) where++import qualified Data.Aeson as Aeson+  ( Value (..),+  )+import Data.HashMap.Lazy (toList)+--+-- MORPHEUS++import Data.Morpheus.Internal.Utils+  ( fromElems,+  )+import Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+    processParser,+  )+import Data.Morpheus.Parsing.Internal.Terms+  ( spaceAndComments,+  )+import Data.Morpheus.Parsing.Request.Operation+  ( parseOperation,+  )+import Data.Morpheus.Parsing.Request.Selection+  ( parseFragmentDefinition,+  )+import Data.Morpheus.Types.IO (GQLRequest (..))+import Data.Morpheus.Types.Internal.AST+  ( FieldName (..),+    GQLQuery (..),+    ResolvedValue,+    replaceValue,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+  )+import Text.Megaparsec+  ( eof,+    label,+    manyTill,+  )++request :: Parser GQLQuery+request = label "GQLQuery" $ do+  spaceAndComments+  operation <- parseOperation+  fragments <- manyTill parseFragmentDefinition eof >>= fromElems+  pure GQLQuery {operation, fragments, inputVariables = []}++parseGQL :: GQLRequest -> Eventless GQLQuery+parseGQL GQLRequest {query, variables} = setVariables <$> processParser request query+  where+    setVariables root = root {inputVariables = toVariableMap variables}+    toVariableMap :: Maybe Aeson.Value -> [(FieldName, ResolvedValue)]+    toVariableMap (Just (Aeson.Object x)) = map toMorpheusValue (toList x)+      where+        toMorpheusValue (key, value) = (FieldName key, replaceValue value)+    toVariableMap _ = []
+ src/Data/Morpheus/Parsing/Request/Selection.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Morpheus.Parsing.Request.Selection+  ( parseSelectionSet,+    parseFragmentDefinition,+  )+where++--+-- MORPHEUS++import Data.Morpheus.Parsing.Internal.Arguments+  ( maybeArguments,+  )+import Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+    getLocation,+  )+import Data.Morpheus.Parsing.Internal.Pattern+  ( optionalDirectives,+  )+import Data.Morpheus.Parsing.Internal.Terms+  ( keyword,+    parseAlias,+    parseName,+    parseTypeCondition,+    setOf,+    spreadLiteral,+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    Fragment (..),+    Position,+    RAW,+    Ref (..),+    Selection (..),+    SelectionContent (..),+    SelectionSet,+  )+import Text.Megaparsec+  ( (<|>),+    label,+    try,+  )++-- Selection Sets : https://graphql.github.io/graphql-spec/June2018/#sec-Selection-Sets+--+-- SelectionSet:+--  { Selection(list) }+--+-- Selection:+--   Field+--   FragmentSpread+--   InlineFragment+--+parseSelectionSet :: Parser (SelectionSet RAW)+parseSelectionSet = label "SelectionSet" $ setOf parseSelection+  where+    parseSelection =+      label "Selection" $+        try inlineFragment+          <|> try spread+          <|> parseSelectionField++-- Fields: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fields+--+-- Field+-- Alias(opt) Name Arguments(opt) Directives(opt) SelectionSet(opt)+--+parseSelectionField :: Parser (Selection RAW)+parseSelectionField =+  label "SelectionField" $+    do+      selectionPosition <- getLocation+      selectionAlias <- parseAlias+      selectionName <- parseName+      selectionArguments <- maybeArguments+      selectionDirectives <- optionalDirectives+      selectionContent <- parseSelectionContent+      pure Selection {..}++parseSelectionContent :: Parser (SelectionContent RAW)+parseSelectionContent =+  label "SelectionContent" $+    SelectionSet <$> parseSelectionSet+      <|> pure SelectionField++--+-- Fragments: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fragments+--+--  FragmentName : Name+--++--  FragmentSpread+--    ...FragmentName Directives(opt)+--+spread :: Parser (Selection RAW)+spread = label "FragmentSpread" $ do+  refPosition <- spreadLiteral+  refName <- parseName+  directives <- optionalDirectives+  pure $ Spread directives Ref {..}++-- FragmentDefinition : https://graphql.github.io/graphql-spec/June2018/#FragmentDefinition+--+--  FragmentDefinition:+--   fragment FragmentName TypeCondition Directives(opt) SelectionSet+--+parseFragmentDefinition :: Parser Fragment+parseFragmentDefinition = label "FragmentDefinition" $ do+  keyword "fragment"+  fragmentPosition <- getLocation+  fragmentName <- parseName+  fragmentBody fragmentName fragmentPosition++-- Inline Fragments : https://graphql.github.io/graphql-spec/June2018/#sec-Inline-Fragments+--+--  InlineFragment:+--  ... TypeCondition(opt) Directives(opt) SelectionSet+--+inlineFragment :: Parser (Selection RAW)+inlineFragment = label "InlineFragment" $ do+  fragmentPosition <- spreadLiteral+  InlineFragment <$> fragmentBody "INLINE_FRAGMENT" fragmentPosition++fragmentBody :: FieldName -> Position -> Parser Fragment+fragmentBody fragmentName fragmentPosition = label "FragmentBody" $ do+  fragmentType <- parseTypeCondition+  fragmentDirectives <- optionalDirectives+  fragmentSelection <- parseSelectionSet+  pure $ Fragment {..}
+ src/Data/Morpheus/QuasiQuoter.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.QuasiQuoter+  ( gql,+    gqlExpression,+    dsl,+    dslExpression,+  )+where++import Data.Morpheus.Error+  ( gqlWarnings,+    renderGQLErrors,+  )+import Data.Morpheus.Parser+  ( parseRequest,+    parseTypeDefinitions,+  )+import Data.Morpheus.Types.IO (GQLRequest (..))+import Data.Morpheus.Types.Internal.Resolving+  ( Result (..),+  )+import Data.Text+  ( Text,+    pack,+    unpack,+  )+import Language.Haskell.TH+import Language.Haskell.TH.Quote++gql :: QuasiQuoter+gql =+  QuasiQuoter+    { quoteExp = gqlExpression . pack,+      quotePat = notHandled "Patterns",+      quoteType = notHandled "Types",+      quoteDec = notHandled "Declarations"+    }+  where+    notHandled things =+      error $ things ++ " are not supported by the GraphQL QuasiQuoter"++gqlExpression :: Text -> Q Exp+gqlExpression queryText = case parseRequest request of+  Failure errors -> fail (renderGQLErrors errors)+  Success {result, warnings} ->+    gqlWarnings warnings >> [|(result, query)|]+  where+    query = unpack queryText+    request =+      GQLRequest+        { query = queryText,+          operationName = Nothing,+          variables = Nothing+        }++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 parseTypeDefinitions doc of+  Failure errors -> fail (renderGQLErrors errors)+  Success {result, warnings} ->+    gqlWarnings warnings >> [|result|]
+ src/Data/Morpheus/Rendering/RenderGQL.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+    renderObject,+    renderIndent,+  )+where++-- MORPHEUS+import Data.Semigroup ((<>))+import Data.Text+  ( Text,+    intercalate,+  )++type Rendering = Text++class RenderGQL a where+  render :: a -> Rendering++renderIndent :: Rendering+renderIndent = "  "++renderObject :: (a -> Rendering) -> [a] -> Rendering+renderObject f list =+  " { \n  " <> intercalate ("\n" <> renderIndent) (map f list) <> "\n}"
+ src/Data/Morpheus/Rendering/RenderIntrospection.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Rendering.RenderIntrospection+  ( render,+    createObjectType,+  )+where++import Data.Maybe (isJust)+-- Morpheus++import Data.Morpheus.Internal.Utils+  ( elems,+    failure,+    selectBy,+  )+import Data.Morpheus.Schema.TypeKind (TypeKind (..))+import Data.Morpheus.Types.Internal.AST+  ( ArgumentsDefinition (..),+    DataEnumValue (..),+    DataInputUnion,+    DataInputUnion,+    DataTypeKind (..),+    DataTypeWrapper (..),+    DataUnion,+    Description,+    DirectiveDefinition (..),+    DirectiveLocation,+    FieldDefinition (..),+    FieldName (..),+    FieldsDefinition,+    IN,+    Message,+    Meta (..),+    OUT,+    QUERY,+    Schema,+    TypeContent (..),+    TypeDefinition (..),+    TypeName (..),+    TypeRef (..),+    createInputUnionFields,+    fieldVisibility,+    kindOf,+    lookupDeprecated,+    lookupDeprecatedReason,+    msg,+    toGQLWrapper,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( ResModel,+    Resolver,+    mkBoolean,+    mkList,+    mkNull,+    mkObject,+    mkString,+  )+import Data.Semigroup ((<>))+import Data.Text (pack)++constRes :: Applicative m => a -> b -> m a+constRes = const . pure++type Result e m a = Schema -> Resolver QUERY e m a++class RenderSchema a where+  render :: (Monad m) => a -> Schema -> Resolver QUERY e m (ResModel QUERY e m)++instance RenderSchema 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)+          ]++instance RenderSchema a => RenderSchema [a] where+  render ls schema = mkList <$> traverse (`render` schema) ls++instance RenderSchema DirectiveLocation where+  render locations _ = pure $ mkString (pack $ show locations)++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++renderFields :: Monad m => Schema -> FieldsDefinition cat -> Resolver QUERY e m [ResModel QUERY e m]+renderFields schema = traverse (`render` schema) . 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)+      ]++interfacePossibleTypes ::+  (Monad m) =>+  Schema ->+  TypeName ->+  Resolver QUERY e m [ResModel QUERY e m]+interfacePossibleTypes schema interfaceName = sequence $ concatMap implements (elems schema)+  where+    implements typeDef@TypeDefinition {typeContent = DataObject {objectImplements}, ..}+      | interfaceName `elem` objectImplements = [render typeDef schema]+    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 ->+  [(FieldName, Resolver QUERY e m (ResModel QUERY e m))]+renderDeprecated meta =+  [ ("isDeprecated", pure $ mkBoolean (isJust $ meta >>= lookupDeprecated)),+    ("deprecationReason", opt (pure . mkString) (meta >>= lookupDeprecated >>= 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++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 []++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++createLeafType ::+  Monad m =>+  TypeKind ->+  TypeName ->+  Maybe Meta ->+  Maybe [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) =+  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)++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)+    ]++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+  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 [])+    ]++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)++renderKind :: Monad m => TypeKind -> (FieldName, Resolver QUERY e m (ResModel QUERY e m))+renderKind = ("kind",) . pure . mkString . pack . show++withTypeWrapper :: Monad m => FieldDefinition cat -> ResModel QUERY e m -> ResModel QUERY e m+withTypeWrapper FieldDefinition {fieldType = TypeRef {typeWrappers}} typ =+  foldr wrapAs typ (toGQLWrapper typeWrappers)++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++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)+    ]
+ src/Data/Morpheus/Schema/Directives.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Schema.Directives (defaultDirectives) where++import Data.Morpheus.Internal.Utils+  ( singleton,+  )+import Data.Morpheus.Types.Internal.AST+  ( ArgumentsDefinition (..),+    DirectiveDefinition (..),+    DirectiveLocation (..),+    TypeWrapper (..),+    createField,+  )++defaultDirectives :: [DirectiveDefinition]+defaultDirectives =+  [ DirectiveDefinition+      { directiveDefinitionName = "skip",+        directiveDefinitionDescription = Just "Directs the executor to skip this field or fragment when the `if` argument is true.",+        directiveDefinitionLocations = [FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT],+        directiveDefinitionArgs = argumentsIf+      },+    DirectiveDefinition+      { directiveDefinitionName = "include",+        directiveDefinitionDescription = Just "Directs the executor to include this field or fragment only when the `if` argument is true.",+        directiveDefinitionLocations = [FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT],+        directiveDefinitionArgs = argumentsIf+      },+    DirectiveDefinition+      { directiveDefinitionName = "deprecated",+        directiveDefinitionDescription = Just "Marks an element of a GraphQL schema as no longer supported.",+        directiveDefinitionLocations = [FIELD_DEFINITION, ENUM_VALUE],+        directiveDefinitionArgs =+          singleton $+            createField+              NoArguments+              "reason"+              ([TypeMaybe], "String")+      }+  ]++argumentsIf :: ArgumentsDefinition+argumentsIf = singleton $ createField NoArguments "if" ([], "Boolean")
+ src/Data/Morpheus/Schema/Schema.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Schema.Schema+  ( withSystemTypes,+  )+where++-- MORPHEUS++import Data.Morpheus.Internal.Utils+  ( (<:>),+    singleton,+  )+import Data.Morpheus.QuasiQuoter (dsl)+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    ArgumentsDefinition (..),+    DataFingerprint (..),+    FieldsDefinition,+    Message,+    OUT,+    Schema (..),+    TypeContent (..),+    TypeDefinition (..),+    TypeUpdater,+    TypeWrapper (..),+    createArgument,+    createField,+    insertType,+    internalFingerprint,+    unsafeFromFields,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( failure,+    resolveUpdates,+  )++withSystemTypes :: TypeUpdater+withSystemTypes s@Schema {query = q@TypeDefinition {typeContent = DataObject inter fields}} =+  ( do+      fs <- fields <:> hiddenFields+      pure $ s {query = q {typeContent = DataObject inter fs}}+  )+    >>= (`resolveUpdates` map (insertType . internalType) schemaTypes)+withSystemTypes _ = failure ("Query must be an Object Type" :: Message)++hiddenFields :: FieldsDefinition OUT+hiddenFields =+  unsafeFromFields+    [ createField+        (singleton (createArgument "name" ([], "String")))+        "__type"+        ([TypeMaybe], "__Type"),+      createField+        NoArguments+        "__schema"+        ([], "__Schema")+    ]++internalType :: TypeDefinition a -> TypeDefinition a+internalType+  tyDef@TypeDefinition+    { typeFingerprint = DataFingerprint name xs+    } =+    tyDef {typeFingerprint = internalFingerprint name xs}++schemaTypes :: [TypeDefinition ANY]+schemaTypes =+  [dsl|++# default scalars+scalar Boolean+scalar Int+scalar Float+scalar String+scalar ID++type __Schema {+  types: [__Type!]!+  queryType: __Type!+  mutationType: __Type+  subscriptionType: __Type+  directives: [__Directive!]!+}++type __Type {+  kind: __TypeKind!+  name: String+  description: String++  # OBJECT and INTERFACE only+  fields(includeDeprecated: Boolean = false): [__Field!]++  # OBJECT only+  interfaces: [__Type!]++  # INTERFACE and UNION only+  possibleTypes: [__Type!]++  # ENUM only+  enumValues(includeDeprecated: Boolean = false): [__EnumValue!]++  # INPUT_OBJECT only+  inputFields: [__InputValue!]++  # NON_NULL and LIST only+  ofType: __Type+}++type __Field {+  name: String!+  description: String+  args: [__InputValue!]!+  type: __Type!+  isDeprecated: Boolean!+  deprecationReason: String+}++type __InputValue {+  name: String!+  description: String+  type: __Type!+  defaultValue: String+}++type __EnumValue {+  name: String!+  description: String+  isDeprecated: Boolean!+  deprecationReason: String+}++type __Directive {+  name: String!+  description: String+  locations: [__DirectiveLocation!]!+  args: [__InputValue!]!+}++enum __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+}++enum __TypeKind {+  SCALAR+  OBJECT+  INTERFACE+  UNION+  ENUM+  INPUT_OBJECT+  LIST+  NON_NULL+}++|]
+ src/Data/Morpheus/Schema/SchemaAPI.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Schema.SchemaAPI+  ( withSystemFields,+  )+where++-- MORPHEUS++import Data.Morpheus.Internal.Utils+  ( (<:>),+    elems,+    empty,+    selectOr,+  )+import Data.Morpheus.Rendering.RenderIntrospection+  ( createObjectType,+    render,+  )+import Data.Morpheus.Schema.Directives+  ( defaultDirectives,+  )+import Data.Morpheus.Schema.Schema+  (+  )+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    OUT,+    QUERY,+    ScalarValue (..),+    Schema (..),+    TypeDefinition (..),+    TypeName (..),+    Value (..),+  )+import Data.Morpheus.Types.Internal.Resolving+  ( ResModel,+    Resolver,+    ResultT,+    RootResModel (..),+    mkList,+    mkNull,+    mkObject,+    withArguments,+  )++resolveTypes ::+  Monad m => Schema -> Resolver QUERY e m (ResModel QUERY e m)+resolveTypes schema = mkList <$> traverse (`render` schema) (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++findType ::+  Monad m =>+  TypeName ->+  Schema ->+  Resolver QUERY e m (ResModel QUERY e m)+findType name schema = selectOr (pure mkNull) (`render` schema) name schema++renderDirectives ::+  Monad m =>+  Schema ->+  Resolver QUERY e m (ResModel QUERY e m)+renderDirectives schema =+  mkList+    <$> traverse+      (`render` schema)+      defaultDirectives++schemaResolver ::+  Monad m =>+  Schema ->+  Resolver QUERY e m (ResModel QUERY e m)+schemaResolver schema@Schema {query, mutation, subscription} =+  pure $+    mkObject+      "__Schema"+      [ ("types", resolveTypes schema),+        ("queryType", pure $ buildSchemaLinkType (Just query) schema),+        ("mutationType", pure $ buildSchemaLinkType mutation schema),+        ("subscriptionType", pure $ buildSchemaLinkType subscription schema),+        ("directives", renderDirectives schema)+      ]++schemaAPI :: Monad m => Schema -> ResModel QUERY e m+schemaAPI schema =+  mkObject+    "Root"+    [ ("__type", withArguments typeResolver),+      ("__schema", schemaResolver schema)+    ]+  where+    typeResolver = selectOr (pure mkNull) handleArg "name"+      where+        handleArg+          Argument+            { argumentValue = (Scalar (String typename))+            } = findType (TypeName typename) schema+        handleArg _ = pure mkNull++withSystemFields :: Monad m => Schema -> RootResModel e m -> ResultT e' m (RootResModel e m)+withSystemFields schema RootResModel {query, ..} =+  pure $+    RootResModel+      { query = query >>= (<:> schemaAPI schema),+        ..+      }
+ src/Data/Morpheus/Schema/TypeKind.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Schema.TypeKind+  ( TypeKind (..),+  )+where++import Data.Aeson (FromJSON (..))+import GHC.Generics++data TypeKind+  = SCALAR+  | OBJECT+  | INTERFACE+  | UNION+  | ENUM+  | INPUT_OBJECT+  | LIST+  | NON_NULL+  deriving (Eq, Generic, FromJSON, Show)
+ src/Data/Morpheus/Types/IO.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Types.IO+  ( GQLRequest (..),+    GQLResponse (..),+    JSONResponse (..),+    renderResponse,+    MapAPI (..),+  )+where++import Data.Aeson+  ( (.:?),+    (.=),+    FromJSON (..),+    ToJSON (..),+    encode,+    object,+    pairs,+    withObject,+  )+import qualified Data.Aeson as Aeson+  ( Value (..),+  )+import Data.Aeson.Internal+  ( formatError,+    ifromJSON,+  )+import Data.Aeson.Parser+  ( eitherDecodeWith,+    jsonNoDup,+  )+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy.Char8 as LB+  ( ByteString,+    fromStrict,+    toStrict,+  )+import qualified Data.HashMap.Lazy as LH+  ( toList,+  )+-- MORPHEUS+import Data.Morpheus.Error.Utils (badRequestError)+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    GQLError (..),+    Token,+    ValidValue,+  )+import Data.Morpheus.Types.Internal.Resolving.Core+  ( Failure (..),+    Result (..),+  )+import Data.Text (Text)+import qualified Data.Text.Lazy as LT+  ( Text,+    fromStrict,+    toStrict,+  )+import Data.Text.Lazy.Encoding+  ( decodeUtf8,+    encodeUtf8,+  )+import GHC.Generics (Generic)++decodeNoDup :: Failure String m => LB.ByteString -> m GQLRequest+decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of+  Left (path, x) -> failure $ formatError path x+  Right value -> pure value++class MapAPI a where+  mapAPI :: Applicative m => (GQLRequest -> m GQLResponse) -> a -> m a++instance MapAPI LB.ByteString where+  mapAPI api request = case decodeNoDup request of+    Left aesonError -> pure $ badRequestError aesonError+    Right req -> encode <$> api req++instance MapAPI LT.Text where+  mapAPI api = fmap decodeUtf8 . mapAPI api . encodeUtf8++instance MapAPI ByteString where+  mapAPI api = fmap LB.toStrict . mapAPI api . LB.fromStrict++instance MapAPI Text where+  mapAPI api = fmap LT.toStrict . mapAPI api . LT.fromStrict++renderResponse :: Result e ValidValue -> GQLResponse+renderResponse (Failure errors) = Errors errors+renderResponse Success {result} = Data result++instance FromJSON a => FromJSON (JSONResponse a) where+  parseJSON = withObject "JSONResponse" objectParser+    where+      objectParser o = JSONResponse <$> o .:? "data" <*> o .:? "errors"++data JSONResponse a = JSONResponse+  { responseData :: Maybe a,+    responseErrors :: Maybe [GQLError]+  }+  deriving (Generic, Show, ToJSON)++-- | GraphQL HTTP Request Body+data GQLRequest = GQLRequest+  { query :: Token,+    operationName :: Maybe FieldName,+    variables :: Maybe Aeson.Value+  }+  deriving (Show, Generic, FromJSON, ToJSON)++-- | GraphQL Response+data GQLResponse+  = Data ValidValue+  | Errors [GQLError]+  deriving (Show, Generic)++instance FromJSON GQLResponse where+  parseJSON (Aeson.Object hm) = case LH.toList hm of+    [("data", value)] -> Data <$> parseJSON value+    [("errors", value)] -> Errors <$> parseJSON value+    _ -> fail "Invalid GraphQL Response"+  parseJSON _ = fail "Invalid GraphQL Response"++instance ToJSON GQLResponse where+  toJSON (Data gqlData) = object ["data" .= toJSON gqlData]+  toJSON (Errors errors) = object ["errors" .= toJSON errors]++  ----------------------------------------------------------+  toEncoding (Data _data) = pairs $ "data" .= _data+  toEncoding (Errors _errors) = pairs $ "errors" .= _errors
+ src/Data/Morpheus/Types/Internal/AST.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Morpheus.Types.Internal.AST+  ( -- BASE+    Ref (..),+    Position (..),+    Message,+    anonymousRef,+    FieldName (..),+    Description,+    Stage,+    RESOLVED,+    VALID,+    RAW,+    VALIDATION_MODE (..),+    -- VALUE+    Value (..),+    ScalarValue (..),+    Object,+    GQLValue (..),+    replaceValue,+    decodeScientific,+    convertToJSONName,+    convertToHaskellName,+    RawValue,+    ValidValue,+    RawObject,+    ValidObject,+    ResolvedObject,+    ResolvedValue,+    splitDuplicates,+    removeDuplicates,+    -- Selection+    Argument (..),+    Arguments,+    SelectionSet,+    SelectionContent (..),+    Selection (..),+    Fragments,+    Fragment (..),+    -- OPERATION+    Operation (..),+    Variable (..),+    VariableDefinitions,+    DefaultValue,+    getOperationName,+    getOperationDataType,+    -- DSL+    ScalarDefinition (..),+    DataEnum,+    FieldsDefinition,+    ArgumentDefinition,+    DataUnion,+    ArgumentsDefinition (..),+    FieldDefinition (..),+    InputFieldsDefinition,+    TypeContent (..),+    TypeDefinition (..),+    Schema (..),+    DataTypeWrapper (..),+    DataTypeKind (..),+    DataFingerprint (..),+    TypeWrapper (..),+    TypeRef (..),+    DataEnumValue (..),+    OperationType (..),+    QUERY,+    MUTATION,+    SUBSCRIPTION,+    Meta (..),+    Directive (..),+    TypeUpdater,+    TypeD (..),+    ConsD (..),+    GQLTypeD (..),+    TypeCategory,+    DataInputUnion,+    VariableContent (..),+    TypeLib,+    initTypeLib,+    defineType,+    isFieldNullable,+    kindOf,+    toNullableField,+    toListField,+    isObject,+    isInput,+    toHSWrappers,+    isNullable,+    toGQLWrapper,+    isWeaker,+    isSubscription,+    isOutputObject,+    sysTypes,+    isSystemTypeName,+    isEntNode,+    createField,+    createArgument,+    createEnumType,+    createScalarType,+    createType,+    createUnionType,+    createAlias,+    createInputUnionFields,+    fieldVisibility,+    createEnumValue,+    insertType,+    lookupDeprecated,+    lookupDeprecatedReason,+    hasArguments,+    lookupWith,+    typeFromScalar,+    -- Temaplate Haskell+    hsTypeName,+    -- LOCAL+    GQLQuery (..),+    Variables,+    isNullableWrapper,+    unsafeFromFields,+    OrderedMap,+    GQLError (..),+    GQLErrors,+    ObjectEntry (..),+    UnionTag (..),+    __inputname,+    updateSchema,+    internalFingerprint,+    ANY,+    IN,+    OUT,+    FromAny (..),+    ToAny (..),+    TRUE,+    FALSE,+    TypeName (..),+    Token,+    Msg (..),+    intercalateName,+    toFieldName,+    TypeNameRef (..),+    isEnum,+    Fields,+    argumentsToFields,+    fieldsToArguments,+    mkCons,+    mkConsEnum,+    Directives,+    DirectiveDefinitions,+    DirectiveDefinition (..),+    DirectiveLocation (..),+  )+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.OrderedMap+import Data.Morpheus.Types.Internal.AST.Selection+import Data.Morpheus.Types.Internal.AST.TH+import Data.Morpheus.Types.Internal.AST.Value+import Language.Haskell.TH.Syntax (Lift)++type Variables = HashMap FieldName ResolvedValue++data GQLQuery = GQLQuery+  { fragments :: Fragments,+    operation :: Operation RAW,+    inputVariables :: [(FieldName, ResolvedValue)]+  }+  deriving (Show, Lift)
+ src/Data/Morpheus/Types/Internal/AST/Base.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Types.Internal.AST.Base+  ( Ref (..),+    Position (..),+    Message (..),+    FieldName (..),+    Description,+    VALID,+    RAW,+    TypeWrapper (..),+    Stage (..),+    RESOLVED,+    TypeRef (..),+    VALIDATION_MODE (..),+    OperationType (..),+    QUERY,+    MUTATION,+    SUBSCRIPTION,+    DataTypeKind (..),+    DataFingerprint (..),+    DataTypeWrapper (..),+    Token,+    anonymousRef,+    toHSWrappers,+    toGQLWrapper,+    sysTypes,+    isNullable,+    isWeaker,+    isSubscription,+    isOutputObject,+    isSystemTypeName,+    isObject,+    isInput,+    isNullableWrapper,+    sysFields,+    typeFromScalar,+    hsTypeName,+    toOperationType,+    splitDuplicates,+    removeDuplicates,+    GQLError (..),+    GQLErrors,+    internalFingerprint,+    TRUE,+    FALSE,+    TypeName (..),+    Msg (..),+    intercalateName,+    toFieldName,+    TypeNameRef (..),+    convertToJSONName,+    convertToHaskellName,+  )+where++import Data.Aeson+  ( FromJSON,+    ToJSON,+    Value,+    encode,+  )+import Data.ByteString.Lazy.Char8 (ByteString, unpack)+import Data.Hashable (Hashable)+import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..))+import Data.Semigroup (Semigroup (..))+import Data.String (IsString)+import Data.Text (Text, intercalate, pack)+import qualified Data.Text as T+import GHC.Generics (Generic)+-- import Instances.TH.Lift ()+import Language.Haskell.TH (stringE)+import Language.Haskell.TH.Syntax (Lift (..))++type TRUE = 'True++type FALSE = 'False++-- Strings+type Token = Text++-- Error / Warning Messages+newtype Message = Message {readMessage :: Text}+  deriving+    (Generic)+  deriving newtype+    (Show, Eq, Ord, IsString, Semigroup, Hashable, FromJSON, ToJSON)++instance Lift Message where+  lift = stringE . T.unpack . readMessage++class Msg a where+  msg :: a -> Message+  msgSepBy :: Text -> [a] -> Message+  msgSepBy t = Message . intercalate t . map (readMessage . msg)++instance Msg String where+  msg = Message . pack++instance Msg ByteString where+  msg = msg . unpack++instance Msg Text where+  msg = Message++instance Msg Value where+  msg = msg . encode++-- FieldName : lower case names+newtype FieldName = FieldName {readName :: Text}+  deriving+    (Generic)+  deriving newtype+    (Show, Ord, Eq, IsString, Hashable, Semigroup, FromJSON, ToJSON)++instance Lift FieldName where+  lift = stringE . T.unpack . readName++instance Msg FieldName where+  msg FieldName {readName} = Message $ "\"" <> readName <> "\""++instance RenderGQL FieldName where+  render = readName++intercalateName :: FieldName -> [FieldName] -> FieldName+intercalateName (FieldName x) = FieldName . intercalate x . map readName++toFieldName :: TypeName -> FieldName+toFieldName = FieldName . readTypeName++-- TypeName+newtype TypeName = TypeName {readTypeName :: Text}+  deriving+    (Generic)+  deriving newtype+    (Show, Ord, Eq, IsString, Hashable, Semigroup, FromJSON, ToJSON)++instance Lift TypeName where+  lift = stringE . T.unpack . readTypeName++instance Msg TypeName where+  msg TypeName {readTypeName} = Message $ "\"" <> readTypeName <> "\""++instance RenderGQL TypeName where+  render = readTypeName++-- Description+type Description = Text++data Stage = RAW | RESOLVED | VALID++data Position = Position+  { line :: Int,+    column :: Int+  }+  deriving (Show, Generic, FromJSON, ToJSON, Lift)++-- Positions 2 Value withs same structire+-- but different Positions should be Equal+instance Eq Position where+  _ == _ = True++data GQLError = GQLError+  { message :: Message,+    locations :: [Position]+  }+  deriving (Show, Eq, Generic, FromJSON, ToJSON)++type GQLErrors = [GQLError]++type RAW = 'RAW++type RESOLVED = 'RESOLVED++type VALID = 'VALID++data VALIDATION_MODE+  = WITHOUT_VARIABLES+  | FULL_VALIDATION+  deriving (Eq, Show)++data DataFingerprint = DataFingerprint TypeName [String] deriving (Show, Eq, Ord, Lift)++internalFingerprint :: TypeName -> [String] -> DataFingerprint+internalFingerprint name = DataFingerprint ("SYSTEM.INTERNAL." <> name)++data OperationType+  = Query+  | Subscription+  | Mutation+  deriving (Show, Eq, Lift)++type QUERY = 'Query++type MUTATION = 'Mutation++type SUBSCRIPTION = 'Subscription++data TypeNameRef = TypeNameRef+  { typeNameRef :: TypeName,+    typeNamePosition :: Position+  }+  deriving (Show, Lift, Eq)++-- Refference with Position information+--+-- includes position for debugging, where Ref "a" 1 === Ref "a" 3+--+data Ref = Ref+  { refName :: FieldName,+    refPosition :: Position+  }+  deriving (Show, Lift, Eq)++instance Ord Ref where+  compare (Ref x _) (Ref y _) = compare x y++anonymousRef :: FieldName -> Ref+anonymousRef refName = Ref {refName, refPosition = Position 0 0}++-- TypeRef+-------------------------------------------------------------------+data TypeRef = TypeRef+  { typeConName :: TypeName,+    typeArgs :: Maybe TypeName,+    typeWrappers :: [TypeWrapper]+  }+  deriving (Show, Eq, Lift)++isNullable :: TypeRef -> Bool+isNullable TypeRef {typeWrappers = typeWrappers} = isNullableWrapper typeWrappers++instance RenderGQL TypeRef where+  render TypeRef {typeConName, typeWrappers} = renderWrapped typeConName typeWrappers++instance Msg TypeRef where+  msg = msg . FieldName . render++-- Kind+-----------------------------------------------------------------------------------+data DataTypeKind+  = KindScalar+  | KindObject (Maybe OperationType)+  | KindUnion+  | KindEnum+  | KindInputObject+  | KindList+  | KindNonNull+  | KindInputUnion+  | KindInterface+  deriving (Eq, Show, Lift)++isSubscription :: DataTypeKind -> Bool+isSubscription (KindObject (Just Subscription)) = True+isSubscription _ = False++isOutputObject :: DataTypeKind -> Bool+isOutputObject (KindObject _) = True+isOutputObject KindInterface = True+isOutputObject _ = False++isObject :: DataTypeKind -> Bool+isObject (KindObject _) = True+isObject KindInputObject = True+isObject KindInterface = True+isObject _ = False++isInput :: DataTypeKind -> Bool+isInput KindInputObject = True+isInput _ = False++-- TypeWrappers+-----------------------------------------------------------------------------------+data TypeWrapper+  = TypeList+  | TypeMaybe+  deriving (Show, Eq, Lift)++data DataTypeWrapper+  = ListType+  | NonNullType+  deriving (Show, Lift)++isNullableWrapper :: [TypeWrapper] -> Bool+isNullableWrapper (TypeMaybe : _) = True+isNullableWrapper _ = False++isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool+isWeaker (TypeMaybe : xs1) (TypeMaybe : xs2) = isWeaker xs1 xs2+isWeaker (TypeMaybe : _) _ = True+isWeaker (_ : xs1) (_ : xs2) = isWeaker xs1 xs2+isWeaker _ _ = False++toGQLWrapper :: [TypeWrapper] -> [DataTypeWrapper]+toGQLWrapper (TypeMaybe : (TypeMaybe : tw)) = toGQLWrapper (TypeMaybe : tw)+toGQLWrapper (TypeMaybe : (TypeList : tw)) = ListType : toGQLWrapper tw+toGQLWrapper (TypeList : tw) = [NonNullType, ListType] <> toGQLWrapper tw+toGQLWrapper [TypeMaybe] = []+toGQLWrapper [] = [NonNullType]++toHSWrappers :: [DataTypeWrapper] -> [TypeWrapper]+toHSWrappers (NonNullType : (NonNullType : xs)) =+  toHSWrappers (NonNullType : xs)+toHSWrappers (NonNullType : (ListType : xs)) = TypeList : toHSWrappers xs+toHSWrappers (ListType : xs) = [TypeMaybe, TypeList] <> toHSWrappers xs+toHSWrappers [] = [TypeMaybe]+toHSWrappers [NonNullType] = []++renderWrapped :: RenderGQL a => a -> [TypeWrapper] -> Token+renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers)+  where+    showGQLWrapper [] = render x+    showGQLWrapper (ListType : xs) = "[" <> showGQLWrapper xs <> "]"+    showGQLWrapper (NonNullType : xs) = showGQLWrapper xs <> "!"++isSystemTypeName :: TypeName -> Bool+isSystemTypeName = (`elem` sysTypes)++sysTypes :: [TypeName]+sysTypes =+  [ "__Schema",+    "__Type",+    "__Directive",+    "__TypeKind",+    "__Field",+    "__DirectiveLocation",+    "__InputValue",+    "__EnumValue",+    "String",+    "Float",+    "Int",+    "Boolean",+    "ID"+  ]++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"+hsTypeName "Boolean" = "Bool"+hsTypeName name = name++toOperationType :: TypeName -> Maybe OperationType+toOperationType "Subscription" = Just Subscription+toOperationType "Mutation" = Just Mutation+toOperationType "Query" = Just Query+toOperationType _ = Nothing++removeDuplicates :: Eq a => [a] -> [a]+removeDuplicates = fst . splitDuplicates++-- elems -> (unique elements, duplicate elems)+splitDuplicates :: Eq a => [a] -> ([a], [a])+splitDuplicates = collectElems ([], [])+  where+    collectElems :: Eq a => ([a], [a]) -> [a] -> ([a], [a])+    collectElems collected [] = collected+    collectElems (collected, errors) (x : xs)+      | x `elem` collected = collectElems (collected, errors <> [x]) xs+      | otherwise = collectElems (collected <> [x], errors) xs++-- handle reserved Names+isReserved :: FieldName -> Bool+isReserved "case" = True+isReserved "class" = True+isReserved "data" = True+isReserved "default" = True+isReserved "deriving" = True+isReserved "do" = True+isReserved "else" = True+isReserved "foreign" = True+isReserved "if" = True+isReserved "import" = True+isReserved "in" = True+isReserved "infix" = True+isReserved "infixl" = True+isReserved "infixr" = True+isReserved "instance" = True+isReserved "let" = True+isReserved "module" = True+isReserved "newtype" = True+isReserved "of" = True+isReserved "then" = True+isReserved "type" = True+isReserved "where" = True+isReserved "_" = True+isReserved _ = False+{-# INLINE isReserved #-}++convertToJSONName :: FieldName -> FieldName+convertToJSONName (FieldName hsName)+  | not (T.null hsName) && isReserved (FieldName name) && (T.last hsName == '\'') = FieldName name+  | otherwise = FieldName hsName+  where+    name = T.init hsName++convertToHaskellName :: FieldName -> FieldName+convertToHaskellName name+  | isReserved name = name <> "'"+  | otherwise = name
+ src/Data/Morpheus/Types/Internal/AST/Data.hs view
@@ -0,0 +1,765 @@+{-# 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
+ src/Data/Morpheus/Types/Internal/AST/MergeSet.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Morpheus.Types.Internal.AST.MergeSet+  ( MergeSet,+    toOrderedMap,+    concatTraverse,+    join,+  )+where++import Data.List ((\\), find)+import Data.Maybe (maybe)+-- MORPHEUS++import Data.Morpheus.Internal.Utils+  ( (<:>),+    Collection (..),+    Failure (..),+    KeyOf (..),+    Listable (..),+    Merge (..),+    Selectable (..),+    elems,+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( FieldName,+    GQLErrors,+    RAW,+    Ref,+    Stage,+    VALID,+  )+import Data.Morpheus.Types.Internal.AST.OrderedMap+  ( OrderedMap (..),+  )+import qualified Data.Morpheus.Types.Internal.AST.OrderedMap as OM+import Data.Semigroup ((<>))+import Language.Haskell.TH.Syntax (Lift (..))++-- set with mergeable components+newtype MergeSet (dups :: Stage) a = MergeSet+  { unpack :: [a]+  }+  deriving+    ( Show,+      Eq,+      Functor,+      Foldable,+      Lift,+      Traversable,+      Collection a+    )++concatTraverse ::+  ( Eq a,+    Eq b,+    Merge a,+    Merge b,+    KeyOf b,+    Monad m,+    Failure GQLErrors m+  ) =>+  (a -> m (MergeSet VALID b)) ->+  MergeSet RAW a ->+  m (MergeSet VALID b)+concatTraverse f smap =+  traverse f (elems smap)+    >>= join++join ::+  ( Eq a,+    KeyOf a,+    Merge a,+    Monad m,+    Failure GQLErrors m,+    Listable a (MergeSet opt a),+    Merge (MergeSet opt a)+  ) =>+  [MergeSet opt a] ->+  m (MergeSet opt a)+join = __join empty+  where+    __join acc [] = pure acc+    __join acc (x : xs) = acc <:> x >>= (`__join` xs)++toOrderedMap :: (KEY a ~ FieldName, KeyOf a) => MergeSet opt a -> OrderedMap FieldName a+toOrderedMap = OM.unsafeFromValues . unpack++instance (KeyOf a, k ~ KEY a) => Selectable (MergeSet opt a) a where+  selectOr fb f key (MergeSet ls) = maybe fb f (find ((key ==) . keyOf) ls)++-- must merge files on collision++instance+  ( KeyOf a,+    Listable a (MergeSet VALID a),+    Merge a,+    Eq a+  ) =>+  Merge (MergeSet VALID a)+  where+  merge = safeJoin++instance+  ( Listable a (MergeSet VALID a),+    KeyOf a,+    Merge a,+    Eq a+  ) =>+  Listable a (MergeSet VALID a)+  where+  fromElems = safeFromList+  elems = unpack++instance Merge (MergeSet RAW a) where+  merge _ (MergeSet x) (MergeSet y) = pure $ MergeSet $ x <> y++instance Listable a (MergeSet RAW a) where+  fromElems = pure . MergeSet+  elems = unpack++safeFromList :: (Monad m, KeyOf a, Eq a, Merge a, Failure GQLErrors m) => [a] -> m (MergeSet opt a)+safeFromList = insertList [] empty++safeJoin :: (Monad m, KeyOf a, Eq a, Listable a (MergeSet opt a), Merge a, Failure GQLErrors m) => [Ref] -> MergeSet opt a -> MergeSet opt a -> m (MergeSet opt a)+safeJoin path hm1 hm2 = insertList path hm1 (elems hm2)++insertList :: (Monad m, Eq a, KeyOf a, Merge a, Failure GQLErrors m) => [Ref] -> MergeSet opt a -> [a] -> m (MergeSet opt a)+insertList _ smap [] = pure smap+insertList path smap (x : xs) = insert path smap x >>= flip (insertList path) xs++insert :: (Monad m, Eq a, KeyOf a, Merge a, Failure GQLErrors m) => [Ref] -> MergeSet opt a -> a -> m (MergeSet opt a)+insert path mSet@(MergeSet ls) currentValue = MergeSet <$> __insert+  where+    __insert =+      selectOr+        (pure $ ls <> [currentValue])+        mergeWith+        (keyOf currentValue)+        mSet+    ------------------+    mergeWith oldValue+      | oldValue == currentValue = pure ls+      | otherwise = do+        mergedValue <- merge path oldValue currentValue+        pure $ (ls \\ [oldValue]) <> [mergedValue]
+ src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Types.Internal.AST.OrderedMap+  ( OrderedMap (..),+    unsafeFromValues,+  )+where++import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HM+import Data.Hashable (Hashable)+import Data.Maybe (fromMaybe, isJust)+-- MORPHEUS+import Data.Morpheus.Error.NameCollision (NameCollision (..))+import Data.Morpheus.Internal.Utils+  ( Collection (..),+    Failure (..),+    KeyOf (..),+    Listable (..),+    Merge (..),+    Selectable (..),+    toPair,+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( GQLErrors,+  )+import Data.Semigroup ((<>))+import Language.Haskell.TH.Syntax (Lift (..))++-- OrderedMap+data OrderedMap k a = OrderedMap+  { mapKeys :: [k],+    mapEntries :: HashMap k a+  }+  deriving (Show, Eq, Functor)++instance (Lift a, Lift k) => Lift (OrderedMap k a) where+  lift (OrderedMap names x) = [|OrderedMap names (HM.fromList ls)|]+    where+      ls = HM.toList x++instance Foldable (OrderedMap k) where+  foldMap f OrderedMap {mapEntries} = foldMap f mapEntries++instance Traversable (OrderedMap k) where+  traverse f (OrderedMap names values) = OrderedMap names <$> traverse f values++instance (KeyOf a, Hashable k, KEY a ~ k) => Collection a (OrderedMap k a) where+  empty = OrderedMap [] HM.empty+  singleton x = OrderedMap [keyOf x] $ HM.singleton (keyOf x) x++instance (Eq k, Hashable k, k ~ KEY a) => Selectable (OrderedMap k a) a where+  selectOr fb f key OrderedMap {mapEntries} = maybe fb f (HM.lookup key mapEntries)++instance (NameCollision a, Eq k, Hashable k, k ~ KEY a) => Merge (OrderedMap k a) where+  merge _ (OrderedMap k1 x) (OrderedMap k2 y) = OrderedMap (k1 <> k2) <$> safeJoin x y++instance (NameCollision a, Eq k, Hashable k, k ~ KEY a) => Listable a (OrderedMap k a) where+  fromElems = safeFromList+  elems OrderedMap {mapKeys, mapEntries} = map takeValue mapKeys+    where+      takeValue key = fromMaybe (error "TODO: invalid Ordered Map") (key `HM.lookup` mapEntries)++safeFromList ::+  ( Failure GQLErrors m,+    Applicative m,+    NameCollision a,+    Eq (KEY a),+    Hashable (KEY a),+    KeyOf a+  ) =>+  [a] ->+  m (OrderedMap (KEY a) a)+safeFromList values = OrderedMap (map keyOf values) <$> safeUnionWith HM.empty (map toPair values)++unsafeFromValues ::+  ( KeyOf a,+    Eq (KEY a),+    Hashable (KEY a)+  ) =>+  [a] ->+  OrderedMap (KEY a) a+unsafeFromValues x = OrderedMap (map keyOf x) $ HM.fromList $ fmap toPair x++safeJoin :: (Failure GQLErrors m, Eq k, Hashable k, KEY a ~ k, Applicative m, NameCollision a) => HashMap k a -> HashMap k a -> m (HashMap k a)+safeJoin hm newls = safeUnionWith hm (HM.toList newls)++safeUnionWith ::+  ( Failure GQLErrors m,+    Applicative m,+    Eq k,+    Hashable k,+    NameCollision a,+    KEY a ~ k+  ) =>+  HashMap k a ->+  [(k, a)] ->+  m (HashMap k a)+safeUnionWith hm names = case insertNoDups (hm, []) names of+  (res, dupps)+    | null dupps -> pure res+    | otherwise -> failure $ map (uncurry nameCollision) dupps++type NoDupHashMap k a = (HashMap k a, [(k, a)])++insertNoDups :: (Eq k, Hashable k) => NoDupHashMap k a -> [(k, a)] -> NoDupHashMap k a+insertNoDups collected [] = collected+insertNoDups (coll, errors) (pair@(name, value) : xs)+  | isJust (name `HM.lookup` coll) = insertNoDups (coll, errors <> [pair]) xs+  | otherwise = insertNoDups (HM.insert name value coll, errors) xs
+ src/Data/Morpheus/Types/Internal/AST/Selection.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Morpheus.Types.Internal.AST.Selection+  ( Selection (..),+    SelectionContent (..),+    SelectionSet,+    UnionTag (..),+    UnionSelection,+    Fragment (..),+    Fragments,+    Operation (..),+    Variable (..),+    VariableDefinitions,+    DefaultValue,+    getOperationName,+    getOperationDataType,+  )+where++import Data.Maybe (fromMaybe, isJust)+-- MORPHEUS++import Data.Morpheus.Error.NameCollision+  ( NameCollision (..),+  )+import Data.Morpheus.Error.Operation+  ( mutationIsNotDefined,+    subscriptionIsNotDefined,+  )+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    KeyOf (..),+    Merge (..),+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( FieldName,+    GQLError (..),+    GQLErrors,+    Message,+    OperationType (..),+    Position,+    RAW,+    Ref (..),+    Stage,+    TypeName (..),+    VALID,+    intercalateName,+    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.Value+  ( ResolvedValue,+    Variable (..),+    VariableDefinitions,+  )+import Data.Semigroup ((<>))+import Language.Haskell.TH.Syntax (Lift (..))++data Fragment = Fragment+  { fragmentName :: FieldName,+    fragmentType :: TypeName,+    fragmentPosition :: Position,+    fragmentSelection :: SelectionSet RAW,+    fragmentDirectives :: Directives RAW+  }+  deriving (Show, Eq, Lift)++-- ERRORs+instance NameCollision Fragment where+  nameCollision _ Fragment {fragmentName, fragmentPosition} =+    GQLError+      { message = "There can be only one fragment named " <> msg fragmentName <> ".",+        locations = [fragmentPosition]+      }++instance KeyOf Fragment where+  keyOf = fragmentName++type Fragments = OrderedMap FieldName Fragment++data SelectionContent (s :: Stage) where+  SelectionField :: SelectionContent s+  SelectionSet :: SelectionSet s -> SelectionContent s+  UnionSelection :: UnionSelection VALID -> SelectionContent VALID++instance+  Merge (SelectionSet s) =>+  Merge (SelectionContent s)+  where+  merge path (SelectionSet s1) (SelectionSet s2) = SelectionSet <$> merge path s1 s2+  merge path (UnionSelection u1) (UnionSelection u2) = UnionSelection <$> merge path u1 u2+  merge path oldC currC+    | oldC == currC = pure oldC+    | otherwise =+      failure+        [ GQLError+            { message = msg (intercalateName "." $ map refName path),+              locations = map refPosition path+            }+        ]++deriving instance Show (SelectionContent a)++deriving instance Eq (SelectionContent a)++deriving instance Lift (SelectionContent a)++data UnionTag = UnionTag+  { unionTagName :: TypeName,+    unionTagSelection :: SelectionSet VALID+  }+  deriving (Show, Eq, Lift)++mergeConflict :: [Ref] -> GQLError -> GQLErrors+mergeConflict [] err = [err]+mergeConflict refs@(rootField : xs) err =+  [ GQLError+      { message = renderSubfields <> message err,+        locations = map refPosition refs <> locations err+      }+  ]+  where+    fieldConflicts ref = msg (refName ref) <> " conflict because "+    renderSubfield ref txt = txt <> "subfields " <> fieldConflicts ref+    renderStart = "Fields " <> fieldConflicts rootField+    renderSubfields =+      foldr+        renderSubfield+        renderStart+        xs++instance Merge UnionTag where+  merge path (UnionTag oldTag oldSel) (UnionTag _ currentSel) =+    UnionTag oldTag <$> merge path oldSel currentSel++instance KeyOf UnionTag where+  type KEY UnionTag = TypeName+  keyOf = unionTagName++type UnionSelection (s :: Stage) = MergeSet s UnionTag++type SelectionSet (s :: Stage) = MergeSet s (Selection s)++data Selection (s :: Stage) where+  Selection ::+    { selectionName :: FieldName,+      selectionAlias :: Maybe FieldName,+      selectionPosition :: Position,+      selectionArguments :: Arguments s,+      selectionContent :: SelectionContent s,+      selectionDirectives :: Directives s+    } ->+    Selection s+  InlineFragment :: Fragment -> Selection RAW+  Spread :: Directives RAW -> Ref -> Selection RAW++instance KeyOf (Selection s) where+  keyOf+    Selection+      { selectionName,+        selectionAlias+      } = fromMaybe selectionName selectionAlias+  keyOf _ = ""++useDufferentAliases :: Message+useDufferentAliases =+  "Use different aliases on the "+    <> "fields to fetch both if this was intentional."++instance+  Merge (SelectionSet a) =>+  Merge (Selection a)+  where+  merge+    path+    old@Selection {selectionPosition = pos1}+    current@Selection {selectionPosition = pos2} =+      do+        selectionName <- mergeName+        let currentPath = path <> [Ref selectionName pos1]+        selectionArguments <- mergeArguments currentPath+        selectionContent <- merge currentPath (selectionContent old) (selectionContent current)+        pure $+          Selection+            { selectionAlias = mergeAlias,+              selectionPosition = pos1,+              selectionDirectives = selectionDirectives old <> selectionDirectives current,+              ..+            }+      where+        -- passes if:++        --     user1: user+        --   }+        -- fails if:++        --     user1: product+        --   }+        mergeName+          | selectionName old == selectionName current = pure $ selectionName current+          | otherwise =+            failure $ mergeConflict path $+              GQLError+                { message =+                    "" <> msg (selectionName old) <> " and " <> msg (selectionName current)+                      <> " are different fields. "+                      <> useDufferentAliases,+                  locations = [pos1, pos2]+                }+        ---------------------+        -- allias name is relevant only if they collide by allias like:+        --   { user1: user+        --     user1: user+        --   }+        mergeAlias+          | all (isJust . selectionAlias) [old, current] = selectionAlias old+          | otherwise = Nothing+        --- arguments must be equal+        mergeArguments currentPath+          | selectionArguments old == selectionArguments current = pure $ selectionArguments current+          | otherwise =+            failure $ mergeConflict currentPath $+              GQLError+                { message = "they have differing arguments. " <> useDufferentAliases,+                  locations = [pos1, pos2]+                }+  merge path _ _ =+    failure $ mergeConflict path $+      GQLError+        { message = "INTERNAL: can't merge. " <> useDufferentAliases,+          locations = []+        }++deriving instance Show (Selection a)++deriving instance Lift (Selection a)++deriving instance Eq (Selection a)++type DefaultValue = Maybe ResolvedValue++data Operation (s :: Stage) = Operation+  { operationName :: Maybe FieldName,+    operationType :: OperationType,+    operationArguments :: VariableDefinitions s,+    operationSelection :: SelectionSet s,+    operationPosition :: Position,+    operationDirectives :: Directives s+  }+  deriving (Show, Lift)++getOperationName :: Maybe FieldName -> TypeName+getOperationName = maybe "AnonymousOperation" (TypeName . readName)++getOperationDataType :: Failure GQLErrors m => Operation a -> Schema -> m (TypeDefinition OUT)+getOperationDataType Operation {operationType = Query} lib = pure (query lib)+getOperationDataType Operation {operationType = Mutation, operationPosition} lib =+  case mutation lib of+    Just x -> pure x+    Nothing -> failure $ mutationIsNotDefined operationPosition+getOperationDataType Operation {operationType = Subscription, operationPosition} lib =+  case subscription lib of+    Just x -> pure x+    Nothing -> failure $ subscriptionIsNotDefined operationPosition
+ src/Data/Morpheus/Types/Internal/AST/TH.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Data.Morpheus.Types.Internal.AST.TH+  ( TypeD (..),+    ConsD (..),+    mkCons,+    GQLTypeD (..),+    isEnum,+    mkConsEnum,+  )+where++import Data.Morpheus.Internal.Utils (elems)+import Data.Morpheus.Types.Internal.AST.Base+  ( DataTypeKind,+    FieldName,+    TypeName,+    TypeRef (..),+    hsTypeName,+  )+import Data.Morpheus.Types.Internal.AST.Data+  ( ANY,+    DataEnumValue (..),+    FieldDefinition (..),+    FieldsDefinition,+    Meta,+    TypeDefinition,+  )++toHSFieldDefinition :: FieldDefinition cat -> FieldDefinition cat+toHSFieldDefinition field@FieldDefinition {fieldType = tyRef@TypeRef {typeConName}} =+  field+    { fieldType = tyRef {typeConName = hsTypeName typeConName}+    }++-- Template Haskell Types+-- Document+data GQLTypeD = GQLTypeD+  { typeD :: TypeD,+    typeArgD :: [TypeD],+    typeOriginal :: TypeDefinition ANY+  }+  deriving (Show)++--- Core+data TypeD = TypeD+  { tName :: TypeName,+    tNamespace :: [FieldName],+    tCons :: [ConsD],+    tKind :: DataTypeKind,+    tMeta :: Maybe Meta+  }+  deriving (Show)++data ConsD = ConsD+  { cName :: TypeName,+    cFields :: [FieldDefinition ANY]+  }+  deriving (Show)++mkCons :: TypeName -> FieldsDefinition cat -> ConsD+mkCons typename fields =+  ConsD+    { cName = hsTypeName typename,+      cFields = map (toHSFieldDefinition . mockFieldDefinition) (elems fields)+    }++isEnum :: [ConsD] -> Bool+isEnum = all (null . cFields)++mockFieldDefinition :: FieldDefinition a -> FieldDefinition b+mockFieldDefinition FieldDefinition {..} = FieldDefinition {..}++mkConsEnum :: DataEnumValue -> ConsD+mkConsEnum DataEnumValue {enumName} = ConsD {cName = hsTypeName enumName, cFields = []}
+ src/Data/Morpheus/Types/Internal/AST/Value.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Types.Internal.AST.Value+  ( Value (..),+    ScalarValue (..),+    Object,+    GQLValue (..),+    replaceValue,+    decodeScientific,+    RawValue,+    ValidValue,+    RawObject,+    ValidObject,+    Variable (..),+    ResolvedValue,+    ResolvedObject,+    VariableContent (..),+    ObjectEntry (..),+    VariableDefinitions,+  )+where++import qualified Data.Aeson as A+  ( (.=),+    FromJSON (..),+    ToJSON (..),+    Value (..),+    encode,+    object,+    pairs,+  )+import qualified Data.HashMap.Strict as M+  ( toList,+  )+-- MORPHEUS+import Data.Morpheus.Error.NameCollision+  ( NameCollision (..),+  )+import Data.Morpheus.Internal.Utils+  ( KeyOf (..),+    elems,+    mapTuple,+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( FieldName,+    FieldName (..),+    GQLError (..),+    Msg (..),+    Position,+    RAW,+    RESOLVED,+    Ref (..),+    Stage,+    TypeName (..),+    TypeRef,+    TypeRef (..),+    VALID,+  )+import Data.Morpheus.Types.Internal.AST.OrderedMap+  ( OrderedMap,+    unsafeFromValues,+  )+import Data.Scientific+  ( Scientific,+    floatingOrInteger,+  )+import Data.Semigroup ((<>))+import Data.Text+  ( Text,+    unpack,+  )+import qualified Data.Vector as V+  ( toList,+  )+import GHC.Generics (Generic)+import Instances.TH.Lift ()+import Language.Haskell.TH.Syntax (Lift (..))++-- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'.+-- for performance reason type 'Text' represents GraphQl 'String' value+data ScalarValue+  = Int Int+  | Float Float+  | String Text+  | Boolean Bool+  deriving (Show, Eq, Generic, Lift)++instance A.ToJSON ScalarValue where+  toJSON (Float x) = A.toJSON x+  toJSON (Int x) = A.toJSON x+  toJSON (Boolean x) = A.toJSON x+  toJSON (String x) = A.toJSON x++instance A.FromJSON ScalarValue where+  parseJSON (A.Bool v) = pure $ Boolean v+  parseJSON (A.Number v) = pure $ decodeScientific v+  parseJSON (A.String v) = pure $ String v+  parseJSON notScalar = fail $ "Expected Scalar got :" <> show notScalar++type family VAR (a :: Stage) :: Stage++type instance VAR RAW = RESOLVED++type instance VAR RESOLVED = RESOLVED++type instance VAR VALID = VALID++data VariableContent (stage :: Stage) where+  DefaultValue :: Maybe ResolvedValue -> VariableContent RESOLVED+  ValidVariableValue :: {validVarContent :: ValidValue} -> VariableContent VALID++instance Lift (VariableContent a) where+  lift (DefaultValue x) = [|DefaultValue x|]+  lift (ValidVariableValue x) = [|ValidVariableValue x|]++deriving instance Show (VariableContent a)++deriving instance Eq (VariableContent a)++data Variable (stage :: Stage) = Variable+  { variableName :: FieldName,+    variableType :: TypeRef,+    variablePosition :: Position,+    variableValue :: VariableContent (VAR stage)+  }+  deriving (Show, Eq, Lift)++instance KeyOf (Variable s) where+  keyOf = variableName++instance NameCollision (Variable s) where+  nameCollision _ Variable {variableName, variablePosition} =+    GQLError+      { message = "There can Be only One Variable Named " <> msg variableName,+        locations = [variablePosition]+      }++type VariableDefinitions s = OrderedMap FieldName (Variable s)++data Value (stage :: Stage) where+  ResolvedVariable :: Ref -> Variable VALID -> Value RESOLVED+  VariableValue :: Ref -> Value RAW+  Object :: Object stage -> Value stage+  List :: [Value stage] -> Value stage+  Enum :: TypeName -> Value stage+  Scalar :: ScalarValue -> Value stage+  Null :: Value stage++deriving instance Eq (Value s)++data ObjectEntry (s :: Stage) = ObjectEntry+  { entryName :: FieldName,+    entryValue :: Value s+  }+  deriving (Eq)++instance Show (ObjectEntry s) where+  show (ObjectEntry (FieldName name) value) = unpack name <> ":" <> show value++instance NameCollision (ObjectEntry s) where+  nameCollision _ ObjectEntry {entryName} =+    GQLError+      { message = "There can Be only One field Named " <> msg entryName,+        locations = []+      }++instance KeyOf (ObjectEntry s) where+  keyOf = entryName++type Object a = OrderedMap FieldName (ObjectEntry a)++type ValidObject = Object VALID++type RawObject = Object RAW++type ResolvedObject = Object RESOLVED++type RawValue = Value RAW++type ValidValue = Value VALID++type ResolvedValue = Value RESOLVED++deriving instance Lift (Value a)++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 <> "}"+    where+      toEntry :: ObjectEntry a -> String -> String+      toEntry value "" = show value+      toEntry value txt = txt <> ", " <> show value+  show (List list) = "[" <> foldl toEntry "" list <> "]"+    where+      toEntry :: String -> Value a -> String+      toEntry "" value = show value+      toEntry txt value = txt <> ", " <> show value++instance Msg (Value a) where+  msg = msg . A.encode++instance A.ToJSON (Value a) where+  toJSON (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) =+    A.toJSON x+  toJSON (VariableValue Ref {refName}) =+    A.String $ "($ref:" <> readName refName <> ")"+  toJSON Null = A.Null+  toJSON (Enum (TypeName x)) = A.String x+  toJSON (Scalar x) = A.toJSON x+  toJSON (List x) = A.toJSON x+  toJSON (Object fields) = A.object $ map toEntry (elems fields)+    where+      toEntry (ObjectEntry (FieldName name) value) = name A..= A.toJSON value++  -------------------------------------------+  toEncoding (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) =+    A.toEncoding x+  toEncoding (VariableValue Ref {refName}) =+    A.toEncoding $ "($ref:" <> refName <> ")"+  toEncoding Null = A.toEncoding A.Null+  toEncoding (Enum x) = A.toEncoding x+  toEncoding (Scalar x) = A.toEncoding x+  toEncoding (List x) = A.toEncoding x+  toEncoding (Object ordmap)+    | null ordmap = A.toEncoding $ A.object []+    | otherwise = A.pairs $ foldl1 (<>) $ map encodeField (elems ordmap)+    where+      encodeField (ObjectEntry (FieldName key) value) = key A..= value++decodeScientific :: Scientific -> ScalarValue+decodeScientific v = case floatingOrInteger v of+  Left float -> Float float+  Right int -> Int int++replaceValue :: A.Value -> Value a+replaceValue (A.Bool v) = gqlBoolean v+replaceValue (A.Number v) = Scalar $ decodeScientific v+replaceValue (A.String v) = gqlString v+replaceValue (A.Object v) =+  gqlObject $+    map+      (mapTuple FieldName replaceValue)+      (M.toList v)+replaceValue (A.Array li) = gqlList (map replaceValue (V.toList li))+replaceValue A.Null = gqlNull++instance A.FromJSON (Value a) where+  parseJSON = pure . replaceValue++-- DEFAULT VALUES+class GQLValue a where+  gqlNull :: a+  gqlScalar :: ScalarValue -> a+  gqlBoolean :: Bool -> a+  gqlString :: Text -> a+  gqlList :: [a] -> a+  gqlObject :: [(FieldName, a)] -> a++-- build GQL Values for Subscription Resolver+instance GQLValue (Value a) where+  gqlNull = Null+  gqlScalar = Scalar+  gqlBoolean = Scalar . Boolean+  gqlString = Scalar . String+  gqlList = List+  gqlObject = Object . unsafeFromValues . map toEntry+    where+      toEntry (key, value) = ObjectEntry key value
+ src/Data/Morpheus/Types/Internal/Resolving.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Types.Internal.Resolving+  ( Event (..),+    UnSubResolver,+    Resolver,+    MapStrategy (..),+    LiftOperation,+    runRootResModel,+    toResolver,+    lift,+    SubEvent,+    Eventless,+    Failure (..),+    GQLChannel (..),+    ResponseEvent (..),+    ResponseStream,+    cleanEvents,+    Result (..),+    ResultT (..),+    unpackEvents,+    LibUpdater,+    resolveUpdates,+    setTypeName,+    ObjectResModel (..),+    ResModel (..),+    FieldResModel,+    WithOperation,+    PushEvents (..),+    subscribe,+    Context (..),+    unsafeInternalContext,+    RootResModel (..),+    unsafeBind,+    liftStateless,+    resultOr,+    withArguments,+    -- Dynamic Resolver+    mkBoolean,+    mkFloat,+    mkInt,+    mkEnum,+    mkList,+    mkUnion,+    mkObject,+    mkNull,+    mkString,+  )+where++import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    ScalarValue (..),+    Token,+    TypeName,+  )+import Data.Morpheus.Types.Internal.Resolving.Core+import Data.Morpheus.Types.Internal.Resolving.Resolver++mkString :: Token -> ResModel o e m+mkString = ResScalar . String++mkFloat :: Float -> ResModel o e m+mkFloat = ResScalar . Float++mkInt :: Int -> ResModel o e m+mkInt = ResScalar . Int++mkBoolean :: Bool -> ResModel o e m+mkBoolean = ResScalar . Boolean++mkEnum :: TypeName -> TypeName -> ResModel o e m+mkEnum = ResEnum++mkList :: [ResModel o e m] -> ResModel o e m+mkList = ResList++mkUnion :: TypeName -> Resolver o e m (ResModel o e m) -> ResModel o e m+mkUnion = ResUnion++mkNull :: ResModel o e m+mkNull = ResNull++mkObject ::+  TypeName ->+  [(FieldName, Resolver o e m (ResModel o e m))] ->+  ResModel o e m+mkObject __typename objectFields =+  ResObject+    ( ObjectResModel+        { __typename,+          objectFields+        }+    )
+ src/Data/Morpheus/Types/Internal/Resolving/Core.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Morpheus.Types.Internal.Resolving.Core+  ( Eventless,+    Result (..),+    Failure (..),+    ResultT (..),+    unpackEvents,+    LibUpdater,+    resolveUpdates,+    mapEvent,+    cleanEvents,+    Event (..),+    Channel (..),+    GQLChannel (..),+    PushEvents (..),+    statelessToResultT,+    resultOr,+  )+where++import Control.Applicative (liftA2)+import Control.Monad (foldM)+import Control.Monad.Trans.Class (MonadTrans (..))+import Data.Function ((&))+import Data.Morpheus.Internal.Utils+  ( Failure (..),+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( GQLError (..),+    GQLErrors,+    Message,+  )+import Data.Semigroup ((<>))++type Eventless = Result ()++-- EVENTS+class PushEvents e m where+  pushEvents :: [e] -> m ()++-- Channel+newtype Channel event = Channel+  { _unChannel :: StreamChannel event+  }++instance (Eq (StreamChannel event)) => Eq (Channel event) where+  Channel x == Channel y = x == y++class GQLChannel a where+  type StreamChannel a :: *+  streamChannels :: a -> [Channel a]++instance GQLChannel () where+  type StreamChannel () = ()+  streamChannels _ = []++instance GQLChannel (Event channel content) where+  type StreamChannel (Event channel content) = channel+  streamChannels Event {channels} = map Channel channels++data Event e c = Event+  {channels :: [e], content :: c}++unpackEvents :: Result event a -> [event]+unpackEvents Success {events} = events+unpackEvents _ = []++--+-- Result+--+--+data Result events a+  = Success {result :: a, warnings :: GQLErrors, events :: [events]}+  | Failure {errors :: GQLErrors}+  deriving (Functor)++instance Applicative (Result e) where+  pure x = Success x [] []+  Success f w1 e1 <*> Success x w2 e2 = Success (f x) (w1 <> w2) (e1 <> e2)+  Failure e1 <*> Failure e2 = Failure (e1 <> e2)+  Failure e <*> Success _ w _ = Failure (e <> w)+  Success _ w _ <*> Failure e = Failure (e <> w)++instance Monad (Result e) where+  return = pure+  Success v w1 e1 >>= fm = case fm v of+    (Success x w2 e2) -> Success x (w1 <> w2) (e1 <> e2)+    (Failure e) -> Failure (e <> w1)+  Failure e >>= _ = Failure e++instance Failure [GQLError] (Result ev) where+  failure = Failure++instance Failure Message (Result e) where+  failure text =+    Failure [GQLError {message = "INTERNAL: " <> text, locations = []}]++instance PushEvents events (Result events) where+  pushEvents events = Success {result = (), warnings = [], events}++resultOr :: (GQLErrors -> a') -> (a -> a') -> Result e a -> a'+resultOr _ f (Success x _ _) = f x+resultOr f _ (Failure e) = f e++-- ResultT+newtype ResultT event (m :: * -> *) a = ResultT+  { runResultT :: m (Result event a)+  }+  deriving (Functor)++statelessToResultT ::+  Applicative m =>+  Eventless a ->+  ResultT e m a+statelessToResultT =+  cleanEvents+    . ResultT+    . pure++instance Applicative m => Applicative (ResultT event m) where+  pure = ResultT . pure . pure+  ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) app1 app2++instance Monad m => Monad (ResultT event m) where+  return = pure+  (ResultT m1) >>= mFunc = ResultT $ do+    result1 <- m1+    case result1 of+      Failure errors -> pure $ Failure errors+      Success value1 w1 e1 -> do+        result2 <- runResultT (mFunc value1)+        case result2 of+          Failure errors -> pure $ Failure (errors <> w1)+          Success v2 w2 e2 -> return $ Success v2 (w1 <> w2) (e1 <> e2)++instance MonadTrans (ResultT event) where+  lift = ResultT . fmap pure++-- instance Applicative m => Failure String (ResultT event m) where+--   failure x =+--     ResultT $ pure $ Failure [GQLError {message = pack x, locations = []}]++instance Monad m => Failure GQLErrors (ResultT event m) where+  failure = ResultT . pure . failure++instance Applicative m => Failure Message (ResultT event m) where+  failure = ResultT . pure . failure++instance Applicative m => PushEvents event (ResultT event m) where+  pushEvents = ResultT . pure . pushEvents++cleanEvents ::+  Functor m =>+  ResultT e m a ->+  ResultT e' m a+cleanEvents resT = ResultT $ replace <$> runResultT resT+  where+    replace (Success v w _) = Success v w []+    replace (Failure e) = Failure e++mapEvent ::+  Monad m =>+  (e -> e') ->+  ResultT e m value ->+  ResultT e' m value+mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma+  where+    mapEv Success {result, warnings, events} =+      Success {result, warnings, events = map func events}+    mapEv (Failure err) = Failure err++-- Helper Functions+type LibUpdater lib = lib -> Eventless lib++resolveUpdates :: Monad m => lib -> [lib -> m lib] -> m lib+resolveUpdates = foldM (&)
+ src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs view
@@ -0,0 +1,576 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Morpheus.Types.Internal.Resolving.Resolver+  ( Event (..),+    UnSubResolver,+    Resolver,+    MapStrategy (..),+    LiftOperation,+    unsafeBind,+    toResolver,+    lift,+    subscribe,+    SubEvent,+    GQLChannel (..),+    ResponseEvent (..),+    ResponseStream,+    ObjectResModel (..),+    ResModel (..),+    FieldResModel,+    WithOperation,+    Context (..),+    unsafeInternalContext,+    runRootResModel,+    setTypeName,+    RootResModel (..),+    liftStateless,+    withArguments,+  )+where++import Control.Monad.Fail (MonadFail (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad.Trans.Reader (ReaderT (..), ask, mapReaderT, withReaderT)+import Data.Maybe (maybe)+-- MORPHEUS+import Data.Morpheus.Error.Internal (internalResolvingError)+import Data.Morpheus.Error.Selection (subfieldsNotSelected)+import Data.Morpheus.Internal.Utils+  ( Merge (..),+    empty,+    keyOf,+    selectOr,+  )+import Data.Morpheus.Types.IO+  ( GQLResponse,+    renderResponse,+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( FieldName,+    GQLError (..),+    GQLErrors,+    MUTATION,+    Message,+    OperationType,+    OperationType (..),+    QUERY,+    SUBSCRIPTION,+    TypeName (..),+    VALID,+    msg,+  )+import Data.Morpheus.Types.Internal.AST.Data+  ( Arguments,+    Schema,+  )+import Data.Morpheus.Types.Internal.AST.MergeSet+  ( toOrderedMap,+  )+import Data.Morpheus.Types.Internal.AST.Selection+  ( Operation (..),+    Selection (..),+    SelectionContent (..),+    SelectionSet,+    UnionSelection,+    UnionTag (..),+  )+import Data.Morpheus.Types.Internal.AST.Value+  ( GQLValue (..),+    ObjectEntry (..),+    ScalarValue (..),+    ValidValue,+    Value (..),+  )+import Data.Morpheus.Types.Internal.Resolving.Core+  ( Channel (..),+    Event (..),+    Eventless,+    Failure (..),+    GQLChannel (..),+    PushEvents (..),+    Result (..),+    ResultT (..),+    StreamChannel,+    cleanEvents,+    mapEvent,+    statelessToResultT,+  )+import Data.Semigroup+  ( (<>),+    Semigroup (..),+  )++type WithOperation (o :: OperationType) = LiftOperation o++type ResponseStream event (m :: * -> *) = ResultT (ResponseEvent event m) m++data ResponseEvent event (m :: * -> *)+  = Publish event+  | Subscribe (SubEvent event m)++type SubEvent event m = Event (Channel event) (event -> m GQLResponse)++-- | A datatype to expose 'Schema' and the query's AST information ('Selection', 'Operation').+data Context = Context+  { currentSelection :: Selection VALID,+    schema :: Schema,+    operation :: Operation VALID,+    currentTypeName :: TypeName+  }+  deriving (Show)++-- Resolver Internal State+newtype ResolverState event m a = ResolverState+  { runResolverState :: ReaderT Context (ResultT event m) a+  }+  deriving+    ( Functor,+      Applicative,+      Monad+    )++instance MonadTrans (ResolverState e) where+  lift = ResolverState . lift . lift++instance (Monad m) => Failure Message (ResolverState e m) where+  failure message = ResolverState $ do+    selection <- currentSelection <$> ask+    lift $ failure [resolverFailureMessage selection message]++instance (Monad m) => Failure GQLErrors (ResolverState e m) where+  failure = ResolverState . lift . failure++instance (Monad m) => PushEvents e (ResolverState e m) where+  pushEvents = ResolverState . lift . pushEvents++mapResolverState ::+  ( ReaderT Context (ResultT e m) a ->+    ReaderT Context (ResultT e' m') a'+  ) ->+  ResolverState e m a ->+  ResolverState e' m' a'+mapResolverState f (ResolverState x) = ResolverState (f x)++getState :: (Monad m) => ResolverState e m (Selection VALID)+getState = ResolverState $ currentSelection <$> ask++mapState :: (Context -> Context) -> ResolverState e m a -> ResolverState e m a+mapState f = mapResolverState (withReaderT f)++-- clear evets and starts new resolver with diferenct type of events but with same value+-- use properly. only if you know what you are doing+clearStateResolverEvents :: (Functor m) => ResolverState e m a -> ResolverState e' m a+clearStateResolverEvents = mapResolverState (mapReaderT cleanEvents)++resolverFailureMessage :: Selection VALID -> Message -> GQLError+resolverFailureMessage Selection {selectionName, selectionPosition} message =+  GQLError+    { message = "Failure on Resolving Field " <> msg selectionName <> ": " <> message,+      locations = [selectionPosition]+    }++--+-- GraphQL Field Resolver+--+---------------------------------------------------------------+data Resolver (o :: OperationType) event (m :: * -> *) value where+  ResolverQ :: {runResolverQ :: ResolverState () m value} -> Resolver QUERY event m value+  ResolverM :: {runResolverM :: ResolverState event m value} -> Resolver MUTATION event m value+  ResolverS :: {runResolverS :: ResolverState (Channel event) m (ReaderT event (Resolver QUERY event m) value)} -> Resolver SUBSCRIPTION event m value++instance Show (Resolver o e m value) where+  show ResolverQ {} = "Resolver QUERY e m a"+  show ResolverM {} = "Resolver MUTATION e m a"+  show ResolverS {} = "Resolver SUBSCRIPTION e m a"++deriving instance (Functor m) => Functor (Resolver o e m)++-- Applicative+instance (LiftOperation o, Monad m) => Applicative (Resolver o e m) where+  pure = packResolver . pure+  ResolverQ r1 <*> ResolverQ r2 = ResolverQ $ r1 <*> r2+  ResolverM r1 <*> ResolverM r2 = ResolverM $ r1 <*> r2+  ResolverS r1 <*> ResolverS r2 = ResolverS $ (<*>) <$> r1 <*> r2++-- Monad+instance (Monad m, LiftOperation o) => Monad (Resolver o e m) where+  return = pure+  (>>=) = unsafeBind++#if __GLASGOW_HASKELL__ < 808+  fail = failure . msg+# endif++-- MonadIO+instance (MonadIO m, LiftOperation o) => MonadIO (Resolver o e m) where+  liftIO = lift . liftIO++-- Monad Transformers+instance (LiftOperation o) => MonadTrans (Resolver o e) where+  lift = packResolver . lift++-- Failure+instance (LiftOperation o, Monad m) => Failure Message (Resolver o e m) where+  failure = packResolver . failure++instance (LiftOperation o, Monad m) => Failure GQLErrors (Resolver o e m) where+  failure = packResolver . failure++instance (Monad m, LiftOperation o) => MonadFail (Resolver o e m) where+  fail = failure . msg++-- PushEvents+instance (Monad m) => PushEvents e (Resolver MUTATION e m) where+  pushEvents = packResolver . pushEvents++instance (Monad m, Semigroup a, LiftOperation o) => Semigroup (Resolver o e m a) where+  x <> y = fmap (<>) x <*> y++liftStateless ::+  ( LiftOperation o,+    Monad m+  ) =>+  Eventless a ->+  Resolver o e m a+liftStateless =+  packResolver+    . ResolverState+    . ReaderT+    . const+    . statelessToResultT++class LiftOperation (o :: OperationType) where+  packResolver :: Monad m => ResolverState e m a -> Resolver o e m a+  withResolver :: Monad m => ResolverState e m a -> (a -> Resolver o e m b) -> Resolver o e m b++-- packResolver+instance LiftOperation QUERY where+  packResolver = ResolverQ . clearStateResolverEvents+  withResolver ctxRes toRes = ResolverQ $ do+    v <- clearStateResolverEvents ctxRes+    runResolverQ $ toRes v++instance LiftOperation MUTATION where+  packResolver = ResolverM+  withResolver ctxRes toRes = ResolverM $ ctxRes >>= runResolverM . toRes++instance LiftOperation SUBSCRIPTION where+  packResolver = ResolverS . pure . lift . packResolver+  withResolver ctxRes toRes = ResolverS $ do+    value <- clearStateResolverEvents ctxRes+    runResolverS $ toRes value++mapResolverContext :: Monad m => (Context -> Context) -> Resolver o e m a -> Resolver o e m a+mapResolverContext f (ResolverQ res) = ResolverQ (mapState f res)+mapResolverContext f (ResolverM res) = ResolverM (mapState f res)+mapResolverContext f (ResolverS resM) = ResolverS $ do+  res <- resM+  pure $ ReaderT $ \e -> ResolverQ $ mapState f (runResolverQ (runReaderT res e))++setSelection :: Monad m => Selection VALID -> Resolver o e m a -> Resolver o e m a+setSelection currentSelection =+  mapResolverContext (\ctx -> ctx {currentSelection})++setTypeName :: Monad m => TypeName -> Resolver o e m a -> Resolver o e m a+setTypeName currentTypeName =+  mapResolverContext (\ctx -> ctx {currentTypeName})++-- unsafe variant of >>= , not for public api. user can be confused:+--  ignores `channels` on second Subsciption, only returns events from first Subscription monad.+--    reason: second monad is waiting for `event` until he does not have some event can't tell which+--            channel does it have to listen+unsafeBind ::+  forall o e m a b.+  Monad m =>+  Resolver o e m a ->+  (a -> Resolver o e m b) ->+  Resolver o e m b+unsafeBind (ResolverQ x) m2 = ResolverQ (x >>= runResolverQ . m2)+unsafeBind (ResolverM x) m2 = ResolverM (x >>= runResolverM . m2)+unsafeBind (ResolverS res) m2 = ResolverS $ do+  (readResA :: ReaderT e (Resolver QUERY e m) a) <- res+  pure $ ReaderT $ \e -> ResolverQ $ do+    let (resA :: Resolver QUERY e m a) = runReaderT readResA e+    (valA :: a) <- runResolverQ resA+    (readResB :: ReaderT e (Resolver QUERY e m) b) <- clearStateResolverEvents $ runResolverS (m2 valA)+    runResolverQ $ runReaderT readResB e++subscribe ::+  forall e m a.+  ( PushEvents (Channel e) (ResolverState (Channel e) m),+    Monad m+  ) =>+  [StreamChannel e] ->+  Resolver QUERY e m (e -> Resolver QUERY e m a) ->+  Resolver SUBSCRIPTION e m a+subscribe ch res = ResolverS $ do+  pushEvents (map Channel ch :: [Channel e])+  (eventRes :: e -> Resolver QUERY e m a) <- clearStateResolverEvents (runResolverQ res)+  pure $ ReaderT eventRes++-- | A function to return the internal 'Context' within a resolver's monad.+-- Using the 'Context' itself is unsafe because it expposes internal structures+-- of the AST, but you can use the "Data.Morpheus.Types.SelectionTree" typeclass to manipulate+-- the internal AST with a safe interface.+unsafeInternalContext :: (Monad m, LiftOperation o) => Resolver o e m Context+unsafeInternalContext = packResolver $ ResolverState ask++-- Converts Subscription Resolver Type to Query Resolver+type family UnSubResolver (a :: * -> *) :: (* -> *)++type instance UnSubResolver (Resolver SUBSCRIPTION e m) = Resolver QUERY e m++withArguments ::+  forall o e m a.+  (LiftOperation o, Monad m) =>+  (Arguments VALID -> Resolver o e m a) ->+  Resolver o e m a+withArguments = withResolver args+  where+    args :: ResolverState e m (Arguments VALID)+    args = selectionArguments <$> getState++--+-- Selection Processing+toResolver ::+  forall o e m a b.+  (LiftOperation o, Monad m) =>+  (Arguments VALID -> Eventless a) ->+  (a -> Resolver o e m b) ->+  Resolver o e m b+toResolver toArgs = withResolver args+  where+    args :: ResolverState e m a+    args =+      ResultT . pure . toArgs . selectionArguments <$> getState+        >>= ResolverState . lift . cleanEvents++pickSelection :: TypeName -> UnionSelection VALID -> SelectionSet VALID+pickSelection = selectOr empty unionTagSelection++withObject ::+  (LiftOperation o, Monad m) =>+  (SelectionSet VALID -> Resolver o e m value) ->+  Selection VALID ->+  Resolver o e m value+withObject f Selection {selectionName, selectionContent, selectionPosition} = checkContent selectionContent+  where+    checkContent (SelectionSet selection) = f selection+    checkContent _ = failure (subfieldsNotSelected selectionName "" selectionPosition)++lookupRes ::+  (LiftOperation o, Monad m) =>+  Selection VALID ->+  ObjectResModel o e m ->+  Resolver o e m ValidValue+lookupRes Selection {selectionName}+  | selectionName == "__typename" =+    pure . Scalar . String . readTypeName . __typename+  | otherwise =+    maybe+      (pure gqlNull)+      (`unsafeBind` runDataResolver)+      . lookup selectionName+      . objectFields++resolveObject ::+  forall o e m.+  (LiftOperation o, Monad m) =>+  SelectionSet VALID ->+  ResModel o e m ->+  Resolver o e m ValidValue+resolveObject selectionSet (ResObject drv@ObjectResModel {__typename}) =+  Object . toOrderedMap <$> traverse resolver selectionSet+  where+    resolver :: Selection VALID -> Resolver o e m (ObjectEntry VALID)+    resolver sel =+      setSelection sel+        $ setTypeName __typename+        $ ObjectEntry (keyOf sel) <$> lookupRes sel drv+resolveObject _ _ =+  failure $ internalResolvingError "expected object as resolver"++toEventResolver :: Monad m => ReaderT event (Resolver QUERY event m) ValidValue -> Context -> event -> m GQLResponse+toEventResolver (ReaderT subRes) sel event = do+  value <- runResultT $ runReaderT (runResolverState $ runResolverQ (subRes event)) sel+  pure $ renderResponse value++runDataResolver :: (Monad m, LiftOperation o) => ResModel o e m -> Resolver o e m ValidValue+runDataResolver = withResolver getState . __encode+  where+    __encode obj sel@Selection {selectionContent} = encodeNode obj selectionContent+      where+        -- LIST+        encodeNode (ResList x) _ = List <$> traverse runDataResolver x+        -- Object -----------------+        encodeNode objDrv@ResObject {} _ = withObject (`resolveObject` objDrv) sel+        -- ENUM+        encodeNode (ResEnum _ enum) SelectionField = pure $ gqlString $ readTypeName enum+        encodeNode (ResEnum typename enum) unionSel@UnionSelection {} =+          encodeNode (unionDrv (typename <> "EnumObject")) unionSel+          where+            unionDrv name =+              ResUnion name+                $ pure+                $ ResObject+                $ ObjectResModel name [("enum", pure $ ResScalar $ String $ readTypeName enum)]+        encodeNode ResEnum {} _ =+          failure ("wrong selection on enum value" :: Message)+        -- UNION+        encodeNode (ResUnion typename unionRef) (UnionSelection selections) =+          unionRef >>= resolveObject currentSelection+          where+            currentSelection = pickSelection typename selections+        encodeNode (ResUnion name _) _ =+          failure ("union Resolver " <> msg name <> " should only recieve UnionSelection")+        -- SCALARS+        encodeNode ResNull _ = pure Null+        encodeNode (ResScalar x) SelectionField = pure $ Scalar x+        encodeNode ResScalar {} _ =+          failure ("scalar Resolver should only recieve SelectionField" :: Message)++runResolver ::+  Monad m =>+  Resolver o event m ValidValue ->+  Context ->+  ResponseStream event m ValidValue+runResolver (ResolverQ resT) sel = cleanEvents $ runReaderT (runResolverState resT) sel+runResolver (ResolverM resT) sel = mapEvent Publish $ runReaderT (runResolverState resT) sel+runResolver (ResolverS resT) sel = ResultT $ do+  readResValue <- runResultT $ runReaderT (runResolverState resT) sel+  pure $ case readResValue of+    Failure x -> Failure x+    Success {warnings, result, events = channels} -> do+      let eventRes = toEventResolver result sel+      Success+        { events = [Subscribe $ Event channels eventRes],+          warnings,+          result = gqlNull+        }++-- Resolver Models -------------------------------------------------------------------+type FieldResModel o e m =+  (FieldName, Resolver o e m (ResModel o e m))++data ObjectResModel o e m = ObjectResModel+  { __typename :: TypeName,+    objectFields ::+      [FieldResModel o e m]+  }+  deriving (Show)++instance Merge (ObjectResModel o e m) where+  merge _ (ObjectResModel tyname x) (ObjectResModel _ y) =+    pure $ ObjectResModel tyname (x <> y)++data ResModel (o :: OperationType) e (m :: * -> *)+  = ResNull+  | ResScalar ScalarValue+  | ResEnum TypeName TypeName+  | ResList [ResModel o e m]+  | ResObject (ObjectResModel o e m)+  | ResUnion TypeName (Resolver o e m (ResModel o e m))+  deriving (Show)++instance Merge (ResModel o e m) where+  merge p (ResObject x) (ResObject y) =+    ResObject <$> merge p x y+  merge _ _ _ =+    failure $ internalResolvingError "can't merge: incompatible resolvers"++data RootResModel e m = RootResModel+  { query :: Eventless (ResModel QUERY e m),+    mutation :: Eventless (ResModel MUTATION e m),+    subscription :: Eventless (ResModel SUBSCRIPTION e m)+  }++runRootDataResolver ::+  (Monad m, LiftOperation o) =>+  Eventless (ResModel o e m) ->+  Context ->+  ResponseStream e m (Value VALID)+runRootDataResolver+  res+  ctx@Context {operation = Operation {operationSelection}} =+    do+      root <- statelessToResultT res+      runResolver (resolveObject operationSelection root) ctx++runRootResModel :: Monad m => RootResModel e m -> Context -> ResponseStream e m (Value VALID)+runRootResModel+  RootResModel+    { query,+      mutation,+      subscription+    }+  ctx@Context {operation = Operation {operationType}} =+    selectByOperation operationType+    where+      selectByOperation Query =+        runRootDataResolver query ctx+      selectByOperation Mutation =+        runRootDataResolver mutation ctx+      selectByOperation Subscription =+        runRootDataResolver subscription ctx++-- map Resolving strategies+class+  MapStrategy+    (from :: OperationType)+    (to :: OperationType)+  where+  mapStrategy ::+    Monad m =>+    Resolver from e m (ResModel from e m) ->+    Resolver to e m (ResModel to e m)++instance MapStrategy o o where+  mapStrategy = id++instance MapStrategy QUERY SUBSCRIPTION where+  mapStrategy = ResolverS . pure . lift . fmap mapDeriving++mapDeriving ::+  ( MapStrategy o o',+    Monad m+  ) =>+  ResModel o e m ->+  ResModel o' e m+mapDeriving ResNull = ResNull+mapDeriving (ResScalar x) = ResScalar x+mapDeriving (ResEnum typeName enum) = ResEnum typeName enum+mapDeriving (ResList x) = ResList $ map mapDeriving x+mapDeriving (ResObject x) = ResObject (mapObjectDeriving x)+mapDeriving (ResUnion name x) = ResUnion name (mapStrategy x)++mapObjectDeriving ::+  ( MapStrategy o o',+    Monad m+  ) =>+  ObjectResModel o e m ->+  ObjectResModel o' e m+mapObjectDeriving (ObjectResModel tyname x) =+  ObjectResModel tyname $+    map (mapEntry mapStrategy) x++mapEntry :: (a -> b) -> (k, a) -> (k, b)+mapEntry f (name, value) = (name, f value)
+ src/Data/Morpheus/Types/Internal/Validation.hs view
@@ -0,0 +1,429 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Types.Internal.Validation+  ( Validator,+    SelectionValidator,+    InputValidator,+    BaseValidator,+    InputSource (..),+    Context (..),+    SelectionContext (..),+    runValidator,+    askSchema,+    askContext,+    askFragments,+    askFieldType,+    askTypeMember,+    selectRequired,+    selectKnown,+    Constraint (..),+    constraint,+    withScope,+    withScopeType,+    withScopePosition,+    askScopeTypeName,+    selectWithDefaultValue,+    askScopePosition,+    askInputFieldType,+    askInputMember,+    startInput,+    withInputScope,+    inputMessagePrefix,+    checkUnused,+    Prop (..),+    constraintInputUnion,+    ScopeKind (..),+    withDirective,+  )+where++import Control.Monad.Trans.Reader+  ( ReaderT (..),+    ask,+    withReaderT,+  )+-- MORPHEUS++import Data.Morpheus.Internal.Utils+  ( Failure (..),+    KeyOf (..),+    Selectable,+    member,+    selectBy,+    selectOr,+    size,+  )+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    Directive (..),+    FieldDefinition (..),+    FieldName,+    FieldsDefinition,+    Fragments,+    IN,+    Message,+    OUT,+    Object,+    Position,+    Ref (..),+    Schema,+    TypeContent (..),+    TypeDefinition (..),+    TypeName (..),+    TypeRef (..),+    Value (..),+    __inputname,+    entryValue,+    fromAny,+    isFieldNullable,+    msg,+    toFieldName,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+  )+import Data.Morpheus.Types.Internal.Validation.Error+  ( InternalError (..),+    KindViolation (..),+    MissingRequired (..),+    Unknown (..),+    Unused (..),+  )+import Data.Morpheus.Types.Internal.Validation.Validator+  ( BaseValidator,+    Constraint (..),+    Context (..),+    InputContext (..),+    InputSource (..),+    InputValidator,+    Prop (..),+    Resolution,+    ScopeKind (..),+    SelectionContext (..),+    SelectionValidator,+    Target (..),+    Validator (..),+    renderInputPrefix,+  )+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 x+  | null x = return ()+  | otherwise = do+    (gctx, _) <- Validator ask+    failure $ map (unused gctx) x++checkUnused :: (KeyOf b, KEY a ~ KEY b, Selectable ca a, Unused b) => ca -> [b] -> Validator ctx ()+checkUnused uses = failOnUnused . getUnused uses++constraint ::+  forall (a :: Target) inp ctx.+  KindViolation a inp =>+  Constraint (a :: Target) ->+  inp ->+  TypeDefinition ANY ->+  Validator ctx (Resolution a)+constraint OBJECT _ TypeDefinition {typeContent = DataObject {objectFields}, typeName} =+  pure (typeName, objectFields)+constraint INPUT ctx x = maybe (failure [kindViolation INPUT ctx]) pure (fromAny x)+constraint target ctx _ = failure [kindViolation target ctx]++selectRequired ::+  ( Selectable c value,+    MissingRequired c ctx,+    KEY Ref ~ KEY value+  ) =>+  Ref ->+  c ->+  Validator ctx value+selectRequired selector container =+  do+    (gctx, ctx) <- Validator ask+    selectBy+      [missingRequired gctx ctx selector container]+      (keyOf selector)+      container++selectWithDefaultValue ::+  ( Selectable values value,+    MissingRequired values ctx,+    KEY value ~ FieldName+  ) =>+  value ->+  FieldDefinition IN ->+  values ->+  Validator ctx value+selectWithDefaultValue+  fallbackValue+  field@FieldDefinition {fieldName}+  values =+    selectOr+      handleNullable+      pure+      fieldName+      values+    where+      ------------------+      handleNullable+        | isFieldNullable field = pure fallbackValue+        | otherwise = failSelection+      -----------------+      failSelection = do+        (gctx, ctx) <- Validator ask+        failure [missingRequired gctx ctx (Ref fieldName (scopePosition gctx)) values]++selectKnown ::+  ( Selectable c a,+    Unknown c ctx,+    KeyOf sel,+    sel ~ UnknownSelector c,+    KEY sel ~ KEY a+  ) =>+  sel ->+  c ->+  Validator ctx a+selectKnown selector lib =+  do+    (gctx, ctx) <- Validator ask+    selectBy+      (unknown gctx ctx lib selector)+      (keyOf selector)+      lib++askFieldType ::+  FieldDefinition OUT ->+  SelectionValidator (TypeDefinition OUT)+askFieldType field@FieldDefinition {fieldType = TypeRef {typeConName}} =+  do+    schema <- askSchema+    anyType <-+      selectBy+        [internalError field]+        typeConName+        schema+    case fromAny anyType of+      Just x -> pure x+      Nothing ->+        failure $+          "Type \"" <> msg (typeName anyType)+            <> "\" referenced by OBJECT \""+            <> "\" must be an OUTPUT_TYPE."++askTypeMember ::+  TypeName ->+  SelectionValidator (TypeName, FieldsDefinition OUT)+askTypeMember name =+  askSchema+    >>= selectOr notFound pure name+    >>= constraintOBJECT+  where+    notFound = do+      scopeType <- askScopeTypeName+      failure $+        "Type \""+          <> msg name+          <> "\" referenced by union \""+          <> msg scopeType+          <> "\" can't found in Schema."+    --------------------------------------+    constraintOBJECT :: TypeDefinition ANY -> SelectionValidator (TypeName, FieldsDefinition OUT)+    constraintOBJECT TypeDefinition {typeName, typeContent} = con typeContent+      where+        con DataObject {objectFields} = pure (typeName, objectFields)+        con _ = do+          scopeType <- askScopeTypeName+          failure $+            "Type \"" <> msg typeName+              <> "\" referenced by union \""+              <> msg scopeType+              <> "\" must be an OBJECT."++askInputFieldType ::+  FieldDefinition IN ->+  InputValidator (TypeDefinition IN)+askInputFieldType field@FieldDefinition {fieldName, fieldType = TypeRef {typeConName}} =+  askSchema+    >>= selectBy+      [internalError field]+      typeConName+    >>= constraintINPUT+  where+    constraintINPUT :: TypeDefinition ANY -> InputValidator (TypeDefinition IN)+    constraintINPUT x = case (fromAny x :: Maybe (TypeDefinition IN)) of+      Just inputType -> pure inputType+      Nothing ->+        failure $+          "Type \""+            <> msg (typeName x)+            <> "\" referenced by field \""+            <> msg fieldName+            <> "\" must be an input type."++askInputMember ::+  TypeName ->+  InputValidator (TypeDefinition IN)+askInputMember name =+  askSchema+    >>= selectOr notFound pure name+    >>= constraintINPUT_OBJECT+  where+    typeInfo tName =+      "Type \"" <> msg tName <> "\" referenced by inputUnion "+    notFound = do+      scopeType <- askScopeTypeName+      failure $+        typeInfo name+          <> msg scopeType+          <> "\" can't found in Schema."+    --------------------------------------+    constraintINPUT_OBJECT :: TypeDefinition ANY -> InputValidator (TypeDefinition IN)+    constraintINPUT_OBJECT TypeDefinition {typeContent, ..} = con (fromAny typeContent)+      where+        con :: Maybe (TypeContent a IN) -> InputValidator (TypeDefinition IN)+        con (Just content@DataInputObject {}) = pure TypeDefinition {typeContent = content, ..}+        con _ = do+          scopeType <- askScopeTypeName+          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)] ->+  Object stage ->+  Either Message (TypeName, Maybe (Value stage))+constraintInputUnion tags hm = do+  (enum :: Value stage) <-+    entryValue+      <$> selectBy+        ( "valid input union should contain \""+            <> msg __inputname+            <> "\" and actual value"+        )+        __inputname+        hm+  tyName <- isPosibeInputUnion tags enum+  case size hm of+    1 -> pure (tyName, Nothing)+    2 -> do+      value <-+        entryValue+          <$> selectBy+            ( "value for Union \""+                <> msg tyName+                <> "\" was not Provided."+            )+            (toFieldName tyName)+            hm+      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"
+ src/Data/Morpheus/Types/Internal/Validation/Error.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Types.Internal.Validation.Error+  ( MissingRequired (..),+    KindViolation (..),+    Unknown (..),+    InternalError (..),+    Target (..),+    Unused (..),+  )+where++-- MORPHEUS++import Data.Morpheus.Error.Selection (unknownSelectionField)+import Data.Morpheus.Error.Utils (errorMessage)+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    Arguments,+    Directive (..),+    DirectiveDefinition (..),+    DirectiveDefinitions,+    FieldDefinition (..),+    FieldsDefinition,+    Fragment (..),+    Fragments,+    GQLError (..),+    GQLErrors,+    IN,+    OUT,+    Object,+    ObjectEntry (..),+    RAW,+    RESOLVED,+    Ref (..),+    Schema,+    TypeNameRef (..),+    TypeRef (..),+    Variable (..),+    VariableDefinitions,+    getOperationName,+    msg,+  )+import Data.Morpheus.Types.Internal.Validation.Validator+  ( Context (..),+    InputContext (..),+    ScopeKind (..),+    Target (..),+    renderInputPrefix,+  )+import Data.Semigroup ((<>))++class InternalError a where+  internalError :: a -> GQLError++instance InternalError (FieldDefinition cat) where+  internalError+    FieldDefinition+      { fieldName,+        fieldType = TypeRef {typeConName}+      } =+      GQLError+        { message =+            "INTERNAL: Type " <> msg typeConName+              <> " referenced by field "+              <> msg fieldName+              <> " can't found in Schema ",+          locations = []+        }++class Unused c where+  unused :: Context -> c -> GQLError++-- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".",+instance Unused (Variable s) where+  unused+    Context {operationName}+    Variable {variableName, variablePosition} =+      GQLError+        { message =+            "Variable " <> msg ("$" <> variableName)+              <> " is never used in operation "+              <> msg (getOperationName operationName)+              <> ".",+          locations = [variablePosition]+        }++instance Unused Fragment where+  unused+    _+    Fragment {fragmentName, fragmentPosition} =+      GQLError+        { message =+            "Fragment " <> msg fragmentName+              <> " is never used.",+          locations = [fragmentPosition]+        }++class MissingRequired c ctx where+  missingRequired :: Context -> ctx -> Ref -> c -> GQLError++instance MissingRequired (Arguments s) ctx where+  missingRequired+    Context {scopePosition, scopeSelectionName, scopeKind}+    _+    Ref {refName}+    _ =+      GQLError+        { message =+            inScope scopeKind+              <> " argument "+              <> msg refName+              <> " is required but not provided.",+          locations = [scopePosition]+        }+      where+        inScope SELECTION = "Field " <> msg scopeSelectionName+        inScope DIRECTIVE = "Directive " <> msg ("@" <> scopeSelectionName)++instance MissingRequired (Object s) InputContext where+  missingRequired+    Context {scopePosition}+    inputCTX+    Ref {refName}+    _ =+      GQLError+        { message =+            renderInputPrefix inputCTX+              <> "Undefined Field "+              <> msg refName+              <> ".",+          locations = [scopePosition]+        }++instance MissingRequired (VariableDefinitions s) ctx where+  missingRequired+    Context {operationName}+    _+    Ref {refName, refPosition}+    _ =+      GQLError+        { message =+            "Variable "+              <> msg refName+              <> " is not defined by operation "+              <> msg (getOperationName operationName)+              <> ".",+          locations = [refPosition]+        }++class Unknown c ctx where+  type UnknownSelector c+  unknown :: Context -> ctx -> c -> UnknownSelector c -> GQLErrors++-- {...H} -> "Unknown fragment \"H\"."+instance Unknown Fragments ctx where+  type UnknownSelector Fragments = Ref+  unknown _ _ _ (Ref name pos) =+    errorMessage+      pos+      ("Unknown Fragment " <> msg name <> ".")++instance Unknown Schema ctx where+  type UnknownSelector Schema = TypeNameRef+  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} =+    errorMessage+      argumentPosition+      ("Unknown Argument " <> msg argumentName <> " on Field " <> msg fieldName <> ".")++instance Unknown (FieldsDefinition IN) InputContext where+  type UnknownSelector (FieldsDefinition IN) = ObjectEntry RESOLVED+  unknown Context {scopePosition} ctx _ ObjectEntry {entryName} =+    [ GQLError+        { message = renderInputPrefix ctx <> "Unknown Field " <> msg entryName <> ".",+          locations = [scopePosition]+        }+    ]++instance Unknown DirectiveDefinition ctx where+  type UnknownSelector DirectiveDefinition = Argument RESOLVED+  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} =+    errorMessage+      directivePosition+      ("Unknown Directive " <> msg directiveName <> ".")++instance Unknown (FieldsDefinition OUT) ctx where+  type UnknownSelector (FieldsDefinition OUT) = Ref+  unknown Context {scopeTypeName} _ _ =+    unknownSelectionField scopeTypeName++class KindViolation (t :: Target) ctx where+  kindViolation :: c t -> ctx -> GQLError++instance KindViolation 'TARGET_OBJECT Fragment where+  kindViolation _ Fragment {fragmentName, fragmentType, fragmentPosition} =+    GQLError+      { message =+          "Fragment "+            <> msg fragmentName+            <> " cannot condition on non composite type "+            <> msg fragmentType+            <> ".",+        locations = [fragmentPosition]+      }++instance KindViolation 'TARGET_INPUT (Variable s) where+  kindViolation+    _+    Variable+      { variableName,+        variablePosition,+        variableType = TypeRef {typeConName}+      } =+      GQLError+        { message =+            "Variable "+              <> msg ("$" <> variableName)+              <> " cannot be non-input type "+              <> msg typeConName+              <> ".",+          locations = [variablePosition]+        }
+ src/Data/Morpheus/Types/Internal/Validation/Validator.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Types.Internal.Validation.Validator+  ( Validator (..),+    SelectionValidator,+    InputValidator,+    BaseValidator,+    runValidator,+    askSchema,+    askContext,+    askFragments,+    Constraint (..),+    withScope,+    withScopeType,+    withScopePosition,+    askScopeTypeName,+    askScopePosition,+    withInputScope,+    inputMessagePrefix,+    Context (..),+    InputSource (..),+    InputContext (..),+    SelectionContext (..),+    renderInputPrefix,+    Target (..),+    Prop (..),+    Resolution,+    ScopeKind (..),+  )+where++import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad.Trans.Reader+  ( ReaderT (..),+    ask,+    withReaderT,+  )+-- MORPHEUS++import Data.Morpheus.Internal.Utils+  ( Failure (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    FieldName,+    FieldsDefinition,+    Fragments,+    GQLError (..),+    GQLErrors,+    IN,+    Message,+    OUT,+    Position,+    RAW,+    RESOLVED,+    Schema,+    TypeDefinition (..),+    TypeName,+    VALID,+    Variable (..),+    VariableDefinitions,+    intercalateName,+    msg,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+  )+import Data.Semigroup+  ( (<>),+    Semigroup (..),+  )++data Prop = Prop+  { propName :: FieldName,+    propTypeName :: TypeName+  }+  deriving (Show)++type Path = [Prop]++renderPath :: Path -> Message+renderPath [] = ""+renderPath path = "in field " <> msg (intercalateName "." $ map propName path) <> ": "++renderInputPrefix :: InputContext -> 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}) =+  "Variable " <> msg ("$" <> variableName) <> " got invalid value. "++data ScopeKind+  = DIRECTIVE+  | SELECTION+  deriving (Show)++data Context = Context+  { schema :: Schema,+    fragments :: Fragments,+    scopePosition :: Position,+    scopeTypeName :: TypeName,+    operationName :: Maybe FieldName,+    scopeSelectionName :: FieldName,+    scopeKind :: ScopeKind+  }+  deriving (Show)++data InputContext = InputContext+  { inputSource :: InputSource,+    inputPath :: [Prop]+  }+  deriving (Show)++data InputSource+  = SourceArgument (Argument RESOLVED)+  | SourceVariable (Variable RAW)+  deriving (Show)++newtype SelectionContext = SelectionContext+  { variables :: VariableDefinitions VALID+  }+  deriving (Show)++data Target+  = TARGET_OBJECT+  | TARGET_INPUT++data Constraint (a :: Target) where+  OBJECT :: Constraint 'TARGET_OBJECT+  INPUT :: Constraint 'TARGET_INPUT++--  UNION  :: Constraint 'TARGET_UNION++type family Resolution (a :: Target)++type instance Resolution 'TARGET_OBJECT = (TypeName, FieldsDefinition OUT)++type instance Resolution 'TARGET_INPUT = TypeDefinition IN++--type instance Resolution 'TARGET_UNION = DataUnion++withInputScope :: Prop -> InputValidator a -> InputValidator a+withInputScope prop = setContext update+  where+    update ctx@InputContext {inputPath = old} =+      ctx {inputPath = old <> [prop]}++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 -> Position -> Validator ctx a -> Validator ctx a+withScope scopeTypeName scopePosition = setGlobalContext update+  where+    update ctx = ctx {scopeTypeName, scopePosition}++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++runValidator :: Validator ctx a -> Context -> ctx -> Eventless a+runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX, ctx)++newtype Validator ctx a = Validator+  { _runValidator ::+      ReaderT+        (Context, ctx)+        Eventless+        a+  }+  deriving+    ( Functor,+      Applicative,+      Monad+    )++type BaseValidator = Validator ()++type SelectionValidator = Validator SelectionContext++type InputValidator = Validator InputContext++-- can be only used for internal errors+instance Failure Message (Validator ctx) where+  failure inputMessage = do+    position <- askScopePosition+    failure+      [ GQLError+          { message = "INTERNAL: " <> inputMessage,+            locations = [position]+          }+      ]++instance Failure GQLErrors (Validator ctx) where+  failure = Validator . lift . failure
+ src/Data/Morpheus/Types/SelectionTree.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module      : Data.Morpheus.Types.SelectionTree+-- Description : A simple interface for Morpheus internal Selection Set's representation.+module Data.Morpheus.Types.SelectionTree where++import Data.Morpheus.Internal.Utils (elems, keyOf)+import Data.Morpheus.Types.Internal.AST.Base (FieldName, VALID)+import Data.Morpheus.Types.Internal.AST.Selection+  ( Selection (..),+    Selection (selectionContent),+    SelectionContent (SelectionField, SelectionSet),+  )++-- | The 'SelectionTree' instance is a simple interface for interacting+-- with morpheus's internal AST while keeping the ability to safely change the concrete+-- representation of the AST.+-- The set of operation is very limited on purpose.+class SelectionTree nodeType where+  -- | leaf test: is the list of children empty?+  isLeaf :: nodeType -> Bool++  -- | Get the children+  getChildrenList :: nodeType -> [nodeType]++  -- | get a node's name+  getName :: nodeType -> FieldName++instance SelectionTree (Selection VALID) where+  isLeaf node = case selectionContent node of+    SelectionField -> True+    _ -> False++  getChildrenList node = case selectionContent node of+    SelectionField -> mempty+    (SelectionSet deeperSel) -> elems deeperSel++  getName = keyOf
+ src/Data/Morpheus/Validation/Document/Validation.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Validation.Document.Validation+  ( validatePartialDocument,+    validateSchema,+  )+where++import Data.Functor (($>))+--+-- Morpheus+import Data.Morpheus.Error.Document.Interface+  ( ImplementsError (..),+    partialImplements,+    unknownInterface,+  )+import Data.Morpheus.Internal.Utils+  ( Selectable (..),+    elems,+  )+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    FieldDefinition (..),+    FieldName (..),+    FieldsDefinition,+    OUT,+    Schema,+    TypeContent (..),+    TypeDefinition (..),+    TypeName,+    TypeRef (..),+    isWeaker,+    lookupWith,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+    Failure (..),+  )++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
+ src/Data/Morpheus/Validation/Internal/Directive.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Validation.Internal.Directive+  ( shouldIncludeSelection,+    validateDirectives,+  )+where++-- MORPHEUS+import Data.Morpheus.Error (errorMessage, globalErrorMessage)+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    selectBy,+    selectOr,+  )+import Data.Morpheus.Schema.Directives (defaultDirectives)+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    Directive (..),+    DirectiveDefinition (..),+    DirectiveLocation (..),+    Directives,+    FieldName,+    RAW,+    ScalarValue (..),+    VALID,+    Value (..),+    msg,+  )+import Data.Morpheus.Types.Internal.Validation+  ( SelectionValidator,+    selectKnown,+    withDirective,+  )+import Data.Morpheus.Validation.Query.Arguments+  ( validateDirectiveArguments,+  )+import Data.Semigroup ((<>))++validateDirective :: DirectiveLocation -> [DirectiveDefinition] -> Directive RAW -> SelectionValidator (Directive VALID)+validateDirective location directiveDefs directive@Directive {directiveArgs, ..} =+  withDirective directive $ do+    directiveDef <- selectKnown directive directiveDefs+    args <- validateDirectiveArguments directiveDef directiveArgs+    validateDirectiveLocation location directive directiveDef+    pure Directive {directiveArgs = args, ..}++validateDirectiveLocation ::+  DirectiveLocation ->+  Directive s ->+  DirectiveDefinition ->+  SelectionValidator ()+validateDirectiveLocation+  loc+  Directive {directiveName, directivePosition}+  DirectiveDefinition {directiveDefinitionLocations}+    | loc `elem` directiveDefinitionLocations = pure ()+    | otherwise =+      failure $+        errorMessage+          directivePosition+          ("Directive " <> msg directiveName <> " may not to be used on " <> msg loc)++validateDirectives :: DirectiveLocation -> Directives RAW -> SelectionValidator (Directives VALID)+validateDirectives location = traverse (validateDirective location defaultDirectives)++directiveFulfilled :: Bool -> FieldName -> Directives s -> SelectionValidator Bool+directiveFulfilled target = selectOr (pure True) (argumentIf target)++shouldIncludeSelection :: Directives VALID -> SelectionValidator Bool+shouldIncludeSelection directives = do+  dontSkip <- directiveFulfilled False "skip" directives+  include <- directiveFulfilled True "include" directives+  pure (dontSkip && include)++argumentIf :: Bool -> Directive s -> SelectionValidator Bool+argumentIf target Directive {directiveName, directiveArgs} =+  selectBy err "if" directiveArgs+    >>= assertArgument target+  where+    err = globalErrorMessage $ "Directive " <> msg ("@" <> directiveName) <> " argument \"if\" of type \"Boolean!\" is required but not provided."++assertArgument :: Bool -> Argument s -> SelectionValidator Bool+assertArgument asserted Argument {argumentValue = Scalar (Boolean actual)} = pure (asserted == actual)+assertArgument _ Argument {argumentValue} = failure $ "Expected type Boolean!, found " <> msg argumentValue <> "."
+ src/Data/Morpheus/Validation/Internal/Value.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Validation.Internal.Value (validateInput) where++import Data.Foldable (traverse_)+import Data.List (elem)+import Data.Maybe (maybe)+-- MORPHEUS++import Data.Morpheus.Error.Input (typeViolation)+import Data.Morpheus.Error.Utils (errorMessage)+import Data.Morpheus.Error.Variable (incompatibleVariableType)+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    elems,+  )+import Data.Morpheus.Types.Internal.AST+  ( DataEnumValue (..),+    FieldDefinition (..),+    IN,+    Message,+    ObjectEntry (..),+    RESOLVED,+    Ref (..),+    ResolvedValue,+    ScalarDefinition (..),+    ScalarValue (..),+    TRUE,+    TypeContent (..),+    TypeDefinition (..),+    TypeName (..),+    TypeRef (..),+    TypeRef (..),+    TypeWrapper (..),+    VALID,+    ValidValue,+    Value (..),+    Variable (..),+    Variable (..),+    VariableContent (..),+    isNullableWrapper,+    isWeaker,+    msg,+    toFieldName,+  )+import Data.Morpheus.Types.Internal.AST.OrderedMap+  ( unsafeFromValues,+  )+import Data.Morpheus.Types.Internal.Validation+  ( InputValidator,+    Prop (..),+    askInputFieldType,+    askInputMember,+    askScopePosition,+    constraintInputUnion,+    inputMessagePrefix,+    selectKnown,+    selectWithDefaultValue,+    withInputScope,+    withScopeType,+  )+import Data.Semigroup ((<>))++castFailure :: TypeRef -> Maybe Message -> ResolvedValue -> InputValidator a+castFailure expected message value = do+  pos <- askScopePosition+  prefix <- inputMessagePrefix+  failure+    $ errorMessage pos+    $ prefix <> typeViolation expected value <> maybe "" (" " <>) message++checkTypeEquality ::+  (TypeName, [TypeWrapper]) ->+  Ref ->+  Variable VALID ->+  InputValidator ValidValue+checkTypeEquality (tyConName, tyWrappers) ref var@Variable {variableValue = ValidVariableValue value, variableType}+  | typeConName variableType == tyConName+      && not+        (isWeaker (typeWrappers variableType) tyWrappers) =+    pure value+  | otherwise =+    failure $+      incompatibleVariableType+        ref+        var+        TypeRef+          { typeConName = tyConName,+            typeWrappers = tyWrappers,+            typeArgs = Nothing+          }++-- Validate Variable Argument or all Possible input Values+validateInput ::+  [TypeWrapper] ->+  TypeDefinition IN ->+  ObjectEntry RESOLVED ->+  InputValidator 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+    -- VALIDATION+    validateWrapped ::+      [TypeWrapper] ->+      TypeContent TRUE IN ->+      ObjectEntry RESOLVED ->+      InputValidator 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+    -- Validate LIST+    validateWrapped (TypeMaybe : wrappers) _ value =+      validateWrapped wrappers tyCont value+    validateWrapped (TypeList : wrappers) _ (ObjectEntry key (List list)) =+      List <$> traverse validateElement list+      where+        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+    {-- 3. THROW ERROR: on invalid values --}+    validateWrapped wrappers _ ObjectEntry {entryValue} = mismatchError wrappers entryValue++validateScalar ::+  TypeName ->+  ScalarDefinition ->+  ResolvedValue ->+  (Maybe Message -> ResolvedValue -> InputValidator ValidValue) ->+  InputValidator ValidValue+validateScalar typeName ScalarDefinition {validateValue} value err = do+  scalarValue <- toScalar value+  case validateValue scalarValue of+    Right _ -> pure scalarValue+    Left "" -> err Nothing value+    Left message -> err (Just $ msg message) value+  where+    toScalar :: ResolvedValue -> InputValidator 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 "Int" = isInt+    isValidDefault _ = const True++isBoolean :: ScalarValue -> Bool+isBoolean Boolean {} = True+isBoolean _ = False++isString :: ScalarValue -> Bool+isString String {} = True+isString _ = False++isFloat :: ScalarValue -> Bool+isFloat Float {} = True+isFloat _ = False++isInt :: ScalarValue -> Bool+isInt Int {} = True+isInt _ = False++validateEnum ::+  (ResolvedValue -> InputValidator ValidValue) ->+  [DataEnumValue] ->+  ResolvedValue ->+  InputValidator ValidValue+validateEnum err enumValues value@(Enum enumValue)+  | enumValue `elem` tags = pure (Enum enumValue)+  | otherwise = err value+  where+    tags = map enumName enumValues+validateEnum err _ value = err value
+ src/Data/Morpheus/Validation/Query/Arguments.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Data.Morpheus.Validation.Query.Arguments+  ( validateDirectiveArguments,+    validateFieldArguments,+  )+where++import Data.Foldable (traverse_)+import Data.Morpheus.Internal.Utils+  ( elems,+    empty,+  )+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    ArgumentDefinition,+    Arguments,+    ArgumentsDefinition (..),+    DirectiveDefinition,+    DirectiveDefinition (..),+    FieldDefinition (..),+    OUT,+    ObjectEntry (..),+    RAW,+    RESOLVED,+    RawValue,+    ResolvedValue,+    TypeRef (..),+    VALID,+    Value (..),+  )+import Data.Morpheus.Types.Internal.Validation+  ( InputSource (..),+    SelectionContext (..),+    SelectionValidator,+    askContext,+    askInputFieldType,+    askScopePosition,+    selectKnown,+    selectRequired,+    selectWithDefaultValue,+    startInput,+    withScopePosition,+  )+import Data.Morpheus.Validation.Internal.Value+  ( validateInput,+  )++-- only Resolves , doesnot checks the types+resolveObject :: RawValue -> SelectionValidator ResolvedValue+resolveObject = resolve+  where+    resolveEntry :: ObjectEntry RAW -> SelectionValidator (ObjectEntry RESOLVED)+    resolveEntry (ObjectEntry name v) = ObjectEntry name <$> resolve v+    ------------------------------------------------+    resolve :: RawValue -> SelectionValidator ResolvedValue+    resolve Null = pure Null+    resolve (Scalar x) = pure $ Scalar x+    resolve (Enum x) = pure $ Enum x+    resolve (List x) = List <$> traverse resolve x+    resolve (Object obj) = Object <$> traverse resolveEntry obj+    resolve (VariableValue ref) =+      variables <$> askContext+        >>= fmap (ResolvedVariable ref)+          . selectRequired ref++resolveArgumentVariables ::+  Arguments RAW ->+  SelectionValidator (Arguments RESOLVED)+resolveArgumentVariables =+  traverse resolveVariable+  where+    resolveVariable :: Argument RAW -> SelectionValidator (Argument RESOLVED)+    resolveVariable (Argument key val position) = do+      constValue <- resolveObject val+      pure $ Argument key constValue position++validateArgument ::+  Arguments RESOLVED ->+  ArgumentDefinition ->+  SelectionValidator (Argument VALID)+validateArgument+  requestArgs+  argumentDef@FieldDefinition+    { fieldName,+      fieldType = TypeRef {typeWrappers}+    } =+    do+      argumentPosition <- askScopePosition+      argument <-+        selectWithDefaultValue+          Argument {argumentName = fieldName, argumentValue = Null, argumentPosition}+          argumentDef+          requestArgs+      validateArgumentValue argument+    where+      -------------------------------------------------------------------------+      validateArgumentValue :: Argument RESOLVED -> SelectionValidator (Argument VALID)+      validateArgumentValue arg@Argument {argumentValue = value, ..} =+        withScopePosition argumentPosition+          $ startInput (SourceArgument arg)+          $ do+            datatype <- askInputFieldType argumentDef+            argumentValue <-+              validateInput+                typeWrappers+                datatype+                (ObjectEntry fieldName value)+            pure Argument {argumentValue, ..}++validateFieldArguments ::+  FieldDefinition OUT ->+  Arguments RAW ->+  SelectionValidator (Arguments VALID)+validateFieldArguments+  fieldDef@FieldDefinition {fieldArgs}+  rawArgs =+    do+      args <- resolveArgumentVariables rawArgs+      traverse_ checkUnknown (elems args)+      traverse (validateArgument args) argsDef+    where+      argsDef = case fieldArgs of+        (ArgumentsDefinition _ argsD) -> argsD+        NoArguments -> empty+      -------------------------------------------------+      checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition+      checkUnknown = (`selectKnown` fieldDef)++validateDirectiveArguments ::+  DirectiveDefinition ->+  Arguments RAW ->+  SelectionValidator (Arguments VALID)+validateDirectiveArguments+  directiveDef@DirectiveDefinition {directiveDefinitionArgs}+  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)
+ src/Data/Morpheus/Validation/Query/Fragment.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Validation.Query.Fragment+  ( validateFragments,+    castFragmentType,+    resolveSpread,+  )+where++import Data.Foldable (traverse_)+-- MORPHEUS+import Data.Morpheus.Error.Fragment+  ( cannotBeSpreadOnType,+    cannotSpreadWithinItself,+  )+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    elems,+    selectOr,+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    Fragment (..),+    Fragments,+    Position,+    RAW,+    Ref (..),+    Selection (..),+    SelectionContent (..),+    SelectionSet,+    TypeName,+    TypeNameRef (..),+  )+import Data.Morpheus.Types.Internal.Validation+  ( BaseValidator,+    Constraint (..),+    Validator,+    askFragments,+    askSchema,+    checkUnused,+    constraint,+    selectKnown,+  )+import Data.Semigroup ((<>))++validateFragments :: SelectionSet RAW -> BaseValidator ()+validateFragments selectionSet =+  fragmentsCycleChecking+    *> checkUnusedFragments selectionSet+    *> fragmentsConditionTypeChecking++checkUnusedFragments :: SelectionSet RAW -> BaseValidator ()+checkUnusedFragments selectionSet = do+  fragments <- askFragments+  checkUnused+    (usedFragments fragments (elems selectionSet))+    (elems fragments)++castFragmentType ::+  Maybe FieldName -> Position -> [TypeName] -> Fragment -> Validator ctx Fragment+castFragmentType key position typeMembers fragment@Fragment {fragmentType}+  | fragmentType `elem` typeMembers = pure fragment+  | otherwise = failure $ cannotBeSpreadOnType key fragmentType position typeMembers++resolveSpread :: [TypeName] -> Ref -> Validator ctx Fragment+resolveSpread allowedTargets ref@Ref {refName, refPosition} =+  askFragments+    >>= selectKnown ref+    >>= castFragmentType (Just refName) refPosition allowedTargets++usedFragments :: Fragments -> [Selection RAW] -> [Node]+usedFragments fragments = concatMap findAllUses+  where+    findUsesSelectionContent :: SelectionContent RAW -> [Node]+    findUsesSelectionContent (SelectionSet selectionSet) =+      concatMap findAllUses selectionSet+    findUsesSelectionContent SelectionField = []+    findAllUses :: Selection RAW -> [Node]+    findAllUses Selection {selectionContent} =+      findUsesSelectionContent selectionContent+    findAllUses (InlineFragment Fragment {fragmentSelection}) =+      concatMap findAllUses fragmentSelection+    findAllUses (Spread _ Ref {refName, refPosition}) =+      [Ref refName refPosition] <> searchInFragment+      where+        searchInFragment =+          selectOr+            []+            (concatMap findAllUses . fragmentSelection)+            refName+            fragments++fragmentsConditionTypeChecking :: BaseValidator ()+fragmentsConditionTypeChecking =+  elems <$> askFragments+    >>= traverse_ checkTypeExistence++checkTypeExistence :: Fragment -> BaseValidator ()+checkTypeExistence fr@Fragment {fragmentType, fragmentPosition} =+  askSchema+    >>= selectKnown (TypeNameRef fragmentType fragmentPosition)+    >>= constraint OBJECT fr+    >> pure ()++fragmentsCycleChecking :: BaseValidator ()+fragmentsCycleChecking = exploreSpreads >>= fragmentCycleChecking++exploreSpreads :: BaseValidator Graph+exploreSpreads = map exploreFragmentSpreads . elems <$> askFragments++exploreFragmentSpreads :: Fragment -> NodeEdges+exploreFragmentSpreads Fragment {fragmentName, fragmentSelection, fragmentPosition} =+  (Ref fragmentName fragmentPosition, concatMap scanForSpread fragmentSelection)++scanForSpreadContent :: SelectionContent RAW -> [Node]+scanForSpreadContent SelectionField = []+scanForSpreadContent (SelectionSet selectionSet) =+  concatMap scanForSpread selectionSet++scanForSpread :: Selection RAW -> [Node]+scanForSpread Selection {selectionContent} =+  scanForSpreadContent selectionContent+scanForSpread (InlineFragment Fragment {fragmentSelection}) =+  concatMap scanForSpread fragmentSelection+scanForSpread (Spread _ Ref {refName, refPosition}) =+  [Ref refName refPosition]++type Node = Ref++type NodeEdges = (Node, [Node])++type Graph = [NodeEdges]++fragmentCycleChecking :: Graph -> BaseValidator ()+fragmentCycleChecking lib = traverse_ checkFragment lib+  where+    checkFragment (fragmentID, _) = checkForCycle lib fragmentID [fragmentID]++checkForCycle :: Graph -> Node -> [Node] -> BaseValidator Graph+checkForCycle lib parentNode history = case lookup parentNode lib of+  Just node -> concat <$> traverse checkNode node+  Nothing -> pure []+  where+    checkNode x = if x `elem` history then cycleError x else recurse x+    recurse node = checkForCycle lib node $ history ++ [node]+    cycleError n = failure $ cannotSpreadWithinItself (n : history)
+ src/Data/Morpheus/Validation/Query/Selection.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Validation.Query.Selection+  ( validateOperation,+  )+where++-- MORPHEUS+import Data.Morpheus.Error.Selection+  ( hasNoSubfields,+    subfieldsNotSelected,+  )+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    elems,+    empty,+    keyOf,+    singleton,+  )+import Data.Morpheus.Types.Internal.AST+  ( Arguments,+    DirectiveLocation (FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT, MUTATION, QUERY, SUBSCRIPTION),+    Directives,+    FieldDefinition,+    FieldName,+    FieldsDefinition,+    Fragment (..),+    GQLError (..),+    OUT,+    Operation (..),+    OperationType (..),+    RAW,+    Ref (..),+    Selection (..),+    SelectionContent (..),+    SelectionSet,+    TRUE,+    TypeContent (..),+    TypeDefinition (..),+    TypeName,+    VALID,+    getOperationDataType,+    isEntNode,+    msg,+  )+import Data.Morpheus.Types.Internal.AST.MergeSet+  ( concatTraverse,+  )+import Data.Morpheus.Types.Internal.Validation+  ( SelectionValidator,+    askFieldType,+    askSchema,+    selectKnown,+    withScope,+  )+import Data.Morpheus.Validation.Internal.Directive+  ( shouldIncludeSelection,+    validateDirectives,+  )+import Data.Morpheus.Validation.Query.Arguments+  ( validateFieldArguments,+  )+import Data.Morpheus.Validation.Query.Fragment+  ( castFragmentType,+    resolveSpread,+  )+import Data.Morpheus.Validation.Query.UnionSelection+  ( validateUnionSelection,+  )+import Data.Semigroup ((<>))++type TypeDef = (TypeName, FieldsDefinition OUT)++getOperationObject ::+  Operation a -> SelectionValidator (TypeName, FieldsDefinition OUT)+getOperationObject operation = do+  dt <- askSchema >>= getOperationDataType operation+  case dt of+    TypeDefinition {typeContent = DataObject {objectFields}, typeName} -> pure (typeName, objectFields)+    TypeDefinition {typeName} ->+      failure $+        "Type Mismatch: operation \""+          <> msg typeName+          <> "\" must be an Object"++selectionsWitoutTypename :: SelectionSet VALID -> [Selection VALID]+selectionsWitoutTypename = filter (("__typename" /=) . keyOf) . elems++singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator ()+singleTopLevelSelection Operation {operationType = Subscription, operationName} selSet =+  case selectionsWitoutTypename selSet of+    (_ : xs) | not (null xs) -> failure $ map (singleTopLevelSelectionError operationName) xs+    _ -> pure ()+singleTopLevelSelection _ _ = pure ()++singleTopLevelSelectionError :: Maybe FieldName -> Selection VALID -> GQLError+singleTopLevelSelectionError name Selection {selectionPosition} =+  GQLError+    { message =+        subscriptionName+          <> " must select "+          <> "only one top level field.",+      locations = [selectionPosition]+    }+  where+    subscriptionName = maybe "Anonymous Subscription" (("Subscription " <>) . msg) name++validateOperation ::+  Operation RAW ->+  SelectionValidator (Operation VALID)+validateOperation+  rawOperation@Operation+    { operationName,+      operationType,+      operationSelection,+      operationDirectives,+      ..+    } =+    do+      typeDef <- getOperationObject rawOperation+      selection <- validateSelectionSet typeDef operationSelection+      singleTopLevelSelection rawOperation selection+      directives <-+        validateDirectives+          (toDirectiveLocation operationType)+          operationDirectives+      pure $+        Operation+          { operationName,+            operationType,+            operationArguments = empty,+            operationSelection = selection,+            operationDirectives = directives,+            ..+          }++toDirectiveLocation :: OperationType -> DirectiveLocation+toDirectiveLocation Subscription = SUBSCRIPTION+toDirectiveLocation Mutation = MUTATION+toDirectiveLocation Query = QUERY++processSelectionDirectives ::+  DirectiveLocation ->+  Directives RAW ->+  (Directives VALID -> SelectionValidator (SelectionSet VALID)) ->+  SelectionValidator (SelectionSet VALID)+processSelectionDirectives location rawDirectives sel = do+  directives <- validateDirectives location rawDirectives+  include <- shouldIncludeSelection directives+  selection <- sel directives+  pure $+    if include+      then selection+      else empty++validateSelectionSet ::+  TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)+validateSelectionSet dataType@(typeName, fieldsDef) =+  concatTraverse validateSelection+  where+    -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet+    validateSelection :: Selection RAW -> SelectionValidator (SelectionSet VALID)+    validateSelection+      sel@Selection+        { selectionName,+          selectionArguments,+          selectionContent,+          selectionPosition,+          selectionDirectives+        } =+        withScope+          typeName+          currentSelectionRef+          $ processSelectionDirectives+            FIELD+            selectionDirectives+            (`validateSelectionContent` selectionContent)+        where+          currentSelectionRef = Ref selectionName selectionPosition+          commonValidation :: SelectionValidator (TypeDefinition OUT, Arguments VALID)+          commonValidation = do+            (fieldDef :: FieldDefinition OUT) <- selectKnown (Ref selectionName selectionPosition) fieldsDef+            -- validate field Argument -----+            arguments <-+              validateFieldArguments+                fieldDef+                selectionArguments+            -- check field Type existence  -----+            (typeDef :: TypeDefinition OUT) <- askFieldType fieldDef+            pure (typeDef, arguments)+          -----------------------------------------------------------------------------------+          validateSelectionContent :: Directives VALID -> SelectionContent RAW -> SelectionValidator (SelectionSet VALID)+          validateSelectionContent directives SelectionField+            | null selectionArguments && selectionName == "__typename" =+              pure $ singleton $+                sel+                  { selectionArguments = empty,+                    selectionDirectives = directives,+                    selectionContent = SelectionField+                  }+            | otherwise = do+              (datatype, validArgs) <- commonValidation+              isLeaf datatype+              pure $ singleton $+                sel+                  { selectionArguments = validArgs,+                    selectionDirectives = directives,+                    selectionContent = SelectionField+                  }+            where+              ------------------------------------------------------------+              isLeaf :: TypeDefinition OUT -> SelectionValidator ()+              isLeaf TypeDefinition {typeName = typename, typeContent}+                | isEntNode typeContent = pure ()+                | otherwise =+                  failure $+                    subfieldsNotSelected selectionName typename selectionPosition+          ----- SelectionSet+          validateSelectionContent directives (SelectionSet rawSelectionSet) =+            do+              (TypeDefinition {typeName = name, typeContent}, validArgs) <- commonValidation+              selContent <- withScope name currentSelectionRef $ validateByTypeContent name typeContent+              pure $ singleton $+                sel+                  { selectionArguments = validArgs,+                    selectionDirectives = directives,+                    selectionContent = selContent+                  }+            where+              validateByTypeContent :: TypeName -> TypeContent TRUE OUT -> SelectionValidator (SelectionContent VALID)+              -- Validate UnionSelection+              validateByTypeContent _ DataUnion {unionMembers} =+                validateUnionSelection+                  validateSelectionSet+                  rawSelectionSet+                  unionMembers+              -- Validate Regular selection set+              validateByTypeContent typename DataObject {objectFields} =+                SelectionSet+                  <$> validateSelectionSet+                    (typename, objectFields)+                    rawSelectionSet+              validateByTypeContent typename DataInterface {interfaceFields} =+                SelectionSet+                  <$> validateSelectionSet+                    (typename, interfaceFields)+                    rawSelectionSet+              validateByTypeContent typename _ =+                failure $+                  hasNoSubfields+                    (Ref selectionName selectionPosition)+                    typename+    validateSelection (Spread dirs ref) =+      processSelectionDirectives FRAGMENT_SPREAD dirs+        $ const+        -- TODO: add directives to selection+        $ resolveSpread [typeName] ref+          >>= validateFragment+    validateSelection+      ( InlineFragment+          fragment@Fragment+            { fragmentDirectives,+              fragmentPosition+            }+        ) =+        processSelectionDirectives INLINE_FRAGMENT fragmentDirectives+          $ const+          -- TODO: add directives to selection+          $ castFragmentType Nothing fragmentPosition [typeName] fragment+            >>= validateFragment+    --------------------------------------------------------------------------------+    validateFragment Fragment {fragmentSelection} = validateSelectionSet dataType fragmentSelection
+ src/Data/Morpheus/Validation/Query/UnionSelection.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Validation.Query.UnionSelection+  ( validateUnionSelection,+  )+where++import Control.Monad ((>=>))+-- MORPHEUS+import Data.Morpheus.Error.Selection (unknownSelectionField)+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    elems,+    empty,+    fromElems,+    selectOr,+    singleton,+  )+import Data.Morpheus.Types.Internal.AST+  ( DataUnion,+    FieldsDefinition,+    Fragment (..),+    OUT,+    RAW,+    Ref (..),+    Selection (..),+    SelectionContent (..),+    SelectionSet,+    SelectionSet,+    TypeName,+    UnionTag (..),+    VALID,+  )+import qualified Data.Morpheus.Types.Internal.AST.MergeSet as MS+  ( join,+  )+import Data.Morpheus.Types.Internal.Validation+  ( SelectionValidator,+    askScopeTypeName,+    askTypeMember,+  )+import Data.Morpheus.Validation.Query.Fragment+  ( castFragmentType,+    resolveSpread,+  )++type TypeDef = (TypeName, FieldsDefinition OUT)++-- returns all Fragments used in Union+exploreUnionFragments ::+  [TypeName] ->+  Selection RAW ->+  SelectionValidator [Fragment]+exploreUnionFragments unionTags = splitFrag+  where+    packFragment fragment = [fragment]+    splitFrag ::+      Selection RAW -> SelectionValidator [Fragment]+    splitFrag (Spread _ ref) = packFragment <$> resolveSpread unionTags ref+    splitFrag Selection {selectionName = "__typename", selectionContent = SelectionField} = pure []+    splitFrag Selection {selectionName, selectionPosition} = do+      typeName <- askScopeTypeName+      failure $ unknownSelectionField typeName (Ref selectionName selectionPosition)+    splitFrag (InlineFragment fragment) =+      packFragment+        <$> castFragmentType Nothing (fragmentPosition fragment) unionTags fragment++-- sorts Fragment by contitional Types+-- [+--   ( Type for Tag User , [ Fragment for User] )+--   ( Type for Tag Product , [ Fragment for Product] )+-- ]+tagUnionFragments ::+  [TypeDef] -> [Fragment] -> [(TypeDef, [Fragment])]+tagUnionFragments types fragments =+  filter notEmpty $+    map categorizeType types+  where+    notEmpty = not . null . snd+    categorizeType :: (TypeName, FieldsDefinition OUT) -> (TypeDef, [Fragment])+    categorizeType datatype = (datatype, filter matches fragments)+      where+        matches fragment = fragmentType fragment == fst datatype++{-+    - all Variable and Fragment references will be: resolved and validated+    - unionTypes: will be clustered under type names+      ...A on T1 {<SelectionA>}+      ...B on T2 {<SelectionB>}+      ...C on T2 {<SelectionC>}+      will be become : [+          UnionTag "T1" {<SelectionA>},+          UnionTag "T2" {<SelectionB>,<SelectionC>}+      ]+ -}+validateCluster ::+  (TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)) ->+  SelectionSet RAW ->+  [(TypeDef, [Fragment])] ->+  SelectionValidator (SelectionContent VALID)+validateCluster validator __typename = traverse _validateCluster >=> fmap UnionSelection . fromElems+  where+    _validateCluster :: (TypeDef, [Fragment]) -> SelectionValidator UnionTag+    _validateCluster (unionType, fragmets) = do+      fragmentSelections <- MS.join (__typename : map fragmentSelection fragmets)+      UnionTag (fst unionType) <$> validator unionType fragmentSelections++validateUnionSelection ::+  (TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)) ->+  SelectionSet RAW ->+  DataUnion ->+  SelectionValidator (SelectionContent VALID)+validateUnionSelection validate selectionSet members = do+  let (__typename :: SelectionSet RAW) = selectOr empty singleton "__typename" selectionSet+  -- get union Types defined in GraphQL schema -> (union Tag, union Selection set)+  -- [("User", FieldsDefinition { ... }), ("Product", FieldsDefinition { ...+  unionTypes <- traverse askTypeMember members+  -- find all Fragments used in Selection+  spreads <- concat <$> traverse (exploreUnionFragments members) (elems selectionSet)+  let categories = tagUnionFragments unionTypes spreads+  validateCluster validate __typename categories
+ src/Data/Morpheus/Validation/Query/Validation.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Validation.Query.Validation+  ( validateRequest,+  )+where++import Data.HashMap.Lazy (fromList)+import Data.Morpheus.Types.Internal.AST+  ( GQLQuery (..),+    Operation (..),+    Schema (..),+    VALID,+    VALIDATION_MODE,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+  )+import Data.Morpheus.Types.Internal.Validation+  ( Context (..),+    ScopeKind (..),+    SelectionContext (..),+    runValidator,+  )+import Data.Morpheus.Validation.Query.Fragment+  ( validateFragments,+  )+import Data.Morpheus.Validation.Query.Selection+  ( validateOperation,+  )+import Data.Morpheus.Validation.Query.Variable+  ( resolveOperationVariables,+  )++validateRequest ::+  Schema ->+  VALIDATION_MODE ->+  GQLQuery ->+  Eventless (Operation VALID)+validateRequest+  schema+  validationMode+  GQLQuery+    { fragments,+      inputVariables,+      operation =+        operation@Operation+          { operationName,+            operationSelection,+            operationPosition+          }+    } =+    do+      variables <- runValidator validateHelpers ctx ()+      runValidator+        (validateOperation operation)+        ctx+        SelectionContext+          { variables+          }+    where+      ctx =+        Context+          { schema,+            fragments,+            scopeTypeName = "Root",+            scopeSelectionName = "Root",+            scopePosition = operationPosition,+            operationName,+            scopeKind = SELECTION+          }+      validateHelpers =+        validateFragments operationSelection+          *> resolveOperationVariables+            (fromList inputVariables)+            validationMode+            operation
+ src/Data/Morpheus/Validation/Query/Variable.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Validation.Query.Variable+  ( resolveOperationVariables,+  )+where++import qualified Data.HashMap.Lazy as M+  ( lookup,+  )+import Data.Maybe (maybe)+--- MORPHEUS+import Data.Morpheus.Error.Variable (uninitializedVariable)+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    elems,+  )+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    DefaultValue,+    Directive (..),+    Fragment (..),+    IN,+    ObjectEntry (..),+    Operation (..),+    RAW,+    RawValue,+    Ref (..),+    ResolvedValue,+    Selection (..),+    SelectionContent (..),+    SelectionSet,+    TypeDefinition,+    TypeNameRef (..),+    TypeRef (..),+    VALID,+    VALIDATION_MODE (..),+    ValidValue,+    Value (..),+    Variable (..),+    VariableContent (..),+    VariableDefinitions,+    Variables,+    isNullable,+  )+import Data.Morpheus.Types.Internal.Validation+  ( BaseValidator,+    Constraint (..),+    InputSource (..),+    askFragments,+    askSchema,+    checkUnused,+    constraint,+    selectKnown,+    startInput,+    withScopePosition,+  )+import Data.Morpheus.Validation.Internal.Value+  ( validateInput,+  )+import Data.Semigroup ((<>))++class ExploreRefs a where+  exploreRefs :: a -> [Ref]++instance ExploreRefs RawValue where+  exploreRefs (VariableValue ref) = [ref]+  exploreRefs (Object fields) = concatMap (exploreRefs . entryValue) fields+  exploreRefs (List ls) = concatMap exploreRefs ls+  exploreRefs _ = []++instance ExploreRefs (Directive RAW) where+  exploreRefs Directive {directiveArgs} = concatMap exploreRefs directiveArgs++instance ExploreRefs (Argument RAW) where+  exploreRefs = exploreRefs . argumentValue++mapSelection :: (Selection RAW -> BaseValidator [b]) -> SelectionSet RAW -> BaseValidator [b]+mapSelection f = fmap concat . traverse f++allVariableRefs :: [SelectionSet RAW] -> BaseValidator [Ref]+allVariableRefs = fmap concat . traverse (mapSelection searchRefs)+  where+    exploreSelectionContent :: SelectionContent RAW -> BaseValidator [Ref]+    exploreSelectionContent SelectionField = pure []+    exploreSelectionContent (SelectionSet selSet) = mapSelection searchRefs selSet+    ---------------------------------------+    searchRefs :: Selection RAW -> BaseValidator [Ref]+    searchRefs Selection {selectionArguments, selectionDirectives, selectionContent} = do+      let directiveRefs = concatMap exploreRefs selectionDirectives+      contentRefs <- exploreSelectionContent selectionContent+      pure $ directiveRefs <> contentRefs <> concatMap exploreRefs selectionArguments+    searchRefs (InlineFragment Fragment {fragmentSelection, fragmentDirectives}) =+      (concatMap exploreRefs fragmentDirectives <>)+        <$> mapSelection searchRefs fragmentSelection+    searchRefs (Spread directives reference) =+      (concatMap exploreRefs directives <>)+        <$> ( askFragments+                >>= selectKnown reference+                >>= mapSelection searchRefs+                . fragmentSelection+            )++resolveOperationVariables ::+  Variables ->+  VALIDATION_MODE ->+  Operation RAW ->+  BaseValidator (VariableDefinitions VALID)+resolveOperationVariables+  root+  validationMode+  Operation+    { operationSelection,+      operationArguments+    } =+    checkUnusedVariables+      *> traverse (lookupAndValidateValueOnBody root validationMode) operationArguments+    where+      checkUnusedVariables :: BaseValidator ()+      checkUnusedVariables = do+        uses <- allVariableRefs [operationSelection]+        checkUnused uses (elems operationArguments)++lookupAndValidateValueOnBody ::+  Variables ->+  VALIDATION_MODE ->+  Variable RAW ->+  BaseValidator (Variable VALID)+lookupAndValidateValueOnBody+  bodyVariables+  validationMode+  var@Variable+    { variableName,+      variableType,+      variablePosition,+      variableValue = DefaultValue defaultValue+    } =+    withScopePosition variablePosition $+      toVariable+        <$> ( askSchema+                >>= selectKnown (TypeNameRef (typeConName variableType) variablePosition)+                >>= constraint INPUT var+                >>= checkType getVariable defaultValue+            )+    where+      toVariable x = var {variableValue = ValidVariableValue x}+      getVariable :: Maybe ResolvedValue+      getVariable = M.lookup variableName bodyVariables+      ------------------------------------------------------------------+      -- checkType ::+      checkType ::+        Maybe ResolvedValue ->+        DefaultValue ->+        TypeDefinition IN ->+        BaseValidator ValidValue+      checkType (Just variable) Nothing varType = validator varType variable+      checkType (Just variable) (Just defValue) varType =+        validator varType defValue >> validator varType variable+      checkType Nothing (Just defValue) varType = validator varType defValue+      checkType Nothing Nothing varType+        | validationMode /= WITHOUT_VARIABLES && not (isNullable variableType) =+          failure $ uninitializedVariable var+        | otherwise =+          returnNull+        where+          returnNull =+            maybe (pure Null) (validator varType) (M.lookup variableName bodyVariables)+      -----------------------------------------------------------------------------------------------+      validator :: TypeDefinition IN -> ResolvedValue -> BaseValidator ValidValue+      validator varType varValue =+        startInput (SourceVariable var) $+          validateInput+            (typeWrappers variableType)+            varType+            (ObjectEntry variableName varValue)
+ test/Lib.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module Lib+  ( getGQLBody,+    getResponseBody,+    getCases,+    maybeVariables,+    readSource,+  )+where++import Control.Applicative ((<|>))+import Data.Aeson (FromJSON, Value (..), decode)+import qualified Data.ByteString.Lazy as L (readFile)+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Maybe (fromMaybe)+import Data.Morpheus.Types.Internal.AST (FieldName (..))+import Data.Text (Text, unpack)++readSource :: FieldName -> IO ByteString+readSource = L.readFile . path . readName++path :: Text -> String+path name = "test/" ++ unpack name++gqlLib :: Text -> String+gqlLib x = path x ++ "/query.gql"++resLib :: Text -> String+resLib x = path x ++ "/response.json"++maybeVariables :: FieldName -> IO (Maybe Value)+maybeVariables (FieldName x) = decode <$> (L.readFile (path x ++ "/variables.json") <|> return "{}")++getGQLBody :: FieldName -> IO ByteString+getGQLBody (FieldName p) = L.readFile (gqlLib p)++getCases :: FromJSON a => String -> IO [a]+getCases dir = fromMaybe [] . decode <$> L.readFile ("test/" ++ dir ++ "/cases.json")++getResponseBody :: FieldName -> IO Value+getResponseBody (FieldName p) = fromMaybe Null . decode <$> L.readFile (resLib p)
+ test/Schema.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Schema+  ( testSchema,+  )+where++import Control.Monad ((<=<))+import Data.Aeson ((.:), (.=), FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, object)+import qualified Data.ByteString.Lazy.Char8 as LB (unpack)+import Data.Either (either)+import Data.Morpheus.Core (parseFullGQLDocument, validateSchema)+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    GQLErrors,+    Schema,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+    Result (..),+  )+import Data.Semigroup ((<>))+import Data.Text (pack)+import GHC.Generics (Generic)+import Lib (readSource)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase)++readSchema :: FieldName -> IO (Eventless Schema)+readSchema = fmap (validateSchema <=< parseFullGQLDocument) . readSource . ("schema/" <>) . (<> "/schema.gql")++readResponse :: FieldName -> IO Response+readResponse = fmap (either AesonError id . eitherDecode) . readSource . ("schema/" <>) . (<> "/response.json")++data Response+  = OK+  | Errors {errors :: GQLErrors}+  | AesonError String+  deriving (Generic)++instance FromJSON Response where+  parseJSON (Object v) =+    Errors <$> v .: "errors"+  parseJSON (String "OK") = pure OK+  parseJSON v = pure $ AesonError (show v)++instance ToJSON Response where+  toJSON OK = String "OK"+  toJSON (Errors err) = object ["errors" .= toJSON err]+  toJSON (AesonError err) = String (pack err)++testSchema :: TestTree+testSchema =+  testGroup+    "Test Schema"+    [ testGroup+        "Validation"+        $ map+          (uncurry schemaCase)+          [ ("validation/interface/ok", "interface validation success"),+            ("validation/interface/fail", "interface validation fails")+          ]+    ]++schemaCase :: FieldName -> String -> TestTree+schemaCase path description = testCase description $ do+  schema <- readSchema path+  expected <- readResponse path+  assertion expected schema++assertion :: Response -> Eventless Schema -> IO ()+assertion OK Success {} = return ()+assertion Errors {errors = err} Failure {errors}+  | err == errors =+    pure+      ()+assertion expected Success {} =+  assertFailure $+    LB.unpack+      ("expected: \n " <> encode expected <> " \n but got: \n OK")+assertion expected Failure {errors} =+  assertFailure $+    LB.unpack+      ("expected: \n " <> encode expected <> " \n but got: \n " <> encode (Errors errors))
+ test/Spec.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Main+  ( main,+  )+where++import qualified Data.Aeson as A+import Data.Aeson (decode, encode)+import Data.Functor.Identity (Identity (..))+import Data.Morpheus.Core (runApi)+import Data.Morpheus.Internal.Utils+  ( fromElems,+  )+import Data.Morpheus.QuasiQuoter (dsl)+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    Schema,+    VALID,+    Value (..),+    msg,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( ResModel,+    Resolver,+    ResponseStream,+    Result (..),+    ResultT (..),+    RootResModel (..),+    WithOperation,+    mkList,+    mkNull,+    mkObject,+    mkString,+  )+import Data.Semigroup ((<>))+import qualified Data.Text.Lazy as LT (toStrict)+import Data.Text.Lazy.Encoding (decodeUtf8)+import Lib+  ( getGQLBody,+    getResponseBody,+    maybeVariables,+  )+import Schema+  ( testSchema,+  )+import Test.Tasty+  ( TestTree,+    defaultMain,+    testGroup,+  )+import Test.Tasty.HUnit+  ( assertFailure,+    testCase,+  )++getSchema :: Monad m => ResponseStream e m Schema+getSchema =+  fromElems+    [dsl|+  +  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!]!+  }+|]++resolver :: Monad m => RootResModel e m+resolver =+  RootResModel+    { query =+        pure $+          mkObject+            "Query"+            [("deity", resolveDeity)],+      mutation = pure mkNull,+      subscription = pure mkNull+    }++resolveDeity :: (WithOperation o, Monad m) => Resolver o e m (ResModel o e m)+resolveDeity =+  pure $+    mkObject+      "Deity"+      [ ("name", pure $ mkString "Morpheus"),+        ("power", pure $ mkList [mkString "Shapeshifting"])+      ]++main :: IO ()+main =+  defaultMain+    $ testGroup+      "core tests"+    $ map+      (uncurry basicTest)+      [ ("basic Test", "simple"),+        ("test interface", "interface")+      ]+      <> [testSchema]++basicTest :: String -> FieldName -> TestTree+basicTest description path = testCase description $ do+  actual <- simpleTest <$> getRequest path+  expected <- expectedResponse path+  assertion expected actual++simpleTest :: GQLRequest -> ResponseStream e Identity (Value VALID)+simpleTest request = do+  schema <- getSchema+  runApi schema resolver request++expectedResponse :: FieldName -> IO A.Value+expectedResponse = getResponseBody++assertion :: A.Value -> ResponseStream e Identity (Value VALID) -> IO ()+assertion expected (ResultT (Identity Success {result}))+  | Just expected == decode (encode result) = return ()+  | otherwise =+    assertFailure $ show ("expected: \n " <> msg expected <> " \n but got: \n " <> msg result)+assertion _ (ResultT (Identity Failure {errors})) = assertFailure (show errors)++getRequest :: FieldName -> IO GQLRequest+getRequest path = do+  queryBS <- LT.toStrict . decodeUtf8 <$> getGQLBody path+  variables <- maybeVariables path+  pure $+    GQLRequest+      { operationName = Nothing,+        query = queryBS,+        variables+      }
+ test/interface/query.gql view
@@ -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+              }+            }+          }+        }+      }+    }+  }+}
+ test/interface/response.json view
@@ -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+  }+}
+ test/schema/validation/interface/fail/response.json view
@@ -0,0 +1,16 @@+{+  "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": []+    }+  ]+}
+ test/schema/validation/interface/fail/schema.gql view
@@ -0,0 +1,33 @@+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+# }
+ test/schema/validation/interface/ok/response.json view
@@ -0,0 +1,1 @@+"OK"
+ test/schema/validation/interface/ok/schema.gql view
@@ -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!]!+}
+ test/simple/query.gql view
@@ -0,0 +1,6 @@+{+  deity {+    name+    power+  }+}
+ test/simple/response.json view
@@ -0,0 +1,6 @@+{+  "deity": {+    "name": "Morpheus",+    "power": ["Shapeshifting"]+  }+}