morpheus-graphql-core 0.15.1 → 0.16.0

raw patch · 131 files changed

+41184/−2230 lines, 131 filesdep +reludePVP ok

version bump matches the API change (PVP)

Dependencies added: relude

API changes (from Hackage documentation)

Files

• changelog.md +23/−0
• morpheus-graphql-core.cabal +54/−6
• src/Data/Morpheus/Core.hs +12/−12
• src/Data/Morpheus/Error.hs +2/−2
• src/Data/Morpheus/Error/Fragment.hs +5/−8
• src/Data/Morpheus/Error/NameCollision.hs +5/−0
• src/Data/Morpheus/Error/Schema.hs +0/−25
• src/Data/Morpheus/Error/Utils.hs +1/−3
• src/Data/Morpheus/Error/Variable.hs +1/−2
• src/Data/Morpheus/Error/Warning.hs +2/−15
• src/Data/Morpheus/Ext/Elems.hs +25/−0
• src/Data/Morpheus/Ext/Failure.hs +21/−0
• src/Data/Morpheus/Ext/KeyOf.hs +38/−0
• src/Data/Morpheus/Ext/Map.hs +104/−0
• src/Data/Morpheus/Ext/MergeSet.hs +106/−0
• src/Data/Morpheus/Ext/OrdMap.hs +92/−0
• src/Data/Morpheus/Ext/SafeHashMap.hs +81/−0
• src/Data/Morpheus/Ext/SemigroupM.hs +82/−0
• src/Data/Morpheus/Internal/Graph.hs +10/−19
• src/Data/Morpheus/Internal/TH.hs +6/−111
• src/Data/Morpheus/Internal/Utils.hs +60/−254
• src/Data/Morpheus/Parser.hs +12/−5
• src/Data/Morpheus/Parsing/Document/TypeSystem.hs +110/−128
• src/Data/Morpheus/Parsing/Internal/Arguments.hs +8/−7
• src/Data/Morpheus/Parsing/Internal/Internal.hs +30/−22
• src/Data/Morpheus/Parsing/Internal/Pattern.hs +57/−47
• src/Data/Morpheus/Parsing/Internal/Terms.hs +138/−106
• src/Data/Morpheus/Parsing/Internal/Value.hs +19/−35
• src/Data/Morpheus/Parsing/Request/Operation.hs +21/−20
• src/Data/Morpheus/Parsing/Request/Parser.hs +18/−8
• src/Data/Morpheus/Parsing/Request/Selection.hs +12/−12
• src/Data/Morpheus/QuasiQuoter.hs +18/−10
• src/Data/Morpheus/Rendering/RenderGQL.hs +60/−32
• src/Data/Morpheus/Rendering/RenderIntrospection.hs +5/−19
• src/Data/Morpheus/Schema/DSL.hs +8/−7
• src/Data/Morpheus/Schema/Schema.hs +3/−18
• src/Data/Morpheus/Schema/SchemaAPI.hs +5/−4
• src/Data/Morpheus/Types/App.hs +5/−17
• src/Data/Morpheus/Types/GQLScalar.hs +2/−14
• src/Data/Morpheus/Types/ID.hs +2/−12
• src/Data/Morpheus/Types/IO.hs +7/−17
• src/Data/Morpheus/Types/Internal/AST.hs +5/−17
• src/Data/Morpheus/Types/Internal/AST/Base.hs +18/−38
• src/Data/Morpheus/Types/Internal/AST/DirectiveLocation.hs +2/−1
• src/Data/Morpheus/Types/Internal/AST/Fields.hs +56/−68
• src/Data/Morpheus/Types/Internal/AST/MergeSet.hs +0/−152
• src/Data/Morpheus/Types/Internal/AST/OrdMap.hs +0/−100
• src/Data/Morpheus/Types/Internal/AST/SafeHashMap.hs +0/−91
• src/Data/Morpheus/Types/Internal/AST/Selection.hs +46/−48
• src/Data/Morpheus/Types/Internal/AST/TH.hs +1/−8
• src/Data/Morpheus/Types/Internal/AST/TypeCategory.hs +1/−2
• src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs +50/−52
• src/Data/Morpheus/Types/Internal/AST/Value.hs +27/−50
• src/Data/Morpheus/Types/Internal/Config.hs +1/−5
• src/Data/Morpheus/Types/Internal/Resolving.hs +4/−16
• src/Data/Morpheus/Types/Internal/Resolving/Core.hs +7/−10
• src/Data/Morpheus/Types/Internal/Resolving/Event.hs +14/−21
• src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +19/−56
• src/Data/Morpheus/Types/Internal/Resolving/ResolverState.hs +11/−24
• src/Data/Morpheus/Types/Internal/Stitching.hs +14/−25
• src/Data/Morpheus/Types/Internal/Validation.hs +3/−20
• src/Data/Morpheus/Types/Internal/Validation/Error.hs +1/−4
• src/Data/Morpheus/Types/Internal/Validation/Internal.hs +1/−14
• src/Data/Morpheus/Types/Internal/Validation/SchemaValidator.hs +1/−14
• src/Data/Morpheus/Types/Internal/Validation/Validator.hs +9/−28
• src/Data/Morpheus/Types/SelectionTree.hs +1/−7
• src/Data/Morpheus/Validation/Document/Validation.hs +29/−46
• src/Data/Morpheus/Validation/Internal/Arguments.hs +8/−17
• src/Data/Morpheus/Validation/Internal/Directive.hs +2/−16
• src/Data/Morpheus/Validation/Internal/Value.hs +10/−31
• src/Data/Morpheus/Validation/Query/Fragment.hs +1/−11
• src/Data/Morpheus/Validation/Query/FragmentPreconditions.hs +1/−9
• src/Data/Morpheus/Validation/Query/Selection.hs +4/−18
• src/Data/Morpheus/Validation/Query/UnionSelection.hs +10/−11
• src/Data/Morpheus/Validation/Query/Validation.hs +5/−0
• src/Data/Morpheus/Validation/Query/Variable.hs +6/−24
• test/Spec.hs +24/−4
• test/Utils/Api.hs +4/−18
• test/Utils/MergeSchema.hs +5/−26
• test/Utils/Rendering.hs +73/−0
• test/Utils/Schema.hs +7/−24
• test/Utils/Utils.hs +21/−32
• test/rendering/simple/directive/query.gql +5/−0
• test/rendering/simple/directive/rendering.gql +5/−0
• test/rendering/simple/fragment/query.gql +12/−0
• test/rendering/simple/fragment/rendering.gql +17/−0
• test/rendering/simple/fragment/variables.json +3/−0
• test/rendering/simple/mutation/query.gql +9/−0
• test/rendering/simple/mutation/rendering.gql +9/−0
• test/rendering/simple/nested/query.gql +22/−0
• test/rendering/simple/nested/rendering.gql +22/−0
• test/rendering/simple/query/query.gql +9/−0
• test/rendering/simple/query/rendering.gql +9/−0
• test/rendering/simple/schema.gql +17/−0
• test/rendering/simple/simple/query.gql +9/−0
• test/rendering/simple/simple/rendering.gql +9/−0
• test/rendering/simple/subscription/query.gql +9/−0
• test/rendering/simple/subscription/rendering.gql +9/−0
• test/rendering/union/interface/query.gql +12/−0
• test/rendering/union/interface/rendering.gql +17/−0
• test/rendering/union/interface/variables.json +3/−0
• test/rendering/union/schema.gql +46/−0
• test/rendering/union/union/query.gql +14/−0
• test/rendering/union/union/rendering.gql +10/−0
• test/rendering/union/union/variables.json +3/−0
• test/rendering/variable/enum/query.gql +6/−0
• test/rendering/variable/enum/rendering.gql +6/−0
• test/rendering/variable/enum/variables.json +3/−0
• test/rendering/variable/include-exclude/query.gql +10/−0
• test/rendering/variable/include-exclude/rendering.gql +8/−0
• test/rendering/variable/include-exclude/variables.json +4/−0
• test/rendering/variable/input/query.gql +6/−0
• test/rendering/variable/input/rendering.gql +6/−0
• test/rendering/variable/input/variables.json +3/−0
• test/rendering/variable/list/query.gql +6/−0
• test/rendering/variable/list/rendering.gql +6/−0
• test/rendering/variable/list/variables.json +3/−0
• test/rendering/variable/schema.gql +26/−0
• test/rendering/variable/simple/query.gql +6/−0
• test/rendering/variable/simple/rendering.gql +6/−0
• test/rendering/variable/simple/variables.json +3/−0
• test/schema/validation/default-value/argument/missing-field/response.json +3/−3
• test/schema/validation/default-value/argument/unexpected-value/response.json +5/−5
• test/schema/validation/default-value/field/unexpected-value/response.json +8/−8
• test/schema/validation/directive/fail/at-invalid-place/response.json +4/−4
• test/schema/validation/directive/fail/missing-argument/response.json +17/−17
• test/schema/validation/directive/fail/sopthisticated/response.json +18/−18
• test/schema/validation/directive/fail/unexpected-value/response.json +8/−8
• test/schema/validation/directive/fail/unknown-directive/response.json +13/−12
• test/schema/validation/performance-check/response.json +1/−0
• test/schema/validation/performance-check/schema.gql +38947/−0

@@ -1,5 +1,28 @@ # Changelog +## 0.16.0 - 05.11.2020++### Breaking Changes++- signature changes:++  - `render`:+    `a -> Text`+    to `a -> ByteString`+  - parseTypeSystemDefinition :+    `Text -> Eventless (Schema VALID)`+    to `ByteString -> Eventless (Schema VALID)`++  - parseTypeDefinitions:+    `Text -> Eventless [TypeDefinition ANY CONST]`+    to `ByteString -> Eventless [TypeDefinition ANY CONST]`++### new features++### Minor Changes++- parser performance optimization+ ## 0.15.1 - 12.09.2020  relaxed upper boundary of `megaparsec` up to 10.0.0

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: ce18cb316044bb79be32544a1626da5772a8ed0cc0d17214179d77c1d9c6f8f4+-- hash: 0e4275c173b38bbd418ec7b8e986f8b9542760b3cb6df2c53d5976715576a5f4  name:           morpheus-graphql-core-version:        0.15.1+version:        0.16.0 synopsis:       Morpheus GraphQL Core description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -44,6 +44,37 @@     test/merge/schema/simple-query/api/ext.gql     test/merge/schema/simple-query/expected/ok.gql     test/merge/schema/simple-query/request/query/query.gql+    test/rendering/simple/directive/query.gql+    test/rendering/simple/directive/rendering.gql+    test/rendering/simple/fragment/query.gql+    test/rendering/simple/fragment/rendering.gql+    test/rendering/simple/mutation/query.gql+    test/rendering/simple/mutation/rendering.gql+    test/rendering/simple/nested/query.gql+    test/rendering/simple/nested/rendering.gql+    test/rendering/simple/query/query.gql+    test/rendering/simple/query/rendering.gql+    test/rendering/simple/schema.gql+    test/rendering/simple/simple/query.gql+    test/rendering/simple/simple/rendering.gql+    test/rendering/simple/subscription/query.gql+    test/rendering/simple/subscription/rendering.gql+    test/rendering/union/interface/query.gql+    test/rendering/union/interface/rendering.gql+    test/rendering/union/schema.gql+    test/rendering/union/union/query.gql+    test/rendering/union/union/rendering.gql+    test/rendering/variable/enum/query.gql+    test/rendering/variable/enum/rendering.gql+    test/rendering/variable/include-exclude/query.gql+    test/rendering/variable/include-exclude/rendering.gql+    test/rendering/variable/input/query.gql+    test/rendering/variable/input/rendering.gql+    test/rendering/variable/list/query.gql+    test/rendering/variable/list/rendering.gql+    test/rendering/variable/schema.gql+    test/rendering/variable/simple/query.gql+    test/rendering/variable/simple/rendering.gql     test/schema/parsing/directive/ok/simple/schema.gql     test/schema/parsing/directive/ok/sophisticated/schema.gql     test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/schema.gql@@ -73,6 +104,7 @@     test/schema/validation/interface/field-args/ok/schema.gql     test/schema/validation/interface/field-type/fail/schema.gql     test/schema/validation/interface/field-type/ok/schema.gql+    test/schema/validation/performance-check/schema.gql     test/schema/validation/schema-definition/fail/non-object-kind/from-schema/schema.gql     test/schema/validation/schema-definition/fail/non-object-kind/without-schema/schema.gql     "test/schema/validation/schema-definition/fail/required query/empty/schema.gql"@@ -100,6 +132,14 @@     test/merge/schema/simple-query/api/app.json     test/merge/schema/simple-query/api/ext.json     test/merge/schema/simple-query/request/query/response.json+    test/rendering/simple/fragment/variables.json+    test/rendering/union/interface/variables.json+    test/rendering/union/union/variables.json+    test/rendering/variable/enum/variables.json+    test/rendering/variable/include-exclude/variables.json+    test/rendering/variable/input/variables.json+    test/rendering/variable/list/variables.json+    test/rendering/variable/simple/variables.json     test/schema/parsing/directive/ok/simple/response.json     test/schema/parsing/directive/ok/sophisticated/response.json     test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/response.json@@ -129,6 +169,7 @@     test/schema/validation/interface/field-args/ok/response.json     test/schema/validation/interface/field-type/fail/response.json     test/schema/validation/interface/field-type/ok/response.json+    test/schema/validation/performance-check/response.json     test/schema/validation/schema-definition/fail/non-object-kind/from-schema/response.json     test/schema/validation/schema-definition/fail/non-object-kind/without-schema/response.json     "test/schema/validation/schema-definition/fail/required query/empty/response.json"@@ -161,11 +202,18 @@       Data.Morpheus.Error.Input       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.Ext.Elems+      Data.Morpheus.Ext.Failure+      Data.Morpheus.Ext.KeyOf+      Data.Morpheus.Ext.Map+      Data.Morpheus.Ext.MergeSet+      Data.Morpheus.Ext.OrdMap+      Data.Morpheus.Ext.SafeHashMap+      Data.Morpheus.Ext.SemigroupM       Data.Morpheus.Internal.Graph       Data.Morpheus.Parser       Data.Morpheus.Parsing.Document.TypeSystem@@ -186,9 +234,6 @@       Data.Morpheus.Types.Internal.AST.Base       Data.Morpheus.Types.Internal.AST.DirectiveLocation       Data.Morpheus.Types.Internal.AST.Fields-      Data.Morpheus.Types.Internal.AST.MergeSet-      Data.Morpheus.Types.Internal.AST.OrdMap-      Data.Morpheus.Types.Internal.AST.SafeHashMap       Data.Morpheus.Types.Internal.AST.Selection       Data.Morpheus.Types.Internal.AST.Stage       Data.Morpheus.Types.Internal.AST.TH@@ -227,6 +272,7 @@     , hashable >=1.0.0     , megaparsec >=7.0.0 && <10.0.0     , mtl >=2.0 && <=3.0+    , relude >=0.3.0     , scientific >=0.3.6.2 && <0.4     , template-haskell >=2.0 && <=3.0     , text >=1.2.3.0 && <1.3@@ -242,6 +288,7 @@   other-modules:       Utils.Api       Utils.MergeSchema+      Utils.Rendering       Utils.Schema       Utils.Utils       Paths_morpheus_graphql_core@@ -257,6 +304,7 @@     , megaparsec >=7.0.0 && <10.0.0     , morpheus-graphql-core     , mtl >=2.0 && <=3.0+    , relude >=0.3.0     , scientific >=0.3.6.2 && <0.4     , tasty     , tasty-hunit

@@ -5,6 +5,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Core   ( parseDSL,@@ -16,7 +17,6 @@     parseRequestWith,     validateSchema,     parseRequest,-    RenderGQL (..),     SelectionTree (..),     Config (..),     VALIDATION_MODE (..),@@ -28,15 +28,15 @@     withDebugger,     mkApp,     runAppStream,+    render,+    RenderGQL,   ) where --- MORPHEUS-import Control.Monad ((>=>)) import Data.ByteString.Lazy.Char8   ( ByteString,   )-import Data.Morpheus.Internal.Utils+import Data.Morpheus.Ext.SemigroupM   ( (<:>),   ) import Data.Morpheus.Parser@@ -45,9 +45,8 @@     parseTypeDefinitions,     parseTypeSystemDefinition,   )-import Data.Morpheus.Rendering.RenderGQL-  ( RenderGQL (..),-  )+import Data.Morpheus.Rendering.RenderGQL (RenderGQL)+import qualified Data.Morpheus.Rendering.RenderGQL as R import Data.Morpheus.Schema.Schema (internalSchema) import Data.Morpheus.Types.App   ( App (..),@@ -70,22 +69,23 @@ import Data.Morpheus.Types.Internal.Resolving   ( Eventless,     resultOr,+    sortErrors,   ) 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 Relude hiding (ByteString) +render :: RenderGQL a => a -> ByteString+render = R.renderGQL+ parseDSL :: ByteString -> Either String (Schema VALID) parseDSL = resultOr (Left . show) pure . parseGQLDocument  parseGQLDocument :: ByteString -> Eventless (Schema VALID)-parseGQLDocument = parseTypeSystemDefinition . LT.toStrict . decodeUtf8+parseGQLDocument = sortErrors . parseTypeSystemDefinition  parseFullGQLDocument :: ByteString -> Eventless (Schema VALID) parseFullGQLDocument = parseGQLDocument >=> (internalSchema <:>)

@@ -1,14 +1,14 @@+{-# LANGUAGE NoImplicitPrelude #-}+ module Data.Morpheus.Error   ( errorMessage,     globalErrorMessage,     gqlWarnings,     renderGQLErrors,     deprecatedField,-    nameCollisionError,   ) where -import Data.Morpheus.Error.Schema import Data.Morpheus.Error.Utils import Data.Morpheus.Error.Warning   ( deprecatedField,

@@ -8,8 +8,6 @@ where  -- MORPHEUS--import Data.Maybe (Maybe (..)) import Data.Morpheus.Error.Utils (validationErrorMessage) import Data.Morpheus.Types.Internal.AST.Base   ( FieldName,@@ -20,8 +18,7 @@     msg,     msgSepBy,   )-import Data.Semigroup ((<>))-import Prelude (($), fmap, head)+import Relude  {-   FRAGMENT:@@ -35,14 +32,14 @@     {...H} -> "Unknown fragment \"H\"." -} -cannotSpreadWithinItself :: [Ref] -> ValidationError-cannotSpreadWithinItself fragments = ValidationError text (fmap refPosition fragments)+cannotSpreadWithinItself :: NonEmpty Ref -> ValidationError+cannotSpreadWithinItself (fr :| frs) = ValidationError text (fmap refPosition (fr : frs))   where     text =       "Cannot spread fragment "-        <> msg (refName $ head fragments)+        <> msg (refName fr)         <> " within itself via "-        <> msgSepBy ", " (fmap refName fragments)+        <> msgSepBy ", " (fmap refName (fr : frs))         <> "."  -- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."

@@ -5,9 +5,14 @@   ) where +import Data.Morpheus.Ext.Map (Indexed (..)) import Data.Morpheus.Types.Internal.AST.Base   ( ValidationError,   )+import Relude  class NameCollision a where   nameCollision :: a -> ValidationError++instance NameCollision a => NameCollision (Indexed k a) where+  nameCollision = nameCollision . indexedValue

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

@@ -14,7 +14,6 @@   ( ByteString,     pack,   )-import Data.Maybe (Maybe, maybeToList) import Data.Morpheus.Types.Internal.AST.Base   ( GQLError (..),     GQLErrors,@@ -22,8 +21,7 @@     Position (..),     ValidationError (..),   )-import Data.Semigroup ((<>))-import Prelude ((.), String)+import Relude hiding (ByteString)  validationErrorMessage :: Maybe Position -> Message -> ValidationError validationErrorMessage pos message = ValidationError message (maybeToList pos)

@@ -16,8 +16,7 @@     Variable (..),     msg,   )-import Data.Semigroup ((<>))-import Prelude (($), Maybe (..))+import Relude  -- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"." incompatibleVariableType :: Ref -> Variable s -> TypeRef -> ValidationError

@@ -12,10 +12,6 @@  import Data.Aeson (encode) import Data.ByteString.Lazy.Char8 (unpack)-import Data.Foldable (traverse_)--- MORPHEUS--import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Error.Utils (errorMessage) import Data.Morpheus.Types.Internal.AST.Base   ( Description,@@ -24,17 +20,8 @@     Ref (..),     msg,   )-import Data.Semigroup ((<>))-import Language.Haskell.TH-  ( Q,-    reportWarning,-  )-import Prelude-  ( ($),-    (.),-    String,-    pure,-  )+import Language.Haskell.TH (Q, reportWarning)+import Relude  renderGQLErrors :: GQLErrors -> String renderGQLErrors = unpack . encode

@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Ext.Elems+  ( Elems (..),+    size,+  )+where++import qualified Data.HashMap.Lazy as HM+import Instances.TH.Lift ()+import Relude++class Elems a coll | coll -> a where+  elems :: coll -> [a]++instance Elems a (HashMap k a) where+  elems = HM.elems++instance Elems a [a] where+  elems = id++size :: Elems a coll => coll -> Int+size = length . elems

@@ -0,0 +1,21 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Ext.Failure+  ( Failure (..),+  )+where++import Relude++-- Failure: for custom Morpheus GrapHQL errors+class Applicative f => Failure error (f :: * -> *) where+  failure :: error -> f v++instance Failure error (Either error) where+  failure = Left++instance (Monad m, Failure errors m) => Failure errors (ReaderT ctx m) where+  failure = lift . failure

@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Ext.KeyOf+  ( KeyOf (..),+    toPair,+  )+where++import Data.Morpheus.Ext.Map+  ( Indexed (..),+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( FieldName (..),+    Ref (..),+    TypeName (..),+    TypeNameRef (..),+  )+import Relude++class (Eq k, Hashable k) => KeyOf k a | a -> k where+  keyOf :: a -> k++instance (Eq k, Hashable k) => KeyOf k (k, a) where+  keyOf = fst++instance KeyOf FieldName Ref where+  keyOf = refName++instance KeyOf TypeName TypeNameRef where+  keyOf = typeNameRef++instance (Eq k, Hashable k) => KeyOf k (Indexed k a) where+  keyOf = indexedKey++toPair :: KeyOf k a => a -> (k, a)+toPair x = (keyOf x, x)

@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Ext.Map+  ( Indexed (..),+    indexed,+    fromListT,+    resolveWith,+    runResolutionT,+    ResolutionT,+  )+where++import Data.Foldable (foldl)+import qualified Data.HashMap.Lazy as HM+import Language.Haskell.TH.Syntax (Lift)+import Relude++sortedEntries :: [Indexed k a] -> [(k, a)]+sortedEntries = fmap f . sortOn index+  where+    f a = (indexedKey a, indexedValue a)++fromListT :: (Monad m, Eq k, Hashable k) => [(k, a)] -> ResolutionT k a coll m coll+fromListT = traverse resolveDuplicatesM . fromListDuplicates >=> fromNoDuplicatesM++resolveWith ::+  Monad m =>+  (a -> a -> m a) ->+  NonEmpty a ->+  m a+resolveWith f (x :| xs) = foldlM f x xs++data Indexed k a = Indexed+  { index :: Int,+    indexedKey :: k,+    indexedValue :: a+  }+  deriving+    ( Show,+      Eq,+      Functor,+      Traversable,+      Foldable,+      Lift+    )++fromListDuplicates :: (Eq k, Hashable k) => [(k, a)] -> [(k, NonEmpty a)]+fromListDuplicates xs =+  sortedEntries+    $ HM.elems+    $ clusterDuplicates (indexed xs) HM.empty++indexed :: [(k, a)] -> [Indexed k a]+indexed = __indexed 0+  where+    __indexed :: Int -> [(k, a)] -> [Indexed k a]+    __indexed _ [] = []+    __indexed i ((k, x) : xs) = Indexed i k x : __indexed (i + 1) xs++resolveDuplicatesM :: Monad m => (k, NonEmpty a) -> ResolutionT k a coll m (k, a)+resolveDuplicatesM (k, xs) = asks resolveDuplicates >>= lift . fmap (k,) . (xs &)++fromNoDuplicatesM :: Monad m => [(k, a)] -> ResolutionT k a coll m coll+fromNoDuplicatesM xs = asks ((xs &) . fromNoDuplicates)++insertWithList :: (Eq k, Hashable k) => Indexed k (NonEmpty a) -> HashMap k (Indexed k (NonEmpty a)) -> HashMap k (Indexed k (NonEmpty a))+insertWithList (Indexed i1 key value) = HM.alter (Just . updater) key+  where+    updater Nothing = Indexed i1 key value+    updater (Just (Indexed i2 _ x)) = Indexed i2 key (x <> value)++clusterDuplicates :: (Eq k, Hashable k) => [Indexed k a] -> HashMap k (Indexed k (NonEmpty a)) -> HashMap k (Indexed k (NonEmpty a))+clusterDuplicates [] = id+clusterDuplicates xs = flip (foldl (\coll x -> insertWithList (fmap (:| []) x) coll)) xs++data Resolution k a coll m = Resolution+  { resolveDuplicates :: NonEmpty a -> m a,+    fromNoDuplicates :: [(k, a)] -> coll+  }++runResolutionT ::+  ResolutionT k a coll m b ->+  ([(k, a)] -> coll) ->+  (NonEmpty a -> m a) ->+  m b+runResolutionT (ResolutionT x) fromNoDuplicates resolveDuplicates = runReaderT x Resolution {..}++newtype ResolutionT k a coll m x = ResolutionT+  { _runResolutionT :: ReaderT (Resolution k a coll m) m x+  }+  deriving+    ( Functor,+      Monad,+      Applicative,+      MonadReader (Resolution k a coll m)+    )++instance MonadTrans (ResolutionT k a coll) where+  lift = ResolutionT . lift

@@ -0,0 +1,106 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Ext.MergeSet+  ( MergeSet,+  )+where++import Data.Morpheus.Ext.Elems (Elems (..))+import Data.Morpheus.Ext.Map+  ( fromListT,+    resolveWith,+    runResolutionT,+  )+import Data.Morpheus.Ext.SemigroupM+  ( SemigroupM (..),+  )+import Data.Morpheus.Internal.Utils+  ( Collection (..),+    Failure (..),+    FromElems (..),+    KeyOf (..),+    Selectable (..),+    toPair,+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( Ref,+    ValidationErrors,+  )+import Data.Morpheus.Types.Internal.AST.Stage+  ( RAW,+    Stage,+    VALID,+  )+import Language.Haskell.TH.Syntax (Lift (..))+import Relude++-- set with mergeable components+newtype MergeSet (dups :: Stage) k a = MergeSet+  { unpack :: [a]+  }+  deriving+    ( Show,+      Eq,+      Functor,+      Foldable,+      Lift,+      Traversable,+      Collection a,+      Elems a+    )++instance (KeyOf k a) => Selectable k a (MergeSet opt k a) where+  selectOr fb f key (MergeSet ls) = maybe fb f (find ((key ==) . keyOf) ls)++instance+  ( KeyOf k a,+    SemigroupM m a,+    Monad m,+    Failure ValidationErrors m,+    Eq a+  ) =>+  SemigroupM m (MergeSet VALID k a)+  where+  mergeM path (MergeSet x) (MergeSet y) = resolveMergable path (x <> y)++resolveMergable ::+  ( KeyOf k a,+    Monad m,+    Eq a,+    SemigroupM m a,+    Failure ValidationErrors m+  ) =>+  [Ref] ->+  [a] ->+  m (MergeSet dups k a)+resolveMergable path xs = runResolutionT (fromListT (toPair <$> xs)) (MergeSet . fmap snd) (resolveWith (resolveConflict path))++instance+  ( KeyOf k a,+    SemigroupM m a,+    Monad m,+    Failure ValidationErrors m,+    Eq a+  ) =>+  FromElems m a (MergeSet VALID k a)+  where+  fromElems = resolveMergable []++instance Applicative m => SemigroupM m (MergeSet RAW k a) where+  mergeM _ (MergeSet x) (MergeSet y) = pure $ MergeSet $ x <> y++instance Applicative m => FromElems m a (MergeSet RAW k a) where+  fromElems = pure . MergeSet++resolveConflict :: (Monad m, Eq a, KeyOf k a, SemigroupM m a, Failure ValidationErrors m) => [Ref] -> a -> a -> m a+resolveConflict path oldValue newValue+  | oldValue == newValue = pure oldValue+  | otherwise = mergeM path oldValue newValue

@@ -0,0 +1,92 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Ext.OrdMap+  ( OrdMap (..),+    unsafeFromList,+  )+where++import qualified Data.HashMap.Lazy as HM+import Data.Morpheus.Error.NameCollision (NameCollision (..))+import Data.Morpheus.Ext.Elems (Elems (..))+import Data.Morpheus.Ext.Map+  ( Indexed (..),+    indexed,+  )+import Data.Morpheus.Ext.SemigroupM+  ( SemigroupM (..),+  )+import Data.Morpheus.Internal.Utils+  ( Collection (..),+    Failure,+    FromElems (..),+    KeyOf (..),+    Selectable (..),+    toPair,+  )+import Data.Morpheus.Types.Internal.AST.Base (ValidationErrors)+import Language.Haskell.TH.Syntax (Lift (..))+import Relude++-- OrdMap+newtype OrdMap k a = OrdMap+  { mapEntries :: HashMap k (Indexed k a)+  }+  deriving+    ( Show,+      Eq,+      Functor,+      Traversable+    )++instance (Lift a, Lift k, Eq k, Hashable k) => Lift (OrdMap k a) where+  lift (OrdMap x) = [|OrdMap (HM.fromList ls)|]+    where+      ls = HM.toList x++#if MIN_VERSION_template_haskell(2,16,0)+  liftTyped (OrdMap x) = [||OrdMap (HM.fromList ls)||]+    where+      ls = HM.toList x+#endif++instance (Eq k, Hashable k) => Foldable (OrdMap k) where+  foldMap f = foldMap f . getElements++getElements :: (Eq k, Hashable k) => OrdMap k b -> [b]+getElements = fmap indexedValue . sortOn index . toList . mapEntries++instance (KeyOf k a, Hashable k) => Collection a (OrdMap k a) where+  empty = OrdMap HM.empty+  singleton x = OrdMap $ HM.singleton (keyOf x) (Indexed 0 (keyOf x) x)++instance (Eq k, Hashable k) => Selectable k a (OrdMap k a) where+  selectOr fb f key OrdMap {mapEntries} = maybe fb (f . indexedValue) (HM.lookup key mapEntries)++instance (NameCollision a, Monad m, KeyOf k a, Failure ValidationErrors m) => SemigroupM m (OrdMap k a) where+  mergeM ref (OrdMap x) (OrdMap y) = OrdMap <$> mergeM ref x y++instance (NameCollision a, Monad m, Failure ValidationErrors m, KeyOf k a, Hashable k) => FromElems m a (OrdMap k a) where+  fromElems values = OrdMap <$> fromElems (indexed (toPair <$> values))++instance (Eq k, Hashable k) => Elems a (OrdMap k a) where+  elems = getElements++unsafeFromList ::+  (Hashable k, Eq k) =>+  [(k, a)] ->+  OrdMap k a+unsafeFromList = OrdMap . HM.fromList . fmap withKey . indexed+  where+    withKey idx = (indexedKey idx, idx)

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

@@ -0,0 +1,82 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Ext.SemigroupM+  ( SemigroupM (..),+    (<:>),+    concatTraverse,+    join,+  )+where++import qualified Data.HashMap.Lazy as HM+import Data.HashMap.Lazy (HashMap)+import Data.Morpheus.Error.NameCollision (NameCollision)+import Data.Morpheus.Ext.KeyOf (KeyOf (..))+import Data.Morpheus.Ext.Map+  ( fromListT,+    runResolutionT,+  )+import Data.Morpheus.Internal.Utils+  ( Collection (..),+    Elems (..),+    Failure,+    failOnDuplicates,+  )+import Data.Morpheus.Types.Internal.AST.Base+  ( Ref,+    ValidationErrors,+  )+import Relude+  ( ($),+    Applicative (..),+    Monad (..),+    Semigroup (..),+    Traversable (..),+  )++class SemigroupM (m :: * -> *) a where+  mergeM :: [Ref] -> a -> a -> m a++instance+  ( NameCollision a,+    Monad m,+    KeyOf k a,+    Failure ValidationErrors m+  ) =>+  SemigroupM m (HashMap k a)+  where+  mergeM _ x y = runResolutionT (fromListT $ HM.toList x <> HM.toList y) HM.fromList failOnDuplicates++concatTraverse ::+  ( Monad m,+    Failure ValidationErrors m,+    Collection b cb,+    Elems a ca,+    SemigroupM m cb+  ) =>+  (a -> m cb) ->+  ca ->+  m cb+concatTraverse f smap =+  traverse f (elems smap)+    >>= join++join ::+  ( Collection e a,+    Monad m,+    Failure ValidationErrors m,+    SemigroupM m a+  ) =>+  [a] ->+  m a+join = __join empty+  where+    __join acc [] = pure acc+    __join acc (x : xs) = acc <:> x >>= (`__join` xs)++(<:>) :: SemigroupM m a => a -> a -> m a+(<:>) = mergeM []

@@ -11,18 +11,9 @@   ) where -import Control.Applicative (Applicative, pure)-import Data.Foldable (traverse_)-import Data.List (elem, lookup)-import Data.Maybe (Maybe (..))--- MORPHEUS-import Data.Morpheus.Types.Internal.AST-  ( Ref (..),-  )-import Data.Semigroup ((<>))-import Prelude-  ( otherwise,-  )+import Data.List (lookup)+import Data.Morpheus.Types.Internal.AST (Ref (..))+import Relude  type Node = Ref @@ -32,31 +23,31 @@  cycleChecking ::   Applicative m =>-  ([Ref] -> m ()) ->+  (NonEmpty Ref -> m ()) ->   Graph ->   m ()-cycleChecking fail graph = traverse_ checkNode graph+cycleChecking fail' graph = traverse_ checkNode graph   where-    checkNode (node, _) = cycleCheckingWith graph node [node] fail+    checkNode (node, _) = cycleCheckingWith graph node [node] fail'  cycleCheckingWith ::   Applicative m =>   Graph ->   Ref ->   [Ref] ->-  ([Ref] -> m ()) ->+  (NonEmpty Ref -> m ()) ->   m ()-cycleCheckingWith graph parentNode history fail =+cycleCheckingWith graph parentNode history fail' =   case lookup parentNode graph of     Just node -> traverse_ checkNode node     Nothing -> pure ()   where     checkNode node       | node `elem` history =-        fail (node : history)+        fail' (node :| history)       | otherwise =         cycleCheckingWith           graph           node           (history <> [node])-          fail+          fail'

@@ -9,7 +9,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}--- MORPHEUS {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Internal.TH@@ -19,18 +18,17 @@     applyVars,     decArgs,     declareTypeRef,-    destructRecord,     funDProxy,     funDSimple,     infoTyVars,     isEnum,     m',-    mkFieldsE,     nameSpaceField,     nameSpaceType,     toCon,     toConE,     toConT,+    toVar,     ToName (..),     toString,     toVarE,@@ -43,49 +41,29 @@     o',     e',     vars,-    decodeObjectE,-    matchWith,   ) where -import Control.Applicative ((<*>), pure)-import Control.Monad.Fail (fail)-import Data.Foldable (foldl, foldr1)-import Data.Functor ((<$>))-import Data.Maybe (Maybe (..))+import Data.Foldable (foldl) import Data.Morpheus.Internal.Utils   ( capitalize,     nameSpaceField,     nameSpaceType,   ) import Data.Morpheus.Types.Internal.AST-  ( FieldDefinition (..),-    FieldName (..),+  ( FieldName (..),     TypeKind (..),     TypeName (..),     TypeRef (..),     TypeWrapper (..),     convertToHaskellName,     isEnum,-    isNullable,     isOutputObject,     readName,   )-import Data.Semigroup ((<>)) import Data.Text (unpack) import Language.Haskell.TH-import Prelude-  ( ($),-    (.),-    (==),-    Bool (..),-    String,-    id,-    map,-    otherwise,-    show,-    (||),-  )+import Relude hiding (ToString (..), Type)  m' :: Type m' = VarT (mkName "m")@@ -119,8 +97,8 @@     wrappedT [] = decType typeArgs     --------------------------------------------     decType :: Maybe String -> Type-    decType (Just par) = apply (capitalize typeConName) [toVar par]-    decType _ = toCon (capitalize typeConName)+    decType (Just par) = apply typeConName [toVar par]+    decType _ = toCon typeConName  tyConArgs :: TypeKind -> [String] tyConArgs kindD@@ -234,21 +212,6 @@ funDSimple :: Name -> [PatQ] -> ExpQ -> DecQ funDSimple name args body = funD name [clause args (normalB body) []] --- |--- input:--- >>>--- destructRecord "User" ["name","id"]--- >>>------ expression:--- >>>--- (User name id)--- >>>-destructRecord :: TypeName -> [FieldDefinition cat s] -> PatQ-destructRecord conName fields = conP (toName conName) (vars names)-  where-    names = map fieldName fields- infoTyVars :: Info -> [TyVarBndr] infoTyVars (TyConI x) = decArgs x infoTyVars _ = []@@ -270,74 +233,6 @@  toConE :: ToCon a Exp => a -> ExpQ toConE = toCon---- | 'mkFieldsE'------  input :---  >>>---       mkFieldsE 'mkValue [FieldDefinition { fieldName = \"field1" ,..} ,..]---  >>>------  expression :---  >>>---    [ mkValue \"field1\" field1,---    ..---    ]--- >>>-mkFieldsE :: Name -> [FieldDefinition cat s] -> Exp-mkFieldsE name = ListE . map (mkEntryWith name)----  input : mkFieldWith 'mkValue (FieldDefinition { fieldName = "field1", ..})---  expression: mkValue "field1"  field1-mkEntryWith ::-  Name ->-  FieldDefinition cat s ->-  Exp-mkEntryWith f FieldDefinition {fieldName} =-  AppE-    (AppE (VarE f) (toString fieldName))-    (toVar fieldName)--decodeObjectE :: (Bool -> Name) -> TypeName -> [FieldDefinition cat s] -> ExpQ-decodeObjectE _ conName [] = appE (varE 'pure) (toCon conName)-decodeObjectE funName conName fields =-  uInfixE-    (toCon conName)-    (varE '(<$>))-    (foldr1 withApplicative $ map (defField funName) fields)--withApplicative :: ExpQ -> ExpQ -> ExpQ-withApplicative x = uInfixE x (varE '(<*>))--matchWith ::-  Bool ->-  (t -> (PatQ, ExpQ)) ->-  [t] ->-  ExpQ-matchWith isClosed f xs = lamCaseE (map buildMatch xs <> fallback)-  where-    fallback-      | isClosed = []-      | otherwise = [elseCaseEXP]-    buildMatch x = match pat (normalB body) []-      where-        (pat, body) = f x--elseCaseEXP :: MatchQ-elseCaseEXP = match v' body []-  where-    body =-      normalB $-        appE-          (toVarE 'fail)-          ( uInfixE-              (appE (varE 'show) v')-              (varE '(<>))-              (stringE " is Not Valid Union Constructor")-          )--defField :: (Bool -> Name) -> FieldDefinition cat s -> ExpQ-defField f field@FieldDefinition {fieldName} = uInfixE v' (varE $ f (isNullable field)) (toString fieldName)  #if MIN_VERSION_template_haskell(2,15,0) -- fix breaking changes

@@ -1,12 +1,9 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Internal.Utils@@ -16,89 +13,65 @@     capitalTypeName,     Collection (..),     Selectable (..),-    Listable (..),-    Merge (..),+    FromElems (..),     Failure (..),     KeyOf (..),     toPair,     selectBy,-    member,-    keys,-    size,-    (<:>),     mapFst,     mapSnd,     mapTuple,-    UpdateT (..),-    resolveUpdates,-    concatUpdates,-    failUpdates,-    ordTraverse,-    ordTraverse_,     traverseCollection,-    (<.>),-    SemigroupM (..),-    fromListT,-    mergeT,-    runResolutionT,-    ResolutionT,     prop,-    resolveWith,     stripFieldNamespace,     stripConstructorNamespace,+    fromLBS,+    toLBS,+    mergeT,+    Elems (..),+    size,+    failOnDuplicates,   ) where -import Control.Applicative (Applicative (..))-import Control.Monad ((=<<), (>=>), (>>=), foldM)-import Control.Monad.Reader (MonadReader (..), asks)-import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.Trans.Reader-  ( ReaderT (..),-  )+import Data.ByteString.Lazy (ByteString) import Data.Char   ( toLower,     toUpper,   )-import Data.Foldable (foldlM, null, traverse_)-import Data.Function ((&))-import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HM-import Data.Hashable (Hashable)-import Data.List (drop, find)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (maybe) import Data.Morpheus.Error.NameCollision (NameCollision (..))+import Data.Morpheus.Ext.Elems (Elems (..), size)+import Data.Morpheus.Ext.Failure (Failure (..))+import Data.Morpheus.Ext.KeyOf (KeyOf (..), toPair)+import Data.Morpheus.Ext.Map+  ( ResolutionT,+    fromListT,+    runResolutionT,+  ) import Data.Morpheus.Types.Internal.AST.Base   ( FieldName,     FieldName (..),-    Ref (..),     Token,     TypeName (..),-    TypeNameRef (..),     ValidationErrors,   )-import Data.Semigroup (Semigroup (..)) import qualified Data.Text as T-import Data.Traversable (traverse)+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import Instances.TH.Lift ()-import Prelude-  ( ($),-    (.),-    Bool (..),-    Either (..),-    Eq (..),-    Functor (..),-    Int,-    Monad,-    String,-    const,-    fst,-    length,-    otherwise,-    snd,+import Relude hiding+  ( ByteString,+    decodeUtf8,+    encodeUtf8,   ) +toLBS :: Text -> ByteString+toLBS = encodeUtf8 . LT.fromStrict++fromLBS :: ByteString -> Text+fromLBS = LT.toStrict . decodeUtf8+ prop :: (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop f fSel a1 a2 = f (fSel a1) (fSel a2) @@ -106,40 +79,30 @@ nameSpaceType list (TypeName name) = TypeName . T.concat $ fmap capitalize (fmap readName list <> [name])  nameSpaceField :: TypeName -> FieldName -> FieldName-nameSpaceField nSpace (FieldName name) = FieldName (nonCapital nSpace <> capitalize name)+nameSpaceField (TypeName nSpace) (FieldName name) = FieldName (uncapitalize nSpace <> capitalize name)  dropPrefix :: TypeName -> String -> String-dropPrefix (TypeName name) = drop (length (T.unpack name))+dropPrefix (TypeName name) = drop (T.length name)  stripConstructorNamespace :: TypeName -> String -> String stripConstructorNamespace = dropPrefix  stripFieldNamespace :: TypeName -> String -> String-stripFieldNamespace prefix = uncapitalize . dropPrefix prefix--mapText :: (String -> String) -> Token -> Token-mapText f = T.pack . f . T.unpack--nonCapital :: TypeName -> Token-nonCapital = uncapitalize . readTypeName--class Capitalize a where-  capitalize :: a -> a-  uncapitalize :: a -> a+stripFieldNamespace prefix = __uncapitalize . dropPrefix prefix+  where+    __uncapitalize [] = []+    __uncapitalize (x : xs) = toLower x : xs -instance Capitalize String where-  capitalize [] = []-  capitalize (x : xs) = toUpper x : xs-  uncapitalize [] = []-  uncapitalize (x : xs) = toLower x : xs+capitalize :: Text -> Text+capitalize = mapFstChar toUpper -instance Capitalize Token where-  capitalize = mapText capitalize-  uncapitalize = mapText uncapitalize+uncapitalize :: Text -> Text+uncapitalize = mapFstChar toLower -instance Capitalize TypeName where-  capitalize = TypeName . capitalize . readTypeName-  uncapitalize = TypeName . uncapitalize . readTypeName+mapFstChar :: (Char -> Char) -> Token -> Token+mapFstChar f x+  | T.null x = x+  | otherwise = T.singleton (f $ T.head x) <> T.tail x  capitalTypeName :: FieldName -> TypeName capitalTypeName = TypeName . capitalize . readName@@ -160,6 +123,9 @@ class Selectable k a c | c -> a where   selectOr :: d -> (a -> d) -> k -> c -> d +  member :: k -> c -> Bool+  member = selectOr False (const True)+ instance KeyOf k a => Selectable k a [a] where   selectOr fb f key lib = maybe fb f (find ((key ==) . keyOf) lib) @@ -169,29 +135,11 @@ selectBy :: (Failure e m, Selectable k a c, Monad m) => e -> k -> c -> m a selectBy err = selectOr (failure err) pure -member :: Selectable k a c => k -> c -> Bool-member = selectOr False toTrue-  where-    toTrue :: a -> Bool-    toTrue _ = True--ordTraverse ::-  ( Monad f,-    KeyOf k b,-    Listable a (t a),-    Listable b (t b),-    Failure ValidationErrors f-  ) =>-  (a -> f b) ->-  t a ->-  f (t b)-ordTraverse = traverseCollection- traverseCollection ::   ( Monad f,     KeyOf k b,-    Listable a (t a),-    Listable b (t' b),+    Elems a (t a),+    FromElems f b (t' b),     Failure ValidationErrors f   ) =>   (a -> f b) ->@@ -199,75 +147,25 @@   f (t' b) traverseCollection f a = fromElems =<< traverse f (elems a) -ordTraverse_ ::-  ( Monad f,-    Listable a (t a)-  ) =>-  (a -> f b) ->-  t a ->-  f ()-ordTraverse_ f a = traverse_ f (elems a)--class (Eq k, Hashable k) => KeyOf k a | a -> k where-  keyOf :: a -> k--instance (Eq k, Hashable k) => KeyOf k (k, a) where-  keyOf = fst--instance KeyOf FieldName Ref where-  keyOf = refName--instance KeyOf TypeName TypeNameRef where-  keyOf = typeNameRef--toPair :: KeyOf k a => a -> (k, a)-toPair x = (keyOf x, x)- -- list Like Collections-class Listable a coll | coll -> a where-  elems :: coll -> [a]-  fromElems :: (Monad m, Failure ValidationErrors m) => [a] -> m coll--instance (NameCollision a, KeyOf k a) => Listable a (HashMap k a) where-  fromElems xs = runResolutionT (fromListT xs) hmUnsafeFromValues failOnDuplicates-  elems = HM.elems+class FromElems m a coll | coll -> a where+  fromElems :: [a] -> m coll -keys :: (KeyOf k a, Listable a coll) => coll -> [k]-keys = fmap keyOf . elems+mergeT :: (KeyOf k a, Monad m, Elems a c) => c -> c -> ResolutionT k a c m c+mergeT x y = fromListT (toPair <$> (elems x <> elems y)) -size :: Listable a coll => coll -> Int-size = length . elems+instance+  ( NameCollision a,+    Failure ValidationErrors m,+    KeyOf k a,+    Monad m+  ) =>+  FromElems m a (HashMap k a)+  where+  fromElems xs = runResolutionT (fromListT (toPair <$> xs)) HM.fromList failOnDuplicates  -- Merge Object with of Failure as an Option-class Merge a where-  merge :: (Monad m, Failure ValidationErrors m) => [Ref] -> a -> a -> m a -instance (NameCollision a, KeyOf k a) => Merge (HashMap k a) where-  merge _ x y = runResolutionT (fromListT $ HM.elems x <> HM.elems y) hmUnsafeFromValues failOnDuplicates--(<:>) :: (Monad m, Merge a, Failure ValidationErrors m) => a -> a -> m a-(<:>) = merge []--class SemigroupM m a where-  mergeM :: [Ref] -> a -> a -> m a--(<.>) ::-  (SemigroupM m a) =>-  a ->-  a ->-  m a-(<.>) = mergeM []---- Failure: for custom Morpheus GrapHQL errors-class Applicative f => Failure error (f :: * -> *) where-  failure :: error -> f v--instance Failure error (Either error) where-  failure = Left--instance (Monad m, Failure errors m) => Failure errors (ReaderT ctx m) where-  failure = lift . failure- mapFst :: (a -> a') -> (a, b) -> (a', b) mapFst f (a, b) = (f a, b) @@ -276,98 +174,6 @@  mapTuple :: (a -> a') -> (b -> b') -> (a, b) -> (a', b') mapTuple f1 f2 (a, b) = (f1 a, f2 b)---- Helper Functions-newtype UpdateT m a = UpdateT {updateTState :: a -> m a}--failUpdates :: (Failure e m) => e -> UpdateT m a-failUpdates = UpdateT . const . failure--concatUpdates :: Monad m => [UpdateT m a] -> UpdateT m a-concatUpdates x = UpdateT (`resolveUpdates` x)--resolveUpdates :: Monad m => a -> [UpdateT m a] -> m a-resolveUpdates a = foldM (&) a . fmap updateTState--type RESOLUTION k a coll m =-  ( Monad m,-    KeyOf k a,-    Listable a coll-  )--data Resolution a coll m = Resolution-  { resolveDuplicates :: NonEmpty a -> m a,-    fromNoDuplicates :: [a] -> coll-  }--runResolutionT ::-  ResolutionT a coll m b ->-  ([a] -> coll) ->-  (NonEmpty a -> m a) ->-  m b-runResolutionT (ResolutionT x) fromNoDuplicates resolveDuplicates = runReaderT x Resolution {..}--newtype ResolutionT a coll m x = ResolutionT-  { _runResolutionT :: ReaderT (Resolution a coll m) m x-  }-  deriving-    ( Functor,-      Monad,-      Applicative,-      MonadReader (Resolution a coll m)-    )--instance MonadTrans (ResolutionT e coll) where-  lift = ResolutionT . lift--instance-  ( Monad m,-    Failure ValidationErrors m-  ) =>-  Failure ValidationErrors (ResolutionT a coll m)-  where-  failure = lift . failure--resolveDuplicatesM :: Monad m => NonEmpty a -> ResolutionT a coll m a-resolveDuplicatesM xs = asks resolveDuplicates >>= lift . (xs &)--fromNoDuplicatesM :: Monad m => [a] -> ResolutionT a coll m coll-fromNoDuplicatesM xs = asks ((xs &) . fromNoDuplicates)--insertWithList :: (Eq k, Hashable k) => (k, NonEmpty a) -> [(k, NonEmpty a)] -> [(k, NonEmpty a)]-insertWithList (key, value) values-  | key `member` values = fmap replaceBy values-  | otherwise = values <> [(key, value)]-  where-    replaceBy (entryKey, entryValue)-      | key == entryKey = (key, entryValue <> value)-      | otherwise = (entryKey, entryValue)--clusterDuplicates :: (Eq k, Hashable k) => [(k, NonEmpty a)] -> [(k, a)] -> [(k, NonEmpty a)]-clusterDuplicates collected [] = collected-clusterDuplicates coll ((key, value) : xs) = clusterDuplicates (insertWithList (key, value :| []) coll) xs--fromListDuplicates :: (KeyOf k a) => [a] -> [(k, NonEmpty a)]-fromListDuplicates xs = clusterDuplicates [] (fmap toPair xs)--fromListT ::-  RESOLUTION k a coll m =>-  [a] ->-  ResolutionT a coll m coll-fromListT = traverse (resolveDuplicatesM . snd) . fromListDuplicates >=> fromNoDuplicatesM--mergeT :: RESOLUTION k a coll m => coll -> coll -> ResolutionT a coll m coll-mergeT c1 c2 = traverse (resolveDuplicatesM . snd) (fromListDuplicates (elems c1 <> elems c2)) >>= fromNoDuplicatesM--resolveWith ::-  Monad m =>-  (a -> a -> m a) ->-  NonEmpty a ->-  m a-resolveWith f (x :| xs) = foldlM f x xs--hmUnsafeFromValues :: (Eq k, KeyOf k a) => [a] -> HashMap k a-hmUnsafeFromValues = HM.fromList . fmap toPair  failOnDuplicates :: (Failure ValidationErrors m, NameCollision a) => NonEmpty a -> m a failOnDuplicates (x :| xs)

@@ -1,3 +1,5 @@+{-# LANGUAGE NoImplicitPrelude #-}+ module Data.Morpheus.Parser   ( parseTypeDefinitions,     parseTypeSystemDefinition,@@ -6,12 +8,14 @@   ) where -import Control.Monad ((>=>))+import Data.ByteString.Lazy (ByteString)+import Data.Morpheus.Ext.SemigroupM ((<:>)) import qualified Data.Morpheus.Parsing.Document.TypeSystem as P   ( parseSchema,     parseTypeDefinitions,   ) import Data.Morpheus.Parsing.Request.Parser (parseGQL)+import Data.Morpheus.Schema.Schema (internalSchema) import Data.Morpheus.Types.IO   ( GQLRequest (..),   )@@ -37,10 +41,10 @@ import Data.Morpheus.Validation.Query.Validation   ( validateRequest,   )-import Data.Text (Text)+import Relude hiding (ByteString)  parseTypeSystemDefinition ::-  Text -> Eventless (Schema VALID)+  ByteString -> Eventless (Schema VALID) parseTypeSystemDefinition =   P.parseSchema     >=> validateSchema@@ -51,11 +55,14 @@         }  parseTypeDefinitions ::-  Text -> Eventless [TypeDefinition ANY CONST]+  ByteString -> Eventless [TypeDefinition ANY CONST] parseTypeDefinitions = P.parseTypeDefinitions  parseRequest :: GQLRequest -> Eventless GQLQuery parseRequest = parseGQL  parseRequestWith :: Config -> Schema VALID -> GQLRequest -> Eventless (Operation VALID)-parseRequestWith config schema = parseRequest >=> validateRequest config schema+parseRequestWith config schema req = do+  qu <- parseRequest req+  fuillSchema <- internalSchema <:> schema+  validateRequest config fuillSchema qu

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -10,13 +11,7 @@   ) where --- MORPHEUS--import Control.Applicative ((*>), pure)-import Control.Monad ((>=>))-import Data.Foldable (foldr)-import Data.Functor ((<$>), fmap)-import Data.Maybe (Maybe (..))+import Data.ByteString.Lazy (ByteString) import Data.Morpheus.Error.NameCollision (NameCollision (..)) import Data.Morpheus.Parsing.Internal.Internal   ( Parser,@@ -33,7 +28,10 @@     typeDeclaration,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( collection,+  ( at,+    collection,+    colon,+    equal,     ignoredTokens,     keyword,     optDescription,@@ -43,7 +41,6 @@     pipe,     sepByAnd,     setOf,-    symbol,   ) import Data.Morpheus.Parsing.Internal.Value   ( Parse (..),@@ -51,41 +48,51 @@ import Data.Morpheus.Types.Internal.AST   ( ANY,     CONST,-    DataFingerprint (..),     Description,     DirectiveDefinition (..),-    IN,+    Directives,+    ELEM,+    FieldsDefinition,+    OBJECT,     OUT,     RawTypeDefinition (..),     RootOperationTypeDefinition (..),     ScalarDefinition (..),     Schema,     SchemaDefinition (..),+    TRUE,     TypeContent (..),     TypeDefinition (..),     TypeName,     Value,     buildSchema,     mkUnionMember,-    toAny,   ) import Data.Morpheus.Types.Internal.Resolving   ( Eventless,     failure,   )-import Data.Text (Text)+import Relude hiding (ByteString) import Text.Megaparsec-  ( (<|>),-    eof,+  ( eof,     label,     manyTill,-    optional,   )-import Prelude-  ( ($),-    (.),-  ) +mkObject ::+  (ELEM OBJECT a ~ TRUE) =>+  Maybe Description ->+  TypeName ->+  [TypeName] ->+  Directives s ->+  FieldsDefinition OUT s ->+  TypeDefinition a s+mkObject typeDescription typeName objectImplements typeDirectives objectFields =+  TypeDefinition+    { typeContent = DataObject {objectImplements, objectFields},+      ..+    }+ -- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars -- --  ScalarTypeDefinition:@@ -95,15 +102,12 @@   Parse (Value s) =>   Maybe Description ->   Parser (TypeDefinition ANY s)-scalarTypeDefinition typeDescription = label "ScalarTypeDefinition" $ do-  typeName <- typeDeclaration "scalar"-  typeDirectives <- optionalDirectives-  pure-    TypeDefinition-      { typeFingerprint = DataFingerprint typeName [],-        typeContent = DataScalar $ ScalarDefinition pure,-        ..-      }+scalarTypeDefinition typeDescription =+  label "ScalarTypeDefinition" $+    TypeDefinition typeDescription+      <$> typeDeclaration "scalar"+      <*> optionalDirectives+      <*> pure (DataScalar (ScalarDefinition pure))  -- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects --@@ -123,20 +127,17 @@ objectTypeDefinition ::   Parse (Value s) =>   Maybe Description ->-  Parser (TypeDefinition OUT s)-objectTypeDefinition typeDescription = label "ObjectTypeDefinition" $ do-  typeName <- typeDeclaration "type"-  objectImplements <- optionalImplementsInterfaces-  typeDirectives <- optionalDirectives-  objectFields <- fieldsDefinition-  -- build object-  pure-    TypeDefinition-      { typeFingerprint = DataFingerprint typeName [],-        typeContent = DataObject {objectImplements, objectFields},-        ..-      }+  Parser (TypeDefinition ANY s)+objectTypeDefinition typeDescription =+  label "ObjectTypeDefinition" $+    mkObject typeDescription+      <$> typeDeclaration "type"+      <*> optionalImplementsInterfaces+      <*> optionalDirectives+      <*> fieldsDefinition +-- build object+ optionalImplementsInterfaces :: Parser [TypeName] optionalImplementsInterfaces = implements <|> pure []   where@@ -151,16 +152,13 @@ interfaceTypeDefinition ::   Parse (Value s) =>   Maybe Description ->-  Parser (TypeDefinition OUT s)-interfaceTypeDefinition typeDescription = label "InterfaceTypeDefinition" $ do-  typeName <- typeDeclaration "interface"-  typeDirectives <- optionalDirectives-  typeContent <- DataInterface <$> fieldsDefinition-  pure-    TypeDefinition-      { typeFingerprint = DataFingerprint typeName [],-        ..-      }+  Parser (TypeDefinition ANY s)+interfaceTypeDefinition typeDescription =+  label "InterfaceTypeDefinition" $+    TypeDefinition typeDescription+      <$> typeDeclaration "interface"+      <*> optionalDirectives+      <*> (DataInterface <$> fieldsDefinition)  -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions --@@ -174,19 +172,16 @@ unionTypeDefinition ::   Parse (Value s) =>   Maybe Description ->-  Parser (TypeDefinition OUT s)-unionTypeDefinition typeDescription = label "UnionTypeDefinition" $ do-  typeName <- typeDeclaration "union"-  typeDirectives <- optionalDirectives-  typeContent <- DataUnion <$> unionMemberTypes-  pure-    TypeDefinition-      { typeFingerprint = DataFingerprint typeName [],-        ..-      }+  Parser (TypeDefinition ANY s)+unionTypeDefinition typeDescription =+  label "UnionTypeDefinition" $+    TypeDefinition typeDescription+      <$> typeDeclaration "union"+      <*> optionalDirectives+      <*> (DataUnion <$> unionMemberTypes)   where     unionMemberTypes =-      symbol '='+      equal         *> pipe (mkUnionMember <$> parseTypeName)  -- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums@@ -204,15 +199,12 @@   Parse (Value s) =>   Maybe Description ->   Parser (TypeDefinition ANY s)-enumTypeDefinition typeDescription = label "EnumTypeDefinition" $ do-  typeName <- typeDeclaration "enum"-  typeDirectives <- optionalDirectives-  typeContent <- DataEnum <$> collection enumValueDefinition-  pure-    TypeDefinition-      { typeFingerprint = DataFingerprint typeName [],-        ..-      }+enumTypeDefinition typeDescription =+  label "EnumTypeDefinition" $+    TypeDefinition typeDescription+      <$> typeDeclaration "enum"+      <*> optionalDirectives+      <*> (DataEnum <$> collection enumValueDefinition)  -- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects --@@ -225,18 +217,14 @@ inputObjectTypeDefinition ::   Parse (Value s) =>   Maybe Description ->-  Parser (TypeDefinition IN s)+  Parser (TypeDefinition ANY s) inputObjectTypeDefinition typeDescription =-  label "InputObjectTypeDefinition" $ do-    typeName <- typeDeclaration "input"-    typeDirectives <- optionalDirectives-    typeContent <- DataInputObject <$> inputFieldsDefinition-    -- build input-    pure-      TypeDefinition-        { typeFingerprint = DataFingerprint typeName [],-          ..-        }+  label "InputObjectTypeDefinition" $+    TypeDefinition+      typeDescription+      <$> typeDeclaration "input"+      <*> optionalDirectives+      <*> (DataInputObject <$> inputFieldsDefinition)  -- 3.13 DirectiveDefinition --@@ -246,26 +234,20 @@ --  DirectiveLocations: --    DirectiveLocations | DirectiveLocation --    |[opt] DirectiveLocation- parseDirectiveDefinition ::+  Parse (Value s) =>   Maybe Description ->-  Parser RawTypeDefinition-parseDirectiveDefinition directiveDefinitionDescription = label "DirectiveDefinition" $ do-  keyword "directive"-  symbol '@'-  directiveDefinitionName <- parseName-  directiveDefinitionArgs <- optionalCollection argumentsDefinition-  _ <- optional (keyword "repeatable")-  keyword "on"-  directiveDefinitionLocations <- pipe parseDirectiveLocation-  pure-    $ RawDirectiveDefinition-    $ DirectiveDefinition-      { directiveDefinitionName,-        directiveDefinitionDescription,-        directiveDefinitionLocations,-        directiveDefinitionArgs-      }+  Parser (DirectiveDefinition s)+parseDirectiveDefinition directiveDefinitionDescription =+  label "DirectiveDefinition" $+    DirectiveDefinition+      <$> ( keyword "directive"+              *> at+              *> parseName+          )+        <*> pure directiveDefinitionDescription+        <*> optionalCollection argumentsDefinition+        <*> (optional (keyword "repeatable") *> keyword "on" *> pipe parseDirectiveLocation)  -- 3.2 Schema -- SchemaDefinition:@@ -280,21 +262,20 @@ --     mutation :: Maybe TypeName, --     subscription :: Maybe TypeName --   }--parseSchemaDefinition :: Maybe Description -> Parser RawTypeDefinition-parseSchemaDefinition _schemaDescription = label "SchemaDefinition" $ do-  keyword "schema"-  schemaDirectives <- optionalDirectives-  unSchemaDefinition <- setOf parseRootOperationTypeDefinition-  pure-    $ RawSchemaDefinition-    $ SchemaDefinition {schemaDirectives, unSchemaDefinition}+parseSchemaDefinition :: Maybe Description -> Parser SchemaDefinition+parseSchemaDefinition _schemaDescription =+  label "SchemaDefinition" $+    keyword "schema"+      *> ( SchemaDefinition+             <$> optionalDirectives+             <*> setOf parseRootOperationTypeDefinition+         )  parseRootOperationTypeDefinition :: Parser RootOperationTypeDefinition-parseRootOperationTypeDefinition = do-  operationType <- parseOperationType-  symbol ':'-  RootOperationTypeDefinition operationType <$> parseTypeName+parseRootOperationTypeDefinition =+  RootOperationTypeDefinition+    <$> (parseOperationType <* colon)+    <*> parseTypeName  parseTypeSystemUnit ::   Parser RawTypeDefinition@@ -303,18 +284,18 @@     do       description <- optDescription       -- scalar | enum |  input | object | union | interface-      types description-        <|> parseSchemaDefinition description-        <|> parseDirectiveDefinition description+      parseTypeDef description+        <|> RawSchemaDefinition <$> parseSchemaDefinition description+        <|> RawDirectiveDefinition <$> parseDirectiveDefinition description   where-    types description =+    parseTypeDef description =       RawTypeDefinition-        <$> ( (toAny <$> inputObjectTypeDefinition description)-                <|> (toAny <$> unionTypeDefinition description)+        <$> ( objectTypeDefinition description+                <|> inputObjectTypeDefinition description+                <|> interfaceTypeDefinition description+                <|> unionTypeDefinition description                 <|> enumTypeDefinition description                 <|> scalarTypeDefinition description-                <|> (toAny <$> objectTypeDefinition description)-                <|> (toAny <$> interfaceTypeDefinition description)             )  typePartition ::@@ -353,12 +334,13 @@ withSchemaDefinition (_ : xs, _, _) = failure (fmap nameCollision xs)  parseTypeSystemDefinition :: Parser [RawTypeDefinition]-parseTypeSystemDefinition = label "TypeSystemDefinitions" $ do-  ignoredTokens-  manyTill parseTypeSystemUnit eof+parseTypeSystemDefinition =+  label "TypeSystemDefinitions" $+    ignoredTokens+      *> manyTill parseTypeSystemUnit eof  typeSystemDefinition ::-  Text ->+  ByteString ->   Eventless     ( Maybe SchemaDefinition,       [TypeDefinition ANY CONST],@@ -368,14 +350,14 @@   processParser parseTypeSystemDefinition     >=> withSchemaDefinition . typePartition -parseTypeDefinitions :: Text -> Eventless [TypeDefinition ANY CONST]+parseTypeDefinitions :: ByteString -> Eventless [TypeDefinition ANY CONST] parseTypeDefinitions = fmap snd3 . typeSystemDefinition  snd3 :: (a, b, c) -> b snd3 (_, x, _) = x  parseSchema ::-  Text ->+  ByteString ->   Eventless (Schema CONST) parseSchema =   typeSystemDefinition

@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Internal.Arguments (maybeArguments) where @@ -9,8 +9,7 @@     getLocation,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( parseAssignment,-    parseName,+  ( fieldNameColon,     uniqTupleOpt,   ) import Data.Morpheus.Parsing.Internal.Value@@ -21,6 +20,7 @@     Arguments,     Value,   )+import Relude import Text.Megaparsec (label)  -- Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments@@ -32,10 +32,11 @@ --  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}+  label "Argument" $+    Argument+      <$> getLocation+      <*> fieldNameColon+      <*> parse  maybeArguments :: Parse (Value s) => Parser (Arguments s) maybeArguments =

@@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Internal.Internal   ( Parser,@@ -8,6 +9,7 @@   ) where +import Data.ByteString.Lazy (ByteString) import qualified Data.List.NonEmpty as NonEmpty import Data.Morpheus.Types.Internal.AST   ( GQLError (..),@@ -20,10 +22,15 @@     Result (..),     failure,   )-import Data.Text-  ( Text,+import Relude+  ( ($),+    (.),+    Applicative (..),+    Either (..),+    Functor (..),+    Void,+    fst,   )-import Data.Void (Void) import Text.Megaparsec   ( ParseError,     ParseErrorBundle@@ -51,11 +58,11 @@  type MyError = Void -type Parser = ParsecT MyError Text Eventless+type Parser = ParsecT MyError ByteString Eventless -type ErrorBundle = ParseErrorBundle Text MyError+type ErrorBundle = ParseErrorBundle ByteString MyError -processParser :: Parser a -> Text -> Eventless a+processParser :: Parser a -> ByteString -> Eventless a processParser parser txt = case runParserT parser [] txt of   Success {result} -> case result of     Right root -> pure root@@ -63,19 +70,20 @@   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+processErrorBundle = fmap parseErrorToGQLError . bundleToErrors++parseErrorToGQLError :: (ParseError ByteString MyError, SourcePos) -> GQLError+parseErrorToGQLError (err, position) =+  GQLError+    { message = msg (parseErrorPretty err),+      locations = [toLocation position]+    }++bundleToErrors ::+  ErrorBundle -> [(ParseError ByteString MyError, SourcePos)]+bundleToErrors ParseErrorBundle {bundleErrors, bundlePosState} =+  NonEmpty.toList $ fst $+    attachSourcePos+      errorOffset+      bundleErrors+      bundlePosState

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Internal.Pattern   ( inputValueDefinition,@@ -15,8 +16,6 @@   ) where -import Data.Functor (($>))--- MORPHEUS import Data.Morpheus.Parsing.Internal.Arguments   ( maybeArguments,   )@@ -25,14 +24,15 @@     getLocation,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( ignoredTokens,+  ( at,+    colon,+    ignoredTokens,     keyword,     optDescription,     parseName,     parseType,     parseTypeName,     setOf,-    symbol,     uniqTuple,   ) import Data.Morpheus.Parsing.Internal.Value@@ -42,6 +42,7 @@ import Data.Morpheus.Types.Internal.AST   ( ArgumentsDefinition (..),     DataEnumValue (..),+    Description,     Directive (..),     DirectiveLocation (..),     FieldContent (..),@@ -52,18 +53,18 @@     InputFieldsDefinition,     OUT,     OperationType (..),+    TRUE,     TypeName,+    TypeRef,     Value,   )-import Data.Text (pack)+import Relude hiding (many) import Text.Megaparsec-  ( (<|>),-    choice,+  ( choice,     label,     many,-    optional,   )-import Text.Megaparsec.Char (string)+import Text.Megaparsec.Byte (string)  --  EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition --@@ -73,11 +74,12 @@ enumValueDefinition ::   Parse (Value s) =>   Parser (DataEnumValue s)-enumValueDefinition = label "EnumValueDefinition" $ do-  enumDescription <- optDescription-  enumName <- parseTypeName-  enumDirectives <- optionalDirectives-  return DataEnumValue {..}+enumValueDefinition =+  label "EnumValueDefinition" $+    DataEnumValue+      <$> optDescription+      <*> parseTypeName+      <*> optionalDirectives  -- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition --@@ -87,14 +89,14 @@ inputValueDefinition ::   Parse (Value s) =>   Parser (FieldDefinition IN s)-inputValueDefinition = label "InputValueDefinition" $ do-  fieldDescription <- optDescription-  fieldName <- parseName-  symbol ':'-  fieldType <- parseType-  fieldContent <- optional (DefaultInputValue <$> parseDefaultValue)-  fieldDirectives <- optionalDirectives-  pure FieldDefinition {..}+inputValueDefinition =+  label "InputValueDefinition" $+    FieldDefinition+      <$> optDescription+      <*> parseName+      <*> (colon *> parseType)+      <*> optional (DefaultInputValue <$> parseDefaultValue)+      <*> optionalDirectives  -- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments --@@ -122,15 +124,25 @@ --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) -- fieldDefinition :: Parse (Value s) => Parser (FieldDefinition OUT s)-fieldDefinition = label "FieldDefinition" $ do-  fieldDescription <- optDescription-  fieldName <- parseName-  fieldContent <- optional (FieldArgs <$> argumentsDefinition)-  symbol ':'-  fieldType <- parseType-  fieldDirectives <- optionalDirectives-  pure FieldDefinition {..}+fieldDefinition =+  label "FieldDefinition" $+    mkField+      <$> optDescription+      <*> parseName+      <*> optional (FieldArgs <$> argumentsDefinition)+      <*> (colon *> parseType)+      <*> optionalDirectives +mkField ::+  Maybe Description ->+  FieldName ->+  Maybe (FieldContent TRUE cat s) ->+  TypeRef ->+  [Directive s] ->+  FieldDefinition cat s+mkField fieldDescription fieldName fieldContent fieldType fieldDirectives =+  FieldDefinition {..}+ -- InputFieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives --   InputFieldsDefinition: --     { InputValueDefinition(list) }@@ -154,12 +166,12 @@ -- -- @ Name Arguments[Const](opt) directive :: Parse (Value s) => Parser (Directive s)-directive = label "Directive" $ do-  directivePosition <- getLocation-  symbol '@'-  directiveName <- parseName-  directiveArgs <- maybeArguments-  pure Directive {..}+directive =+  label "Directive" $+    Directive+      <$> getLocation+      <*> (at *> parseName)+      <*> maybeArguments  -- typDeclaration : Not in spec ,start part of type definitions --@@ -167,18 +179,16 @@ --   Description(opt) scalar Name -- typeDeclaration :: FieldName -> Parser TypeName-typeDeclaration kind = do-  keyword kind-  parseTypeName+typeDeclaration kind = keyword kind *> parseTypeName  parseOperationType :: Parser OperationType-parseOperationType = label "OperationType" $ do-  kind <--    (string "query" $> Query)-      <|> (string "mutation" $> Mutation)-      <|> (string "subscription" $> Subscription)-  ignoredTokens-  return kind+parseOperationType =+  label "OperationType" $+    ( (string "query" $> Query)+        <|> (string "mutation" $> Mutation)+        <|> (string "subscription" $> Subscription)+    )+      <* ignoredTokens  parseDirectiveLocation :: Parser DirectiveLocation parseDirectiveLocation =@@ -209,4 +219,4 @@     <* ignoredTokens  toKeyword :: Show a => a -> Parser a-toKeyword x = string (pack $ show x) $> x+toKeyword x = string (fromString $ show x) $> x

@@ -1,13 +1,15 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Internal.Terms   ( name,     variable,+    varName,     ignoredTokens,     parseString,-    -------------     collection,     setOf,     uniqTuple,@@ -15,7 +17,6 @@     parseTypeCondition,     spreadLiteral,     parseNonNull,-    parseAssignment,     parseWrappedType,     parseAlias,     sepByAnd,@@ -28,19 +29,26 @@     parseNegativeSign,     parseTypeName,     pipe,+    fieldNameColon,+    brackets,+    equal,+    comma,+    colon,+    at,   ) where -import Control.Monad ((>=>))--- MORPHEUS-import Control.Monad.Trans (lift)-import Data.Functor (($>))+import Data.ByteString.Lazy+  ( pack,+  ) import Data.Morpheus.Internal.Utils   ( Collection,+    FromElems (..),     KeyOf,-    Listable (..),     empty,     fromElems,+    fromLBS,+    toLBS,   ) import Data.Morpheus.Parsing.Internal.Internal   ( Parser,@@ -57,26 +65,25 @@     TypeRef (..),     toHSWrappers,   )+import Data.Morpheus.Types.Internal.Resolving (Eventless) import Data.Text-  ( pack,-    strip,+  ( strip,   )+import Relude hiding (empty, many) import Text.Megaparsec   ( (<?>),-    (<|>),     between,     choice,     label,     many,     manyTill,-    optional,     sepBy,     sepBy1,     sepEndBy,     skipManyTill,     try,   )-import Text.Megaparsec.Char+import Text.Megaparsec.Byte   ( char,     digitChar,     letterChar,@@ -88,7 +95,7 @@   )  parseNegativeSign :: Parser Bool-parseNegativeSign = (char '-' $> True <* ignoredTokens) <|> pure False+parseNegativeSign = (minus $> True <* ignoredTokens) <|> pure False  parseName :: Parser FieldName parseName = FieldName <$> name@@ -97,18 +104,57 @@ parseTypeName = label "TypeName" $ TypeName <$> name  keyword :: FieldName -> Parser ()-keyword (FieldName word) = string word *> space1 *> ignoredTokens+keyword (FieldName word) = string (toLBS word) *> space1 *> ignoredTokens -symbol :: Char -> Parser ()+symbol :: Word8 -> Parser () symbol x = char x *> ignoredTokens --- LITERALS-braces :: Parser [a] -> Parser [a]-braces =-  between-    (char '{' *> ignoredTokens)-    (char '}' *> ignoredTokens)+-- braces: {}+braces :: Parser a -> Parser a+braces = between (symbol 123) (symbol 125) +-- brackets: []+brackets :: Parser a -> Parser a+brackets = between (symbol 91) (symbol 93)++-- parens : '()'+parens :: Parser a -> Parser a+parens = between (symbol 40) (symbol 41)++-- underscore : '_'+underscore :: Parser Word8+underscore = char 95++comma :: Parser ()+comma = label "," $ char 44 *> space++-- dollar :: $+dollar :: Parser ()+dollar = label "$" $ symbol 36++-- equal :: '='+equal :: Parser ()+equal = label "=" $ symbol 61++-- colon :: ':'+colon :: Parser ()+colon = label ":" $ symbol 58++-- minus: '-'+minus :: Parser ()+minus = label "-" $ symbol 45++-- verticalPipe: '|'+verticalPipe :: Parser ()+verticalPipe = label "|" $ symbol 124++ampersand :: Parser ()+ampersand = label "&" $ symbol 38++-- at: '@'+at :: Parser ()+at = label "@" $ symbol 64+ -- PRIMITIVE ------------------------------------ @@ -118,35 +164,37 @@ --  NameStart NameContinue[list,opt] -- name :: Parser Token-name = label "Name" $ do-  start <- nameStart-  continue <- nameContinue-  ignoredTokens-  pure $ pack (start : continue)+name =+  label "Name" $+    fromLBS . pack+      <$> ((:) <$> nameStart <*> nameContinue)+      <* ignoredTokens  -- NameStart:: --   Letter --   _-nameStart :: Parser Char-nameStart = letterChar <|> char '_'+nameStart :: Parser Word8+nameStart = letterChar <|> underscore  --  NameContinue:: --   Letter --   Digit-nameContinue :: Parser String-nameContinue = many (letterChar <|> char '_' <|> digitChar)+nameContinue :: Parser [Word8]+nameContinue = many (letterChar <|> underscore <|> digitChar) +varName :: Parser FieldName+varName = dollar *> parseName <* ignoredTokens+ -- Variable : https://graphql.github.io/graphql-spec/June2018/#Variable -- -- Variable :  $Name -- variable :: Parser Ref-variable = label "variable" $ do-  refPosition <- getLocation-  _ <- char '$'-  refName <- parseName-  ignoredTokens-  pure $ Ref {refName, refPosition}+variable =+  label "variable" $+    flip Ref+      <$> getLocation+      <*> varName  -- Descriptions: https://graphql.github.io/graphql-spec/June2018/#Description --@@ -165,39 +213,39 @@ blockString = stringWith (string "\"\"\"") (printChar <|> newline)  singleLineString :: Parser Token-singleLineString = stringWith (char '"') escapedChar+singleLineString = stringWith (string "\"") escapedChar -stringWith :: Parser quote -> Parser Char -> Parser Token+stringWith :: Parser quote -> Parser Word8 -> Parser Token stringWith quote parser =-  pack+  fromLBS . pack     <$> ( quote             *> manyTill parser quote             <* ignoredTokens         ) -escapedChar :: Parser Char+escapedChar :: Parser Word8 escapedChar = label "EscapedChar" $ printChar >>= handleEscape -handleEscape :: Char -> Parser Char-handleEscape '\\' = choice escape+handleEscape :: Word8 -> Parser Word8+handleEscape 92 = choice escape handleEscape x = pure x -escape :: [Parser Char]-escape = map escapeCh escapeOptions+escape :: [Parser Word8]+escape = escapeCh <$> escapeOptions   where-    escapeCh :: (Char, Char) -> Parser Char+    escapeCh :: (Word8, Word8) -> Parser Word8     escapeCh (code, replacement) = char code $> replacement -escapeOptions :: [(Char, Char)]+escapeOptions :: [(Word8, Word8)] escapeOptions =-  [ ('b', '\b'),-    ('n', '\n'),-    ('f', '\f'),-    ('r', '\r'),-    ('t', '\t'),-    ('\\', '\\'),-    ('\"', '\"'),-    ('/', '/')+  [ (98, 8),+    (110, 10),+    (102, 12),+    (114, 13),+    (116, 9),+    (92, 92),+    (34, 34),+    (47, 47)   ]  -- Ignored Tokens : https://graphql.github.io/graphql-spec/June2018/#sec-Source-Text.Ignored-Tokens@@ -215,61 +263,56 @@       *> space  ignored :: Parser ()-ignored =-  label "Ignored" $-    comment-      <|> comma+ignored = label "Ignored" (comment <|> comma)  comment :: Parser () comment =   label "Comment" $-    char '#' *> skipManyTill printChar newline *> space+    octothorpe *> skipManyTill printChar newline *> space -comma :: Parser ()-comma = label "Comma" $ char ',' *> space+-- exclamationMark: '!'+exclamationMark :: Parser ()+exclamationMark = label "!" $symbol 33 +-- octothorpe: '#'+octothorpe :: Parser ()+octothorpe = label "#" $ char 35 $> ()+ ------------------------------------------------------------------------  sepByAnd :: Parser a -> Parser [a]-sepByAnd entry = entry `sepBy` (optional (symbol '&') *> ignoredTokens)+sepByAnd entry = entry `sepBy` (optional ampersand *> ignoredTokens)  pipe :: Parser a -> Parser [a]-pipe x = optional (symbol '|') *> (x `sepBy1` symbol '|')+pipe x = optional verticalPipe *> (x `sepBy1` verticalPipe)  ----------------------------- collection :: Parser a -> Parser [a] collection entry = braces (entry `sepEndBy` ignoredTokens) -setOf :: (Listable a coll, KeyOf k a) => Parser a -> Parser coll+setOf :: (FromElems Eventless a coll, KeyOf k a) => Parser a -> Parser coll setOf = collection >=> lift . fromElems  optionalCollection :: Collection a c => Parser c -> Parser c optionalCollection x = x <|> pure empty  parseNonNull :: Parser [DataTypeWrapper]-parseNonNull = do-  wrapper <- (char '!' $> [NonNullType]) <|> pure []-  ignoredTokens-  return wrapper+parseNonNull =+  (exclamationMark $> [NonNullType])+    <|> pure [] -uniqTuple :: (Listable a coll, KeyOf k a) => Parser a -> Parser coll+uniqTuple :: (FromElems Eventless a coll, KeyOf k a) => Parser a -> Parser coll uniqTuple parser =   label "Tuple" $-    between-      (char '(' *> ignoredTokens)-      (char ')' *> ignoredTokens)+    parens       (parser `sepBy` ignoredTokens <?> "empty Tuple value!")       >>= lift . fromElems -uniqTupleOpt :: (Listable a coll, Collection a coll, KeyOf k a) => Parser a -> Parser coll+uniqTupleOpt :: (FromElems Eventless a coll, Collection a coll, KeyOf k a) => Parser a -> Parser coll uniqTupleOpt x = uniqTuple x <|> pure empty -parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b)-parseAssignment nameParser valueParser = label "assignment" $ do-  name' <- nameParser-  symbol ':'-  value' <- valueParser-  pure (name', value')+fieldNameColon :: Parser FieldName+fieldNameColon = parseName <* colon  -- Type Conditions: https://graphql.github.io/graphql-spec/June2018/#sec-Type-Conditions --@@ -277,16 +320,10 @@ --    on NamedType -- parseTypeCondition :: Parser TypeName-parseTypeCondition = do-  keyword "on"-  parseTypeName+parseTypeCondition = keyword "on" *> parseTypeName  spreadLiteral :: Parser Position-spreadLiteral = do-  index <- getLocation-  _ <- string "..."-  space-  return index+spreadLiteral = getLocation <* string "..." <* space  -- Field Alias : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Alias -- Alias@@ -294,19 +331,19 @@ parseAlias :: Parser (Maybe FieldName) parseAlias = try (optional alias) <|> pure Nothing   where-    alias = label "alias" $ parseName <* char ':' <* ignoredTokens+    alias = label "alias" fieldNameColon  parseType :: Parser TypeRef-parseType = do-  (wrappers, typeConName) <- parseWrappedType-  nonNull <- parseNonNull-  pure-    TypeRef-      { typeConName,-        typeArgs = Nothing,-        typeWrappers = toHSWrappers $ nonNull ++ wrappers-      }+parseType = parseTypeW <$> parseWrappedType <*> parseNonNull +parseTypeW :: ([DataTypeWrapper], TypeName) -> [DataTypeWrapper] -> TypeRef+parseTypeW (wrappers, typeConName) nonNull =+  TypeRef+    { typeConName,+      typeArgs = Nothing,+      typeWrappers = toHSWrappers (nonNull <> wrappers)+    }+ parseWrappedType :: Parser ([DataTypeWrapper], TypeName) parseWrappedType = (unwrapped <|> wrapped) <* ignoredTokens   where@@ -314,12 +351,7 @@     unwrapped = ([],) <$> parseTypeName <* ignoredTokens     ----------------------------------------------     wrapped :: Parser ([DataTypeWrapper], TypeName)-    wrapped =-      between-        (char '[' *> ignoredTokens)-        (char ']' *> ignoredTokens)-        ( do-            (wrappers, tName) <- unwrapped <|> wrapped-            nonNull' <- parseNonNull-            return ((ListType : nonNull') ++ wrappers, tName)-        )+    wrapped = brackets (wrapAsList <$> (unwrapped <|> wrapped) <*> parseNonNull)++wrapAsList :: ([DataTypeWrapper], TypeName) -> [DataTypeWrapper] -> ([DataTypeWrapper], TypeName)+wrapAsList (wrappers, tName) nonNull = (ListType : nonNull <> wrappers, tName)

@@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Internal.Value   ( enumValue,@@ -10,21 +10,18 @@   ) where -import Data.Functor (($>))------ MORPHEUS import Data.Morpheus.Parsing.Internal.Internal   ( Parser,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( ignoredTokens,-    parseAssignment,-    parseName,+  ( brackets,+    equal,+    fieldNameColon,+    ignoredTokens,     parseNegativeSign,     parseString,     parseTypeName,     setOf,-    symbol,     variable,   ) import Data.Morpheus.Types.Internal.AST@@ -37,18 +34,15 @@     Value (..),     decodeScientific,   )+import Relude import Text.Megaparsec-  ( (<|>),-    between,-    label,-    many,+  ( label,     sepBy,   )-import Text.Megaparsec.Char-  ( char,-    string,+import Text.Megaparsec.Byte+  ( string,   )-import Text.Megaparsec.Char.Lexer (scientific)+import Text.Megaparsec.Byte.Lexer (scientific)  valueNull :: Parser (Value a) valueNull = string "null" $> Null@@ -60,35 +54,27 @@     boolFalse = string "false" $> Scalar (Boolean False)  valueNumber :: Parser (Value a)-valueNumber = do-  isNegative <- parseNegativeSign-  Scalar . decodeScientific . signedNumber isNegative <$> scientific+valueNumber =+  Scalar . decodeScientific+    <$> (signedNumber <$> parseNegativeSign <*> scientific)   where     signedNumber isNegative number       | isNegative = - number       | otherwise = number  enumValue :: Parser (Value a)-enumValue = do-  enum <- Enum <$> parseTypeName-  ignoredTokens-  return enum+enumValue = Enum <$> parseTypeName <* ignoredTokens  stringValue :: Parser (Value a) stringValue = label "stringValue" $ Scalar . String <$> parseString  listValue :: Parser a -> Parser [a]-listValue parser =-  label "ListValue" $-    between-      (char '[' *> ignoredTokens)-      (char ']' *> ignoredTokens)-      (parser `sepBy` (many (char ',') *> ignoredTokens))+listValue parser = label "list" $ brackets (parser `sepBy` ignoredTokens)  objectEntry :: Parser (Value a) -> Parser (ObjectEntry a)-objectEntry parser = label "ObjectEntry" $ do-  (entryName, entryValue) <- parseAssignment parseName parser-  pure ObjectEntry {entryName, entryValue}+objectEntry parser =+  label "ObjectEntry" $+    ObjectEntry <$> fieldNameColon <*> parser  objectValue :: Parser (Value a) -> Parser (OrdMap FieldName (ObjectEntry a)) objectValue = label "ObjectValue" . setOf . objectEntry@@ -98,9 +84,7 @@   valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue  parseDefaultValue :: Parser (Value s)-parseDefaultValue = do-  symbol '='-  parseV+parseDefaultValue = equal *> parseV   where     parseV :: Parser (Value s)     parseV = structValue parseV

@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Request.Operation   ( parseOperation,@@ -18,11 +19,11 @@     parseOperationType,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( parseName,+  ( colon,+    parseName,     parseType,-    symbol,     uniqTupleOpt,-    variable,+    varName,   ) import Data.Morpheus.Parsing.Internal.Value   ( parseDefaultValue,@@ -34,15 +35,13 @@   ( Operation (..),     OperationType (..),     RAW,-    Ref (..),     Variable (..),     VariableContent (..),   )+import Relude hiding (empty) import Text.Megaparsec   ( (<?>),-    (<|>),     label,-    optional,   )  -- Variables :  https://graphql.github.io/graphql-spec/June2018/#VariableDefinition@@ -51,12 +50,13 @@ --    Variable : Type DefaultValue(opt) -- variableDefinition :: Parser (Variable RAW)-variableDefinition = label "VariableDefinition" $ do-  (Ref variableName variablePosition) <- variable-  symbol ':'-  variableType <- parseType-  variableValue <- DefaultValue <$> optional parseDefaultValue-  pure Variable {..}+variableDefinition =+  label "VariableDefinition" $+    Variable+      <$> getLocation+      <*> (varName <* colon)+      <*> parseType+      <*> (DefaultValue <$> optional parseDefaultValue)  -- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations --@@ -66,14 +66,15 @@ --   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 {..}+parseOperationDefinition =+  label "OperationDefinition" $+    Operation+      <$> getLocation+      <*> parseOperationType+      <*> optional parseName+      <*> uniqTupleOpt variableDefinition+      <*> optionalDirectives+      <*> parseSelectionSet  parseAnonymousQuery :: Parser (Operation RAW) parseAnonymousQuery = label "AnonymousQuery" $ do

@@ -1,17 +1,18 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Request.Parser (parseGQL) where  -- -- MORPHEUS-import Control.Monad.Trans (lift) import qualified Data.Aeson as Aeson   ( Value (..),   ) import Data.HashMap.Lazy (toList) import Data.Morpheus.Internal.Utils   ( fromElems,+    toLBS,   ) import Data.Morpheus.Parsing.Internal.Internal   ( Parser,@@ -36,21 +37,30 @@ import Data.Morpheus.Types.Internal.Resolving   ( Eventless,   )+import Relude hiding+  ( many,+    toList,+  ) import Text.Megaparsec   ( eof,     label,-    manyTill,+    many,   )  request :: Parser GQLQuery-request = label "GQLQuery" $ do-  ignoredTokens-  operation <- parseOperation-  fragments <- manyTill parseFragmentDefinition eof >>= lift . fromElems-  pure GQLQuery {operation, fragments, inputVariables = []}+request =+  label "GQLQuery" $+    ( GQLQuery []+        <$> (ignoredTokens *> parseOperation)+        <*> (many parseFragmentDefinition >>= lift . fromElems)+    )+      <* ignoredTokens+      <* eof  parseGQL :: GQLRequest -> Eventless GQLQuery-parseGQL GQLRequest {query, variables} = setVariables <$> processParser request query+parseGQL GQLRequest {query, variables} =+  setVariables+    <$> processParser request (toLBS query)   where     setVariables root = root {inputVariables = toVariableMap variables}     toVariableMap :: Maybe Aeson.Value -> [(FieldName, ResolvedValue)]

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Request.Selection   ( parseSelectionSet,@@ -39,9 +40,9 @@     SelectionContent (..),     SelectionSet,   )+import Relude import Text.Megaparsec-  ( (<|>),-    label,+  ( label,     try,   ) @@ -61,7 +62,7 @@     parseSelection =       label "Selection" $         try inlineFragment-          <|> try spread+          <|> spread           <|> parseSelectionField  -- Fields: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fields@@ -72,14 +73,13 @@ parseSelectionField :: Parser (Selection RAW) parseSelectionField =   label "SelectionField" $-    do-      selectionPosition <- getLocation-      selectionAlias <- parseAlias-      selectionName <- parseName-      selectionArguments <- maybeArguments-      selectionDirectives <- optionalDirectives-      selectionContent <- parseSelectionContent-      pure Selection {..}+    Selection+      <$> getLocation+      <*> parseAlias+      <*> parseName+      <*> maybeArguments+      <*> optionalDirectives+      <*> parseSelectionContent  parseSelectionContent :: Parser (SelectionContent RAW) parseSelectionContent =@@ -109,7 +109,7 @@ --   fragment FragmentName TypeCondition Directives(opt) SelectionSet -- parseFragmentDefinition :: Parser (Fragment RAW)-parseFragmentDefinition = label "FragmentDefinition" $ do+parseFragmentDefinition = label "Fragment" $ do   keyword "fragment"   fragmentPosition <- getLocation   fragmentName <- parseName

@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.QuasiQuoter   ( gql,@@ -13,10 +14,18 @@   ) where +import Data.ByteString.Lazy.Char8+  ( ByteString,+    pack,+    unpack,+  ) import Data.Morpheus.Error   ( gqlWarnings,     renderGQLErrors,   )+import Data.Morpheus.Internal.Utils+  ( fromLBS,+  ) import Data.Morpheus.Parser   ( parseRequest,     parseTypeSystemDefinition,@@ -25,13 +34,9 @@ import Data.Morpheus.Types.Internal.Resolving   ( Result (..),   )-import Data.Text-  ( Text,-    pack,-    unpack,-  ) import Language.Haskell.TH import Language.Haskell.TH.Quote+import Relude hiding (ByteString)  gql :: QuasiQuoter gql =@@ -43,9 +48,11 @@     }   where     notHandled things =-      error $ things ++ " are not supported by the GraphQL QuasiQuoter"+      error $+        things+          <> " are not supported by the GraphQL QuasiQuoter" -gqlExpression :: Text -> Q Exp+gqlExpression :: ByteString -> Q Exp gqlExpression queryText = case parseRequest request of   Failure errors -> fail (renderGQLErrors errors)   Success {result, warnings} ->@@ -54,7 +61,7 @@     query = unpack queryText     request =       GQLRequest-        { query = queryText,+        { query = fromLBS queryText,           operationName = Nothing,           variables = Nothing         }@@ -69,9 +76,10 @@     }   where     notHandled things =-      error $ things ++ " are not supported by the GraphQL QuasiQuoter"+      error $+        things <> " are not supported by the GraphQL QuasiQuoter" -dslExpression :: Text -> Q Exp+dslExpression :: ByteString -> Q Exp dslExpression doc = case parseTypeSystemDefinition doc of   Failure errors -> fail (renderGQLErrors errors)   Success {result, warnings} ->

@@ -11,36 +11,44 @@     renderEntry,     space,     Rendering,+    fromText,+    renderGQL,+    intercalate,+    renderInputSeq,   ) where  -- MORPHEUS  import qualified Data.Aeson as A-import Data.Foldable (null)-import Data.Functor ((<$>))-import Data.Maybe (Maybe, maybe)-import Data.Semigroup ((<>))-import Data.Text-  ( Text,+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as LB+import Data.Foldable (foldl)+import qualified Data.Text as T+import Relude hiding+  ( ByteString,     intercalate,-    pack,   )-import Data.Text.Encoding (decodeUtf8)-import Data.ByteString.Lazy (toStrict)-import Prelude-  ( (.),-    ($),-    Bool (..),-    Float,-    Int,-    fmap,-    otherwise,-    show,-  ) -type Rendering = Text+renderGQL :: RenderGQL a => a -> ByteString+renderGQL x = runRendering (render x) 0 +newtype Rendering = Rendering+  { runRendering :: Int -> ByteString+  }++instance Semigroup Rendering where+  Rendering f <> Rendering g = Rendering $ \x -> f x <> g x++instance IsString Rendering where+  fromString = Rendering . const . LB.pack++fromShow :: Show a => a -> Rendering+fromShow = fromString . show++fromText :: Text -> Rendering+fromText = fromString . T.unpack+ class RenderGQL a where   render :: a -> Rendering @@ -50,39 +58,49 @@   where   render = maybe "" render +instance RenderGQL ByteString where+  render = Rendering . const+ instance RenderGQL Int where-  render = pack . show+  render = fromShow  instance RenderGQL Float where-  render = pack . show+  render = fromShow  instance RenderGQL Text where-  render = pack . show+  render = fromShow  instance RenderGQL Bool where   render True = "true"   render False = "false"  instance RenderGQL A.Value where-  render x = decodeUtf8 $ toStrict $ A.encode x--indent :: Rendering-indent = "  "+  render = render . A.encode  space :: Rendering space = " "  newline :: Rendering-newline = "\n"+newline = "\n" <> Rendering indentionSize -indentNewline :: Rendering-indentNewline = newline <> indent+indentionSize :: (Semigroup a, IsString a) => Int -> a+indentionSize 0 = ""+indentionSize n = stimes (n * 2) " " +indent :: Rendering -> Rendering+indent (Rendering f) = Rendering $ f . (+ 1)++intercalate :: Rendering -> [Rendering] -> Rendering+intercalate (Rendering f) fs = Rendering $ \x -> LB.intercalate (f x) (map ((x &) . runRendering) fs)++indentNewline :: Rendering -> Rendering+indentNewline rendering = indent (newline <> rendering)+ renderAtNewLine :: (RenderGQL a) => [a] -> Rendering-renderAtNewLine elems = indentNewline <> intercalate indentNewline (fmap render elems)+renderAtNewLine elems = indentNewline $ intercalate newline (fmap render elems)  renderObject :: (RenderGQL a) => [a] -> Rendering-renderObject fields = " {" <> renderAtNewLine fields <> "\n}"+renderObject fields = space <> "{" <> renderAtNewLine fields <> newline <> "}"  renderMembers :: (RenderGQL a) => [a] -> Rendering renderMembers members = intercalate (space <> "|" <> space) (fmap render members)@@ -98,3 +116,13 @@   value ->   Rendering renderEntry name value = render name <> ": " <> render value++renderInputSeq ::+  (Foldable t, RenderGQL a) =>+  t a ->+  Rendering+renderInputSeq = fromMaybe "" . foldl renderValue Nothing+  where+    renderValue :: RenderGQL a => Maybe Rendering -> a -> Maybe Rendering+    renderValue Nothing value = Just (render value)+    renderValue (Just txt) value = Just (txt <> ", " <> render value)

@@ -14,21 +14,14 @@   ) where --- Morpheus--import Control.Applicative (pure)-import Control.Monad (Monad (..))-import Data.Foldable (foldr)-import Data.Functor ((<$>))-import Data.List (filter)-import Data.Maybe (Maybe (..), isJust, maybe) import Data.Morpheus.Internal.Utils   ( Failure,     elems,     failure,+    fromLBS,     selectBy,   )-import qualified Data.Morpheus.Rendering.RenderGQL as GQL (RenderGQL (..))+import qualified Data.Morpheus.Rendering.RenderGQL as GQL import Data.Morpheus.Types.Internal.AST   ( ANY,     ArgumentsDefinition (..),@@ -77,15 +70,8 @@     mkString,     unsafeInternalContext,   )-import Data.Semigroup ((<>)) import Data.Text (pack)-import Data.Traversable (traverse)-import Prelude-  ( ($),-    (.),-    Bool,-    show,-  )+import Relude  class   ( Monad m,@@ -133,7 +119,7 @@   render = pure . mkBoolean  instance RenderIntrospection TypeKind where-  render = pure . mkString . GQL.render+  render = pure . mkString . fromLBS . GQL.renderGQL  instance RenderIntrospection (DirectiveDefinition VALID) where   render@@ -217,7 +203,7 @@  instance RenderIntrospection (Value VALID) where   render Null = pure mkNull-  render x = pure $ mkString $ GQL.render x+  render x = pure $ mkString $ fromLBS $ GQL.renderGQL x  instance   RenderIntrospection

@@ -5,9 +5,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Schema.DSL (dsl) where +import Data.ByteString.Lazy.Char8+  ( ByteString,+    pack,+  ) import Data.Morpheus.Error   ( gqlWarnings,     renderGQLErrors,@@ -18,12 +23,9 @@ import Data.Morpheus.Types.Internal.Resolving   ( Result (..),   )-import Data.Text-  ( Text,-    pack,-  ) import Language.Haskell.TH import Language.Haskell.TH.Quote+import Relude hiding (ByteString)  dsl :: QuasiQuoter dsl =@@ -34,10 +36,9 @@       quoteDec = notHandled "Declarations"     }   where-    notHandled things =-      error $ things ++ " are not supported by the GraphQL QuasiQuoter"+    notHandled things = error $ things <> " are not supported by the GraphQL QuasiQuoter" -dslExpression :: Text -> Q Exp+dslExpression :: ByteString -> Q Exp dslExpression doc = case parseSchema doc of   Failure errors -> fail (renderGQLErrors errors)   Success {result, warnings} -> gqlWarnings warnings >> [|result|]

@@ -8,36 +8,21 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Schema.Schema   ( internalSchema,   ) where --- MORPHEUS- import Data.Morpheus.Schema.DSL (dsl) import Data.Morpheus.Types.Internal.AST-  ( DataFingerprint (..),-    Schema (..),-    TypeDefinition (..),-    internalFingerprint,+  ( Schema,   ) -toInternalSchema :: Schema s -> Schema s-toInternalSchema Schema {..} = Schema {types = fmap toInternalType types, ..}--toInternalType :: TypeDefinition a s -> TypeDefinition a s-toInternalType-  tyDef@TypeDefinition-    { typeFingerprint = DataFingerprint name xs-    } =-    tyDef {typeFingerprint = internalFingerprint name xs}- internalSchema :: Schema s internalSchema =-  toInternalSchema-    [dsl|+  [dsl|  """ Directs the executor to skip this field or fragment when the `if` argument is true.

@@ -3,16 +3,16 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Schema.SchemaAPI   ( withSystemFields,   ) where --- MORPHEUS+import Data.Morpheus.Ext.SemigroupM ((<:>)) import Data.Morpheus.Internal.Utils-  ( (<.>),-    elems,+  ( elems,     empty,     selectOr,   )@@ -45,6 +45,7 @@     mkObject,     withArguments,   )+import Relude hiding (empty)  resolveTypes ::   Monad m => Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)@@ -103,6 +104,6 @@ withSystemFields schema RootResModel {query, ..} =   pure $     RootResModel-      { query = query >>= (<.> schemaAPI schema),+      { query = query >>= (<:> schemaAPI schema),         ..       }

@@ -16,14 +16,10 @@   ) where -import Control.Applicative (Applicative (..))-import Control.Monad (Monad) import qualified Data.Aeson as A-import qualified Data.ByteString.Lazy.Char8 as LBS-import Data.Functor ((<$>), Functor (..))+import Data.Morpheus.Ext.SemigroupM ((<:>)) import Data.Morpheus.Internal.Utils-  ( (<:>),-    empty,+  ( empty,     failure,     prop,   )@@ -66,15 +62,7 @@   ) import Data.Morpheus.Types.Internal.Stitching (Stitching (..)) import Data.Morpheus.Validation.Document.Validation (ValidateSchema (..))-import Data.Semigroup (Semigroup (..))-import Data.Text (pack)-import Prelude-  ( ($),-    (.),-    Bool (..),-    Maybe (..),-    const,-  )+import Relude hiding (empty)  mkApp :: ValidateSchema s => Schema s -> RootResModel e m -> App e m mkApp appSchema appResolvers =@@ -89,7 +77,7 @@  instance RenderGQL (App e m) where   render App {app} = render app-  render FailApp {appErrors} = pack $ LBS.unpack (A.encode appErrors)+  render FailApp {appErrors} = render (A.encode appErrors)  instance Monad m => Semigroup (App e m) where   (FailApp err1) <> (FailApp err2) = FailApp (err1 <> err2)@@ -133,7 +121,7 @@ validateReq inputSchema config request = cleanEvents $ ResultT $ pure $ do   validSchema <- validateSchema True config inputSchema   schema <- internalSchema <:> validSchema-  operation <- parseRequestWith config schema request+  operation <- parseRequestWith config validSchema request   pure $     ResolverContext       { schema,

@@ -12,9 +12,7 @@   ) where -import Control.Monad.Fail (MonadFail (..)) import qualified Data.Aeson as A-import Data.Either (Either (..), either) import Data.Morpheus.Types.Internal.AST   ( ScalarDefinition (..),     ScalarValue (..),@@ -22,18 +20,8 @@     Value (..),     replaceValue,   )-import Data.Text (Text, unpack)-import Prelude-  ( ($),-    (.),-    Bool,-    Float,-    Int,-    Monad,-    fromInteger,-    pure,-    toInteger,-  )+import Data.Text (unpack)+import Relude  toScalar :: ValidValue -> Either Text ScalarValue toScalar (Scalar x) = pure x

@@ -17,18 +17,8 @@ import Data.Morpheus.Types.Internal.AST   ( ScalarValue (..),   )-import Data.Text-  ( Text,-    pack,-  )-import GHC.Generics (Generic)-import Prelude-  ( ($),-    Either (..),-    Eq,-    Show (..),-    pure,-  )+import Data.Text (pack)+import Relude  -- | default GraphQL type, -- parses only 'String' and 'Int' values,

@@ -15,10 +15,6 @@   ) where --- MORPHEUS--import Control.Applicative (Applicative (..))-import Control.Monad.Fail (fail) import Data.Aeson   ( (.:?),     (.=),@@ -40,30 +36,22 @@   ( eitherDecodeWith,     jsonNoDup,   )-import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB   ( ByteString,     fromStrict,     toStrict,   )-import Data.Either (Either (..))-import Data.Functor ((<$>), fmap) import qualified Data.HashMap.Lazy as LH-  ( toList,-  )-import Data.Maybe (Maybe (..)) 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,@@ -73,8 +61,10 @@   ( decodeUtf8,     encodeUtf8,   )-import GHC.Generics (Generic)-import Prelude (($), (.), Show, String)+import Relude hiding+  ( decodeUtf8,+    encodeUtf8,+  )  decodeNoDup :: Failure String m => LB.ByteString -> m GQLRequest decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of@@ -102,7 +92,7 @@   mapAPI api = fmap LT.toStrict . mapAPI api . LT.fromStrict  renderResponse :: Result e ValidValue -> GQLResponse-renderResponse (Failure errors) = Errors errors+renderResponse (Failure errors) = Errors (sortOn locations errors) renderResponse Success {result} = Data result  instance FromJSON a => FromJSON (JSONResponse a) where@@ -118,8 +108,8 @@  -- | GraphQL HTTP Request Body data GQLRequest = GQLRequest-  { query :: Token,-    operationName :: Maybe FieldName,+  { operationName :: Maybe FieldName,+    query :: Text,     variables :: Maybe Aeson.Value   }   deriving (Show, Generic, FromJSON, ToJSON)

@@ -5,8 +5,7 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST-  ( -- BASE-    Ref (..),+  ( Ref (..),     Position (..),     Message,     anonymousRef,@@ -16,7 +15,6 @@     CONST,     VALID,     RAW,-    -- VALUE     Value (..),     ScalarValue (..),     Object,@@ -33,7 +31,6 @@     ResolvedValue,     splitDuplicates,     removeDuplicates,-    -- Selection     Argument (..),     Arguments,     SelectionSet,@@ -41,13 +38,11 @@     Selection (..),     Fragments,     Fragment (..),-    -- OPERATION     Operation (..),     Variable (..),     VariableDefinitions,     DefaultValue,     getOperationName,-    -- DSL     ScalarDefinition (..),     DataEnum,     FieldsDefinition,@@ -61,7 +56,6 @@     Schema (..),     DataTypeWrapper (..),     TypeKind (..),-    DataFingerprint (..),     TypeWrapper (..),     TypeRef (..),     DataEnumValue (..),@@ -96,9 +90,7 @@     lookupDeprecated,     lookupDeprecatedReason,     lookupWith,-    -- Template Haskell     hsTypeName,-    -- LOCAL     GQLQuery (..),     Variables,     unsafeFromFields,@@ -108,7 +100,6 @@     ObjectEntry (..),     UnionTag (..),     __inputname,-    internalFingerprint,     ANY,     IN,     OUT,@@ -125,7 +116,6 @@     toFieldName,     TypeNameRef (..),     isEnum,-    Fields (..),     fieldsToArguments,     mkCons,     mkConsEnum,@@ -166,18 +156,16 @@     possibleTypes,     possibleInterfaceTypes,     mkField,-    isTypeDefined,     safeDefineType,+    defineSchemaWith,   ) where  import Data.HashMap.Lazy (HashMap)--- Morpheus-+import Data.Morpheus.Ext.OrdMap import Data.Morpheus.Types.Internal.AST.Base import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..)) import Data.Morpheus.Types.Internal.AST.Fields-import Data.Morpheus.Types.Internal.AST.OrdMap import Data.Morpheus.Types.Internal.AST.Selection import Data.Morpheus.Types.Internal.AST.Stage import Data.Morpheus.Types.Internal.AST.TH@@ -190,8 +178,8 @@ type Variables = HashMap FieldName ResolvedValue  data GQLQuery = GQLQuery-  { fragments :: Fragments RAW,+  { inputVariables :: [(FieldName, ResolvedValue)],     operation :: Operation RAW,-    inputVariables :: [(FieldName, ResolvedValue)]+    fragments :: Fragments RAW   }   deriving (Show, Lift)

@@ -25,7 +25,6 @@     MUTATION,     SUBSCRIPTION,     TypeKind (..),-    DataFingerprint (..),     DataTypeWrapper (..),     Token,     anonymousRef,@@ -44,7 +43,6 @@     removeDuplicates,     GQLError (..),     GQLErrors,-    internalFingerprint,     TRUE,     FALSE,     TypeName (..),@@ -72,16 +70,13 @@     Value,     encode,   )-import Data.ByteString.Lazy.Char8 (ByteString, unpack)+import Data.ByteString.Lazy (ByteString) import Data.Char (toLower)-import Data.Hashable (Hashable)-import Data.Maybe (Maybe (..), maybeToList)-import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..))-import Data.Semigroup (Semigroup (..))-import Data.String (IsString (..))-import Data.Text (Text, intercalate, pack)+import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..), Rendering, fromText, renderGQL)+import Data.Text (intercalate, pack) import qualified Data.Text as T-import GHC.Generics (Generic)+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Encoding (decodeUtf8) import Language.Haskell.TH   ( ExpQ,     stringE,@@ -92,23 +87,10 @@     TExp,     unsafeTExpCoerce,   )-import Prelude-  ( ($),-    (&&),-    (.),-    Bool (..),-    Eq (..),-    Functor (..),-    Int,-    Ord (..),-    Show (..),-    String,-    elem,-    fst,-    id,-    not,-    notElem,-    otherwise,+import Relude hiding+  ( ByteString,+    decodeUtf8,+    intercalate,   )  type TRUE = 'True@@ -189,7 +171,7 @@   msg = Message . pack  instance Msg ByteString where-  msg = msg . unpack+  msg = Message . LT.toStrict . decodeUtf8  instance Msg Text where   msg = Message@@ -219,7 +201,7 @@   msg FieldName {readName} = Message $ "\"" <> readName <> "\""  instance RenderGQL FieldName where-  render = readName+  render = fromText . readName  intercalateName :: FieldName -> [FieldName] -> FieldName intercalateName (FieldName x) = FieldName . intercalate x . fmap readName@@ -259,7 +241,7 @@   msg TypeName {readTypeName} = Message $ "\"" <> readTypeName <> "\""  instance RenderGQL TypeName where-  render = readTypeName+  render = fromText . readTypeName  -- Description type Description = Text@@ -270,6 +252,9 @@   }   deriving (Show, Generic, FromJSON, ToJSON, Lift) +instance Ord Position where+  compare x y = compare (line x) (line y)+ -- Positions 2 Value withs same structire -- but different Positions should be Equal instance Eq Position where@@ -283,11 +268,6 @@  type GQLErrors = [GQLError] -data DataFingerprint = DataFingerprint TypeName [String] deriving (Show, Eq, Ord, Lift)--internalFingerprint :: TypeName -> [String] -> DataFingerprint-internalFingerprint name = DataFingerprint ("SYSTEM.INTERNAL." <> name)- data OperationType   = Query   | Subscription@@ -295,7 +275,7 @@   deriving (Show, Eq, Lift, Generic, Hashable)  instance RenderGQL OperationType where-  render = pack . fmap toLower . show+  render = fromString . fmap toLower . show  instance Msg OperationType where   msg Query = msg ("query" :: TypeName)@@ -351,7 +331,7 @@   render TypeRef {typeConName, typeWrappers} = renderWrapped typeConName typeWrappers  instance Msg TypeRef where-  msg = msg . FieldName . render+  msg = msg . FieldName . LT.toStrict . decodeUtf8 . renderGQL  -- Kind -----------------------------------------------------------------------------------@@ -438,7 +418,7 @@ toHSWrappers [] = [TypeMaybe] toHSWrappers [NonNullType] = [] -renderWrapped :: RenderGQL a => a -> [TypeWrapper] -> Token+renderWrapped :: RenderGQL a => a -> [TypeWrapper] -> Rendering renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers)   where     showGQLWrapper [] = render x

@@ -8,7 +8,8 @@  import Data.Morpheus.Types.Internal.AST.Base (Msg (..)) import Language.Haskell.TH.Syntax (Lift)-import Prelude ((.), Eq, Show (..))+import Relude hiding (Show, show)+import Prelude (Show (..))  data DirectiveLocation   = QUERY

@@ -1,10 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -13,7 +11,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST.Fields@@ -23,7 +20,6 @@     ArgumentsDefinition (..),     FieldDefinition (..),     FieldsDefinition,-    Fields (..),     FieldContent (..),     InputFieldsDefinition,     DirectiveDefinitions,@@ -39,31 +35,35 @@     mkInputValue,     mkObjectField,     mkField,+    renderArgumentValues,+    renderDirectives,   ) where --- MORPHEUS--import Data.Foldable (Foldable)-import Data.Functor ((<$>), Functor (..))-import Data.List (find)-import Data.Maybe (Maybe (..)) import Data.Morpheus.Error.NameCollision   ( NameCollision (..),   )+import Data.Morpheus.Ext.OrdMap+  ( OrdMap,+    unsafeFromList,+  ) import Data.Morpheus.Internal.Utils   ( Collection (..),+    Elems (..),+    Failure,+    FromElems (..),     KeyOf (..),-    Listable (..),-    Merge (..),     Selectable (..),-    elems,+    toPair,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),+    Rendering,+    intercalate,     renderArguments,     renderEntry,     renderObject,+    space,   ) import Data.Morpheus.Types.Internal.AST.Base   ( Description,@@ -77,14 +77,11 @@     TypeRef (..),     TypeWrapper (..),     ValidationError (..),+    ValidationErrors,     msgValidation,     sysFields,   ) import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation)-import Data.Morpheus.Types.Internal.AST.OrdMap-  ( OrdMap,-    unsafeFromValues,-  ) import Data.Morpheus.Types.Internal.AST.Stage   ( Stage,   )@@ -101,25 +98,15 @@   ( ScalarValue (..),     Value (..),   )-import Data.Semigroup (Semigroup ((<>)))-import Data.Traversable (Traversable) import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift (..))-import Prelude-  ( ($),-    (.),-    Bool (..),-    Eq,-    Show,-    filter,-    notElem,-  )+import Relude hiding (empty, intercalate)  -- scalar ------------------------------------------------------------------ data Argument (valid :: Stage) = Argument-  { argumentName :: FieldName,-    argumentPosition :: Position,+  { argumentPosition :: Position,+    argumentName :: FieldName,     argumentValue :: Value valid   }   deriving (Show, Eq, Lift)@@ -140,11 +127,17 @@  type Arguments (s :: Stage) = OrdMap FieldName (Argument s) +renderArgumentValues :: Arguments s -> Rendering+renderArgumentValues = renderArguments . filter notNull . elems+  where+    notNull Argument {argumentValue = Null} = False+    notNull _ = True+ -- directive ------------------------------------------------------------------ data Directive (s :: Stage) = Directive-  { directiveName :: FieldName,-    directivePosition :: Position,+  { directivePosition :: Position,+    directiveName :: FieldName,     directiveArgs :: Arguments s   }   deriving (Show, Lift, Eq)@@ -152,13 +145,28 @@ instance KeyOf FieldName (Directive s) where   keyOf = directiveName +instance RenderGQL (Directive s) where+  render Directive {..} =+    "@" <> render directiveName+      <> renderArgumentValues directiveArgs+ type Directives s = [Directive s] +renderDirectives :: Directives s -> Rendering+renderDirectives xs+  | null dirs = ""+  | otherwise = space <> intercalate space (fmap render dirs)+  where+    dirs = filter notSystem xs+    notSystem Directive {directiveName = "include"} = False+    notSystem Directive {directiveName = "skip"} = False+    notSystem _ = True+ data DirectiveDefinition s = DirectiveDefinition   { directiveDefinitionName :: FieldName,     directiveDefinitionDescription :: Maybe Description,-    directiveDefinitionLocations :: [DirectiveLocation],-    directiveDefinitionArgs :: ArgumentsDefinition s+    directiveDefinitionArgs :: ArgumentsDefinition s,+    directiveDefinitionLocations :: [DirectiveLocation]   }   deriving (Show, Lift) @@ -197,33 +205,11 @@   toCategory (FieldArgs x) = FieldArgs x   toCategory (DefaultInputValue x) = DefaultInputValue x -newtype Fields def = Fields-  {unFields :: OrdMap FieldName def}-  deriving-    ( Show,-      Lift,-      Functor,-      Foldable,-      Traversable-    )--deriving instance (KeyOf FieldName def) => Collection def (Fields def)--instance Merge (FieldsDefinition cat s) where-  merge path (Fields x) (Fields y) = Fields <$> merge path x y--instance Selectable FieldName (FieldDefinition cat s) (Fields (FieldDefinition cat s)) where-  selectOr fb f name (Fields lib) = selectOr fb f name lib- unsafeFromFields :: [FieldDefinition cat s] -> FieldsDefinition cat s-unsafeFromFields = Fields . unsafeFromValues+unsafeFromFields = unsafeFromList . fmap toPair  fieldsToArguments :: FieldsDefinition IN s -> ArgumentsDefinition s-fieldsToArguments = ArgumentsDefinition Nothing . unFields--instance (KeyOf FieldName def, NameCollision def) => Listable def (Fields def) where-  fromElems = fmap Fields . fromElems-  elems = elems . unFields+fieldsToArguments = ArgumentsDefinition Nothing  -- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects ------------------------------------------------------------------------------@@ -237,7 +223,7 @@ --  FieldsDefinition --    { FieldDefinition(list) } ---type FieldsDefinition cat s = Fields (FieldDefinition cat s)+type FieldsDefinition cat s = OrdMap FieldName (FieldDefinition cat s)  --  FieldDefinition --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)@@ -246,11 +232,11 @@ --   Description(opt) Name: Type DefaultValue(opt) Directives[Const](opt)  data FieldDefinition (cat :: TypeCategory) (s :: Stage) = FieldDefinition-  { fieldName :: FieldName,-    fieldDescription :: Maybe Description,+  { fieldDescription :: Maybe Description,+    fieldName :: FieldName,     fieldType :: TypeRef,-    fieldDirectives :: [Directive s],-    fieldContent :: Maybe (FieldContent TRUE cat s)+    fieldContent :: Maybe (FieldContent TRUE cat s),+    fieldDirectives :: [Directive s]   }   deriving (Show, Lift, Eq) @@ -286,8 +272,8 @@     "There can Be only One field Named " <> msgValidation fieldName  instance RenderGQL (FieldDefinition cat s) where-  render FieldDefinition {fieldName = FieldName name, fieldType, fieldContent = Just (FieldArgs args)} =-    name <> render args <> ": " <> render fieldType+  render FieldDefinition {fieldName, fieldType, fieldContent = Just (FieldArgs args)} =+    render fieldName <> render args <> ": " <> render fieldType   render FieldDefinition {fieldName, fieldType} =     renderEntry fieldName fieldType @@ -339,7 +325,7 @@ --- InputFieldsDefinition -- { InputValueDefinition(list) } -type InputFieldsDefinition s = Fields (InputValueDefinition s)+type InputFieldsDefinition s = OrdMap FieldName (InputValueDefinition s)  type InputValueDefinition = FieldDefinition IN @@ -366,6 +352,8 @@   empty = ArgumentsDefinition Nothing empty   singleton = ArgumentsDefinition Nothing . singleton -instance Listable (ArgumentDefinition s) (ArgumentsDefinition s) where-  elems (ArgumentsDefinition _ args) = elems args+instance (Monad m, Failure ValidationErrors m) => FromElems m (ArgumentDefinition s) (ArgumentsDefinition s) where   fromElems args = ArgumentsDefinition Nothing <$> fromElems args++instance Elems (ArgumentDefinition s) (ArgumentsDefinition s) where+  elems (ArgumentsDefinition _ args) = elems args

@@ -1,152 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Types.Internal.AST.MergeSet-  ( MergeSet,-    toOrdMap,-    concatTraverse,-    join,-  )-where---- MORPHEUS--import Control.Applicative (Applicative (..))-import Control.Monad (Monad (..))-import Data.Foldable (Foldable (..))-import Data.Functor (Functor (..))-import Data.List (find)-import Data.Maybe (maybe)-import Data.Morpheus.Internal.Utils-  ( (<:>),-    Collection (..),-    Failure (..),-    KeyOf (..),-    Listable (..),-    Merge (..),-    Selectable (..),-    elems,-    fromListT,-    mergeT,-    resolveWith,-    runResolutionT,-  )-import Data.Morpheus.Types.Internal.AST.Base-  ( Ref,-    ValidationErrors,-  )-import Data.Morpheus.Types.Internal.AST.OrdMap-  ( OrdMap (..),-  )-import qualified Data.Morpheus.Types.Internal.AST.OrdMap as OM-import Data.Morpheus.Types.Internal.AST.Stage-  ( RAW,-    Stage,-    VALID,-  )-import Data.Semigroup (Semigroup (..))-import Data.Traversable (Traversable (..))-import Language.Haskell.TH.Syntax (Lift (..))-import Prelude-  ( ($),-    (.),-    Eq (..),-    Show,-    otherwise,-  )---- 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 k b,-    Monad m,-    Failure ValidationErrors 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 k a,-    Merge a,-    Monad m,-    Failure ValidationErrors 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)--toOrdMap :: (KeyOf k a) => MergeSet opt a -> OrdMap k a-toOrdMap = OM.unsafeFromValues . unpack--instance (KeyOf k a) => Selectable k a (MergeSet opt a) where-  selectOr fb f key (MergeSet ls) = maybe fb f (find ((key ==) . keyOf) ls)---- must merge files on collision--instance-  ( KeyOf k a,-    Listable a (MergeSet VALID a),-    Merge a,-    Eq a-  ) =>-  Merge (MergeSet VALID a)-  where-  merge path x y = runResolutionT (mergeT x y) MergeSet (resolveWith (resolveConflict path))--instance-  ( Listable a (MergeSet VALID a),-    KeyOf k a,-    Merge a,-    Eq a-  ) =>-  Listable a (MergeSet VALID a)-  where-  fromElems xs = runResolutionT (fromListT xs) MergeSet (resolveWith (resolveConflict []))-  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--resolveConflict :: (Monad m, Eq a, KeyOf k a, Merge a, Failure ValidationErrors m) => [Ref] -> a -> a -> m a-resolveConflict path oldValue newValue-  | oldValue == newValue = pure oldValue-  | otherwise = merge path oldValue newValue

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

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

@@ -29,10 +29,6 @@   ) where -import Control.Applicative (pure)-import Data.Foldable (all, foldr)-import Data.Functor ((<$>), fmap)-import Data.Maybe (Maybe (..), fromMaybe, isJust, maybe) import Data.Morpheus.Error.NameCollision   ( NameCollision (..),   )@@ -40,16 +36,22 @@   ( mutationIsNotDefined,     subscriptionIsNotDefined,   )+import Data.Morpheus.Ext.MergeSet+  ( MergeSet,+  )+import Data.Morpheus.Ext.OrdMap+  ( OrdMap,+  )+import Data.Morpheus.Ext.SemigroupM (SemigroupM (..)) import Data.Morpheus.Internal.Utils   ( Failure (..),     KeyOf (..),-    Merge (..),     elems,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),     Rendering,-    renderArguments,+    newline,     renderObject,     space,   )@@ -71,12 +73,8 @@ import Data.Morpheus.Types.Internal.AST.Fields   ( Arguments,     Directives,-  )-import Data.Morpheus.Types.Internal.AST.MergeSet-  ( MergeSet,-  )-import Data.Morpheus.Types.Internal.AST.OrdMap-  ( OrdMap,+    renderArgumentValues,+    renderDirectives,   ) import Data.Morpheus.Types.Internal.AST.Stage   ( RAW,@@ -95,15 +93,8 @@     Variable (..),     VariableDefinitions,   )-import Data.Semigroup ((<>)) import Language.Haskell.TH.Syntax (Lift (..))-import Prelude-  ( ($),-    (.),-    Eq (..),-    Show (..),-    otherwise,-  )+import Relude  data Fragment (stage :: Stage) = Fragment   { fragmentName :: FieldName,@@ -140,12 +131,15 @@   render (UnionSelection unionSets) = renderObject (elems unionSets)  instance-  Merge (SelectionSet s) =>-  Merge (SelectionContent s)+  ( Monad m,+    Failure ValidationErrors m,+    SemigroupM m (SelectionSet s)+  ) =>+  SemigroupM m (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 currentC+  mergeM path (SelectionSet s1) (SelectionSet s2) = SelectionSet <$> mergeM path s1 s2+  mergeM path (UnionSelection u1) (UnionSelection u2) = UnionSelection <$> mergeM path u1 u2+  mergeM path oldC currentC     | oldC == currentC = pure oldC     | otherwise =       failure@@ -174,7 +168,6 @@   render UnionTag {unionTagName, unionTagSelection} =     "... on "       <> render unionTagName-      <> space       <> renderSelectionSet unionTagSelection  mergeConflict :: [Ref] -> ValidationError -> ValidationErrors@@ -195,22 +188,22 @@         renderStart         xs -instance Merge UnionTag where-  merge path (UnionTag oldTag oldSel) (UnionTag _ currentSel) =-    UnionTag oldTag <$> merge path oldSel currentSel+instance (Monad m, Failure ValidationErrors m) => SemigroupM m UnionTag where+  mergeM path (UnionTag oldTag oldSel) (UnionTag _ currentSel) =+    UnionTag oldTag <$> mergeM path oldSel currentSel -type UnionSelection (s :: Stage) = MergeSet s UnionTag+type UnionSelection (s :: Stage) = MergeSet s TypeName UnionTag -type SelectionSet (s :: Stage) = MergeSet s (Selection s)+type SelectionSet (s :: Stage) = MergeSet s FieldName (Selection s)  data Selection (s :: Stage) where   Selection ::-    { selectionName :: FieldName,+    { selectionPosition :: Position,       selectionAlias :: Maybe FieldName,-      selectionPosition :: Position,+      selectionName :: FieldName,       selectionArguments :: Arguments s,-      selectionContent :: SelectionContent s,-      selectionDirectives :: Directives s+      selectionDirectives :: Directives s,+      selectionContent :: SelectionContent s     } ->     Selection s   InlineFragment :: Fragment RAW -> Selection RAW@@ -222,7 +215,8 @@       { ..       } =       render (fromMaybe selectionName selectionAlias)-        <> renderArguments (elems selectionArguments)+        <> renderArgumentValues selectionArguments+        <> renderDirectives selectionDirectives         <> render selectionContent  instance KeyOf FieldName (Selection s) where@@ -239,10 +233,13 @@     <> "fields to fetch both if this was intentional."  instance-  Merge (SelectionSet a) =>-  Merge (Selection a)+  ( Monad m,+    SemigroupM m (SelectionSet a),+    Failure ValidationErrors m+  ) =>+  SemigroupM m (Selection a)   where-  merge+  mergeM     path     old@Selection {selectionPosition = pos1}     current@Selection {selectionPosition = pos2} =@@ -250,7 +247,7 @@         selectionName <- mergeName         let currentPath = path <> [Ref selectionName pos1]         selectionArguments <- mergeArguments currentPath-        selectionContent <- merge currentPath (selectionContent old) (selectionContent current)+        selectionContent <- mergeM currentPath (selectionContent old) (selectionContent current)         pure $           Selection             { selectionAlias = mergeAlias,@@ -295,7 +292,7 @@                 { validationMessage = "they have differing arguments. " <> useDifferentAliases,                   validationLocations = [pos1, pos2]                 }-  merge path _ _ =+  mergeM path _ _ =     failure $       mergeConflict         path@@ -310,12 +307,12 @@ type DefaultValue = Maybe ResolvedValue  data Operation (s :: Stage) = Operation-  { operationName :: Maybe FieldName,+  { operationPosition :: Position,     operationType :: OperationType,+    operationName :: Maybe FieldName,     operationArguments :: VariableDefinitions s,-    operationSelection :: SelectionSet s,-    operationPosition :: Position,-    operationDirectives :: Directives s+    operationDirectives :: Directives s,+    operationSelection :: SelectionSet s   }   deriving (Show, Lift) @@ -324,13 +321,14 @@     Operation       { operationName,         operationType,+        operationDirectives,         operationSelection       } =       render operationType-        <> space-        <> render operationName-        <> space+        <> maybe "" ((space <>) . render) operationName+        <> renderDirectives operationDirectives         <> renderSelectionSet operationSelection+        <> newline  getOperationName :: Maybe FieldName -> TypeName getOperationName = maybe "AnonymousOperation" (TypeName . readName)

@@ -25,14 +25,7 @@ import Data.Morpheus.Types.Internal.AST.TypeSystem   ( DataEnumValue (..),   )-import Prelude-  ( (.),-    Bool (..),-    Show,-    all,-    fmap,-    null,-  )+import Relude  toHSFieldDefinition :: FieldDefinition cat s -> FieldDefinition cat s toHSFieldDefinition field@FieldDefinition {fieldType = tyRef@TypeRef {typeConName}} =

@@ -22,13 +22,12 @@   ) where -import Data.Maybe (Maybe (..)) import Data.Morpheus.Types.Internal.AST.Base   ( FALSE,     TRUE,   ) import Data.Morpheus.Types.Internal.AST.Stage (Stage)-import Prelude (Bool (..))+import Relude  data TypeCategory   = IN

@@ -51,44 +51,46 @@     typed,     possibleTypes,     possibleInterfaceTypes,-    isTypeDefined,     safeDefineType,+    defineSchemaWith,   ) where  -- MORPHEUS--import Control.Applicative ((<|>), Applicative (..))-import Control.Monad (Monad (..), foldM)-import Data.Either (Either (..))-import Data.Foldable (concatMap)-import Data.Functor ((<$>), fmap)-import Data.List (elem, filter, find, notElem)-import Data.Maybe (Maybe (..), catMaybes, mapMaybe, maybe)+import Control.Monad (foldM) import Data.Morpheus.Error.NameCollision   ( NameCollision (..),   )-import Data.Morpheus.Internal.Utils+import Data.Morpheus.Ext.OrdMap+  ( OrdMap,+  )+import Data.Morpheus.Ext.SafeHashMap+  ( SafeHashMap,+    insert,+  )+import Data.Morpheus.Ext.SemigroupM   ( (<:>),-    Collection (..),+    SemigroupM (..),+  )+import Data.Morpheus.Internal.Utils+  ( Collection (..),+    Elems (..),     Failure (..),+    FromElems (..),     KeyOf (..),-    Listable (..),-    Merge (..),     Selectable (..),-    elems,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),     Rendering,+    intercalate,     newline,     renderEntry,     renderMembers,     renderObject,   ) import Data.Morpheus.Types.Internal.AST.Base-  ( DataFingerprint (..),-    Description,+  ( Description,     FieldName,     FieldName (..),     Msg (..),@@ -116,13 +118,6 @@     FieldsDefinition,     unsafeFromFields,   )-import Data.Morpheus.Types.Internal.AST.OrdMap-  ( OrdMap,-  )-import Data.Morpheus.Types.Internal.AST.SafeHashMap-  ( SafeHashMap,-    insert,-  ) import Data.Morpheus.Types.Internal.AST.Stage   ( CONST,     Stage,@@ -145,19 +140,14 @@ import Data.Morpheus.Types.Internal.AST.Value   ( Value (..),   )-import Data.Semigroup (Semigroup (..))-import Data.Text (intercalate) import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift (..))-import Prelude-  ( ($),-    (.),-    Bool (..),-    Eq (..),-    Show (..),-    flip,-    otherwise,+import Relude hiding+  ( empty,+    intercalate,+    show,   )+import Prelude (Show (..))  type DataEnum s = [DataEnumValue s] @@ -216,8 +206,8 @@  -- ENUM VALUE data DataEnumValue s = DataEnumValue-  { enumName :: TypeName,-    enumDescription :: Maybe Description,+  { enumDescription :: Maybe Description,+    enumName :: TypeName,     enumDirectives :: [Directive s]   }   deriving (Show, Lift)@@ -242,8 +232,15 @@   }   deriving (Show, Lift) -instance Merge (Schema s) where-  merge _ s1 s2 =+instance+  ( Monad m,+    Failure ValidationErrors m+  ) =>+  SemigroupM+    m+    (Schema s)+  where+  mergeM _ s1 s2 =     Schema       <$> (types s1 <:> types s2)       <*> mergeOperation (query s1) (query s2)@@ -325,10 +322,17 @@ instance Selectable TypeName (TypeDefinition ANY s) (Schema s) where   selectOr fb f name lib = maybe fb f (lookupDataType name lib) -instance Listable (TypeDefinition ANY s) (Schema s) where+instance Elems (TypeDefinition ANY s) (Schema s) where   elems Schema {..} =     elems types       <> concatMap fromOperation [Just query, mutation, subscription]++instance+  ( Monad m,+    Failure ValidationErrors m+  ) =>+  FromElems m (TypeDefinition ANY s) (Schema s)+  where   fromElems types =     traverse3       (popByKey types)@@ -336,9 +340,9 @@         RootOperationTypeDefinition Mutation "Mutation",         RootOperationTypeDefinition Subscription "Subscription"       )-      >>= buildWith types+      >>= defineSchemaWith types -buildWith ::+defineSchemaWith ::   ( Monad f,     Failure ValidationErrors f   ) =>@@ -348,11 +352,11 @@     Maybe (TypeDefinition OBJECT s)   ) ->   f (Schema s)-buildWith oTypes (Just query, mutation, subscription) = do+defineSchemaWith oTypes (Just query, mutation, subscription) = do   let types = excludeTypes [Just query, mutation, subscription] oTypes   let schema = (initTypeLib query) {mutation, subscription}   foldM (flip safeDefineType) schema types-buildWith _ (Nothing, _, _) = failure ["Query root type must be provided." :: ValidationError]+defineSchemaWith _ (Nothing, _, _) = failure ["Query root type must be provided." :: ValidationError]  excludeTypes :: [Maybe (TypeDefinition c1 s)] -> [TypeDefinition c2 s] -> [TypeDefinition c2 s] excludeTypes exclusionTypes = filter ((`notElem` blacklist) . typeName)@@ -382,7 +386,7 @@   withDirectives     dirs     <$> ( traverse3 selectOp (Query, Mutation, Subscription)-            >>= buildWith types+            >>= defineSchemaWith types         )   where     selectOp op = selectOperation schemaDef op types@@ -434,9 +438,6 @@     <|> (subscription >>= isType name)     <|> selectOr Nothing Just name types -isTypeDefined :: TypeName -> Schema s -> Maybe DataFingerprint-isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib- -- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types ------------------------------------------------------------------------- -- TypeDefinition :@@ -448,9 +449,8 @@ --   InputObjectTypeDefinition  data TypeDefinition (a :: TypeCategory) (s :: Stage) = TypeDefinition-  { typeName :: TypeName,-    typeFingerprint :: DataFingerprint,-    typeDescription :: Maybe Description,+  { typeDescription :: Maybe Description,+    typeName :: TypeName,     typeDirectives :: Directives s,     typeContent :: TypeContent TRUE a s   }@@ -586,7 +586,6 @@   TypeDefinition     { typeName,       typeDescription = Nothing,-      typeFingerprint = DataFingerprint typeName [],       typeDirectives = [],       typeContent     }@@ -635,14 +634,13 @@   TypeDefinition cat s ->   Schema s ->   m (Schema s)-safeDefineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys, typeFingerprint} lib = do+safeDefineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys} lib = do   types <- insert unionTags (types lib) >>= insert (toAny dt)   pure lib {types}   where     unionTags =       TypeDefinition         { typeName = typeName <> "Tags",-          typeFingerprint,           typeDescription = Nothing,           typeDirectives = [],           typeContent = mkEnumContent (fmap memberName enumKeys)

@@ -34,9 +34,6 @@ where  -- MORPHEUS--import Control.Applicative (pure)-import Control.Monad.Fail (MonadFail (fail)) import qualified Data.Aeson as A   ( (.=),     FromJSON (..),@@ -45,22 +42,27 @@     object,     pairs,   )-import Data.Either (Either (..))-import Data.Foldable (foldl, foldl1, null)-import Data.Functor (fmap)+import Data.Foldable (foldl1) import qualified Data.HashMap.Lazy as M-  ( toList,-  )-import Data.Maybe (Maybe (..)) import Data.Morpheus.Error.NameCollision   ( NameCollision (..),   )+import Data.Morpheus.Ext.OrdMap+  ( OrdMap,+    unsafeFromList,+  ) import Data.Morpheus.Internal.Utils   ( KeyOf (..),     elems,     mapTuple,   )-import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..))+import Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+    fromText,+    renderGQL,+    renderInputSeq,+    space,+  ) import Data.Morpheus.Types.Internal.AST.Base   ( FieldName,     FieldName (..),@@ -72,10 +74,6 @@     ValidationError (..),     msgValidation,   )-import Data.Morpheus.Types.Internal.AST.OrdMap-  ( OrdMap,-    unsafeFromValues,-  ) import Data.Morpheus.Types.Internal.AST.Stage   ( CONST,     CONST_OR_VALID,@@ -87,26 +85,10 @@   ( Scientific,     floatingOrInteger,   )-import Data.Semigroup ((<>))-import Data.Text-  ( Text,-  ) import qualified Data.Vector as V-  ( toList,-  )-import GHC.Generics (Generic) import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift (..))-import Prelude-  ( ($),-    (.),-    Bool,-    Eq,-    Float,-    Int,-    Show (..),-    otherwise,-  )+import Relude  -- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'. -- for performance reason type 'Text' represents GraphQl 'String' value@@ -155,9 +137,9 @@ deriving instance Eq (VariableContent a)  data Variable (stage :: Stage) = Variable-  { variableName :: FieldName,+  { variablePosition :: Position,+    variableName :: FieldName,     variableType :: TypeRef,-    variablePosition :: Position,     variableValue :: VariableContent (CONST_OR_VALID stage)   }   deriving (Show, Eq, Lift)@@ -194,7 +176,7 @@   deriving (Eq, Show)  instance RenderGQL (ObjectEntry a) where-  render (ObjectEntry (FieldName name) value) = name <> ": " <> render value+  render (ObjectEntry (FieldName name) value) = fromText name <> ": " <> render value  instance NameCollision (ObjectEntry s) where   nameCollision ObjectEntry {entryName} =@@ -222,27 +204,22 @@ deriving instance Lift (ObjectEntry a)  instance RenderGQL (Value a) where-  render (ResolvedVariable Ref {refName} _) =-    "$" <> readName refName-  render (VariableValue Ref {refName}) = "$" <> readName refName <> " "+  render (ResolvedVariable Ref {refName} _) = "$" <> render refName+  render (VariableValue Ref {refName}) = "$" <> render refName <> " "   render Null = "null"-  render (Enum x) = readTypeName x+  render (Enum x) = render x   render (Scalar x) = render x-  render (Object keys) = "{" <> foldl toEntry "" (elems keys) <> "}"-    where-      toEntry :: Text -> ObjectEntry a -> Text-      toEntry "" value = render value-      toEntry txt value = txt <> ", " <> render value-  render (List list) = "[" <> foldl toEntry "" list <> "]"+  render (Object xs) = "{" <> entries <> "}"     where-      toEntry :: Text -> Value a -> Text-      toEntry "" value = render value-      toEntry txt value = txt <> ", " <> render value+      entries+        | null (elems xs) = ""+        | otherwise = space <> renderInputSeq (elems xs) <> space+  render (List list) = "[" <> renderInputSeq list <> "]"  -- render = pack . BS.unpack . A.encode  instance Msg (Value a) where-  msg = msg . render+  msg = msg . renderGQL  instance A.ToJSON (Value a) where   toJSON (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) =@@ -308,6 +285,6 @@   gqlBoolean = Scalar . Boolean   gqlString = Scalar . String   gqlList = List-  gqlObject = Object . unsafeFromValues . fmap toEntry+  gqlObject = Object . unsafeFromList . fmap toEntry     where-      toEntry (key, value) = ObjectEntry key value+      toEntry (key, value) = (key, ObjectEntry key value)

@@ -8,11 +8,7 @@   ) where -import Prelude-  ( Bool (..),-    Eq,-    Show,-  )+import Relude  data VALIDATION_MODE   = WITHOUT_VARIABLES

@@ -3,15 +3,12 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.Resolving-  ( Event (..),-    Resolver,+  ( Resolver,     LiftOperation,     runRootResModel,     lift,-    SubEvent,     Eventless,     Failure (..),-    eventChannels,     ResponseEvent (..),     ResponseStream,     cleanEvents,@@ -40,20 +37,17 @@     mkString,     SubscriptionField (..),     getArguments,-    Channel (..),     ResolverState,     liftResolverState,     mkValue,     FieldResModel,+    sortErrors,+    EventHandler (..),   ) where -import Control.Applicative (pure)-import Control.Monad (Monad) import qualified Data.Aeson as A-import Data.Functor (fmap) import qualified Data.HashMap.Lazy as HM-import Data.Maybe (maybe) import Data.Morpheus.Internal.Utils   ( mapTuple,   )@@ -71,13 +65,7 @@ import qualified Data.Vector as V   ( toList,   )-import Prelude-  ( ($),-    (.),-    Bool,-    Float,-    Int,-  )+import Relude  mkString :: Token -> ResModel o e m mkString = ResScalar . String

@@ -16,13 +16,10 @@     cleanEvents,     PushEvents (..),     resultOr,+    sortErrors,   ) where -import Control.Applicative (Applicative (..), liftA2)-import Control.Monad (Monad (..))-import Control.Monad.Trans.Class (MonadTrans (..))-import Data.Functor ((<$>), Functor (..)) import Data.Morpheus.Internal.Utils   ( Failure (..),   )@@ -32,11 +29,7 @@     ValidationError (..),     toGQLError,   )-import Data.Semigroup ((<>))-import Prelude-  ( ($),-    (.),-  )+import Relude  type Eventless = Result () @@ -84,6 +77,10 @@ resultOr _ f (Success x _ _) = f x resultOr f _ (Failure e) = f e +sortErrors :: Result e a -> Result e a+sortErrors (Failure errors) = Failure (sortOn locations errors)+sortErrors x = x+ -- ResultT newtype ResultT event (m :: * -> *) a = ResultT   { runResultT :: m (Result event a)@@ -104,7 +101,7 @@         result2 <- runResultT (mFunc value1)         case result2 of           Failure errors -> pure $ Failure (errors <> w1)-          Success v2 w2 e2 -> return $ Success v2 (w1 <> w2) (e1 <> e2)+          Success v2 w2 e2 -> pure $ Success v2 (w1 <> w2) (e1 <> e2)  instance MonadTrans (ResultT event) where   lift = ResultT . fmap pure

@@ -1,32 +1,25 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.Resolving.Event-  ( Event (..),-    Channel (..),-    eventChannels,+  ( EventHandler (..),+    ResponseEvent (..),   ) where -import Prelude-  ( Eq (..),-    fmap,+import Data.Morpheus.Types.IO+  ( GQLResponse,   ) --- Channel-data Channel (event :: *) where-  Channel :: a -> Channel (Event a c)--data Event e c = Event-  { channels :: [e],-    content :: c-  }--eventChannels :: Event e c -> [Channel (Event e c)]-eventChannels Event {channels} = fmap Channel channels+class EventHandler e where+  type Channel e+  getChannels :: e -> [Channel e] -instance (Eq ch) => Eq (Channel (Event ch con)) where-  Channel x == Channel y = x == y+data ResponseEvent event (m :: * -> *)+  = Publish event+  | Subscribe+      { subChannel :: Channel event,+        subRes :: event -> m GQLResponse+      }

@@ -14,16 +14,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.Resolving.Resolver-  ( Event (..),-    Resolver,+  ( Resolver,     LiftOperation,     lift,     subscribe,-    SubEvent,     ResponseEvent (..),     ResponseStream,     ObjectResModel (..),@@ -40,26 +37,15 @@   ) where -import Control.Applicative (Applicative (..))-import Control.Monad (Monad (..), join)-import Control.Monad.Fail (MonadFail (..))-import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Reader (MonadReader (..), asks)-import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.Trans.Reader-  ( ReaderT (..),-    mapReaderT,-  )-import Data.Functor ((<$>), Functor (..))-import Data.HashMap.Lazy (HashMap)+import Control.Monad.Trans.Reader (mapReaderT) import qualified Data.HashMap.Lazy as HM-import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Error.Selection (subfieldsNotSelected)+import Data.Morpheus.Ext.SemigroupM (SemigroupM (..)) import Data.Morpheus.Internal.Utils-  ( SemigroupM (..),-    empty,+  ( empty,     keyOf,     selectOr,+    traverseCollection,   ) import Data.Morpheus.Types.IO   ( GQLResponse,@@ -68,7 +54,6 @@ import Data.Morpheus.Types.Internal.AST   ( Arguments,     FieldName,-    GQLErrors,     GQLValue (..),     InternalError,     MUTATION,@@ -93,9 +78,6 @@     msg,     toGQLError,   )-import Data.Morpheus.Types.Internal.AST.MergeSet-  ( toOrdMap,-  ) import Data.Morpheus.Types.Internal.Resolving.Core   ( Eventless,     Failure (..),@@ -106,8 +88,8 @@     mapEvent,   ) import Data.Morpheus.Types.Internal.Resolving.Event-  ( Channel (..),-    Event (..),+  ( EventHandler (..),+    ResponseEvent (..),   ) import Data.Morpheus.Types.Internal.Resolving.ResolverState   ( ResolverContext (..),@@ -120,28 +102,17 @@     runResolverStateT,     toResolverStateT,   )-import Data.Semigroup-  ( Semigroup (..),-  )-import Data.Traversable (traverse)-import Prelude-  ( ($),-    (.),-    Eq (..),-    Show (..),-    otherwise,+import Relude hiding+  ( Show,+    empty,+    show,   )+import Prelude (Show (..))  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)- data SubscriptionField (a :: *) where   SubscriptionField ::     { channel :: forall e m v. a ~ Resolver SUBSCRIPTION e m v => Channel e,@@ -181,10 +152,6 @@   (ResolverM x) >>= m2 = ResolverM (x >>= runResolverM . m2)   (ResolverS res) >>= m2 = ResolverS (liftSubResolver m2 <$> res) -#if __GLASGOW_HASKELL__ < 808-  fail = failure . msg-# endif- liftSubResolver ::   (Monad m) =>   (t -> Resolver SUBSCRIPTION r m a) ->@@ -204,10 +171,7 @@   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+instance (LiftOperation o, Monad m, Failure err (ResolverStateT e m)) => Failure err (Resolver o e m) where   failure = packResolver . failure  instance (Monad m, LiftOperation o) => MonadFail (Resolver o e m) where@@ -249,17 +213,16 @@   packResolver = ResolverS . pure . lift . clearStateResolverEvents  subscribe ::-  forall e channel cont m a.-  (Monad m, Event channel cont ~ e) =>-  channel ->+  (Monad m) =>+  Channel e ->   Resolver QUERY e m (e -> Resolver SUBSCRIPTION e m a) ->   SubscriptionField (Resolver SUBSCRIPTION e m a) subscribe ch res =-  SubscriptionField (Channel ch)+  SubscriptionField ch     $ ResolverS     $ fromSub <$> runResolverQ res   where-    fromSub :: (e -> Resolver SUBSCRIPTION e m a) -> ReaderT e (ResolverStateT () m) a+    fromSub :: Monad m => (e -> Resolver SUBSCRIPTION e m a) -> ReaderT e (ResolverStateT () m) a     fromSub f = join (ReaderT (runResolverS . f))  withArguments ::@@ -311,7 +274,7 @@   ResModel o e m ->   Resolver o e m ValidValue resolveObject selectionSet (ResObject drv@ObjectResModel {__typename}) =-  Object . toOrdMap <$> traverse resolver selectionSet+  Object <$> traverseCollection resolver selectionSet   where     resolver :: Selection VALID -> Resolver o e m (ObjectEntry VALID)     resolver currentSelection =@@ -385,7 +348,7 @@   where     handle = do       channel <- channelGenerator currentSelection-      pure $ Subscribe (Event [channel] res)+      pure $ Subscribe channel res subscriptionEvents ctx Nothing _ = failure [resolverFailureMessage ctx "channel Resolver is not defined"]  -- Resolver Models -------------------------------------------------------------------

@@ -13,7 +13,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.Resolving.ResolverState@@ -29,29 +28,22 @@   ) where -import Control.Applicative (Applicative (..))-import Control.Monad (Monad (..))-import Control.Monad.Reader (MonadReader (..), asks)-import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.Trans.Reader-  ( ReaderT (..),-    mapReaderT,-  )-import Data.Functor (Functor (..))-import Data.Functor.Identity (Identity (..))+import Control.Monad.Trans.Reader (mapReaderT) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),+    renderGQL,   ) import Data.Morpheus.Types.Internal.AST   ( GQLError (..),     GQLErrors,-    InternalError,+    InternalError (..),     Message,     Operation,     Schema,     Selection (..),     TypeName,     VALID,+    ValidationError (..),     msg,   ) import Data.Morpheus.Types.Internal.Config (Config (..))@@ -63,17 +55,7 @@     ResultT (..),     cleanEvents,   )-import Data.Semigroup-  ( Semigroup (..),-  )-import Prelude-  ( ($),-    (.),-    Bool (..),-    Int,-    Show (..),-    id,-  )+import Relude  data ResolverContext = ResolverContext   { currentSelection :: Selection VALID,@@ -119,6 +101,11 @@     ctx <- asks id     failure [renderInternalResolverError ctx message] +instance Monad m => Failure [ValidationError] (ResolverStateT e m) where+  failure messages = do+    ctx <- asks id+    failure $ fmap (resolverFailureMessage ctx . validationMessage) messages+ instance (Monad m) => Failure GQLErrors (ResolverStateT e m) where   failure = ResolverStateT . lift . failure @@ -196,7 +183,7 @@ renderSection label content =   "\n\n" <> label <> ":\n" <> line     <> "\n\n"-    <> msg (render content)+    <> msg (renderGQL content)     <> "\n\n"   where     line = stimes (50 :: Int) "-"

@@ -11,24 +11,23 @@   ) where -import Control.Applicative (Applicative (..))-import Control.Monad (Monad (..))-import Data.Functor ((<$>))-import Data.Maybe (Maybe (..)) import Data.Morpheus.Error.NameCollision (NameCollision (..))+import Data.Morpheus.Ext.Map+  ( resolveWith,+    runResolutionT,+  )+import qualified Data.Morpheus.Ext.OrdMap as OM+import qualified Data.Morpheus.Ext.SafeHashMap as SHM+import Data.Morpheus.Ext.SemigroupM (SemigroupM (..)) import Data.Morpheus.Internal.Utils   ( Failure (..),-    SemigroupM (..),     mergeT,     prop,-    resolveWith,-    runResolutionT,   ) import Data.Morpheus.Types.Internal.AST   ( Directive,     DirectiveDefinition,     FieldDefinition,-    Fields (..),     FieldsDefinition,     Schema (..),     TRUE,@@ -37,17 +36,9 @@     TypeLib,     ValidationErrors,   )-import qualified Data.Morpheus.Types.Internal.AST.OrdMap as OM (unsafeFromValues)-import qualified Data.Morpheus.Types.Internal.AST.SafeHashMap as SHM (unsafeFromValues) import Data.Morpheus.Types.Internal.Resolving (RootResModel) import qualified Data.Morpheus.Types.Internal.Resolving as R (RootResModel (..))-import Data.Semigroup (Semigroup (..))-import Prelude-  ( ($),-    (.),-    Eq (..),-    otherwise,-  )+import Relude hiding (optional)  equal :: (Eq a, Applicative m, Failure ValidationErrors m) => ValidationErrors -> a -> a -> m a equal err p1 p2@@ -76,7 +67,7 @@       <*> prop stitch directiveDefinitions s1 s2  instance Stitching (TypeLib s) where-  stitch x y = runResolutionT (mergeT x y) SHM.unsafeFromValues (resolveWith stitch)+  stitch x y = runResolutionT (mergeT x y) SHM.unsafeFromList (resolveWith stitch)  instance Stitching [DirectiveDefinition s] where   stitch = concatM@@ -96,18 +87,16 @@   m (TypeDefinition c s) stitchOperation x y =   TypeDefinition-    <$> prop fstM typeName x y-    <*> prop fstM typeFingerprint x y-    <*> prop concatM typeDescription x y+    <$> prop concatM typeDescription x y+    <*> prop fstM typeName x y     <*> prop stitch typeDirectives x y     <*> prop stitch typeContent x y  instance Stitching (TypeDefinition cat s) where   stitch x y =     TypeDefinition-      <$> prop (equal [nameCollision y]) typeName x y-      <*> prop (equal [nameCollision y]) typeFingerprint x y-      <*> prop concatM typeDescription x y+      <$> prop concatM typeDescription x y+      <*> prop (equal [nameCollision y]) typeName x y       <*> prop stitch typeDirectives x y       <*> prop stitch typeContent x y @@ -117,7 +106,7 @@   stitch _ _ = failure (["Schema Stitching works only for objects"] :: ValidationErrors)  instance Stitching (FieldsDefinition cat s) where-  stitch (Fields x) (Fields y) = Fields <$> runResolutionT (mergeT x y) OM.unsafeFromValues (resolveWith stitch)+  stitch x y = runResolutionT (mergeT x y) OM.unsafeFromList (resolveWith stitch)  instance Stitching (FieldDefinition cat s) where   stitch old new

@@ -57,18 +57,6 @@   ) where --- MORPHEUS--import Control.Applicative (pure)-import Control.Monad ((>>=))-import Control.Monad.Trans.Reader-  ( ask,-  )-import Data.Either (Either)-import Data.Foldable (null)-import Data.Functor ((<$>), fmap)-import Data.List (filter)-import Data.Maybe (Maybe (..), fromMaybe, maybe) import Data.Morpheus.Internal.Utils   ( Failure (..),     KeyOf (..),@@ -152,14 +140,9 @@     withScope,     withScopeType,   )-import Data.Semigroup-  ( (<>),-  )-import Prelude-  ( ($),-    (.),-    not,-    otherwise,+import Relude hiding+  ( Constraint,+    asks,   )  getUnused :: (KeyOf k b, Selectable k a c) => c -> [b] -> [b]

@@ -16,8 +16,6 @@   ) where --- MORPHEUS-import Data.Maybe (maybeToList) import Data.Morpheus.Error.Selection (unknownSelectionField) import Data.Morpheus.Types.Internal.AST   ( Argument (..),@@ -55,8 +53,7 @@     Target (..),     renderInputPrefix,   )-import Data.Semigroup ((<>))-import Prelude (($))+import Relude  class Unused ctx c where   unused :: ctx -> c -> ValidationError

@@ -20,12 +20,6 @@   ) where --- MORPHEUS--import Control.Applicative (Applicative, pure)-import Control.Monad ((>=>), Monad ((>>=)))-import Data.Functor ((<$>))-import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Internal.Utils   ( Failure (..),     selectBy,@@ -67,14 +61,7 @@     SelectionValidator,     askSchema,   )-import Data.Semigroup-  ( (<>),-  )-import Data.Traversable (traverse)-import Prelude-  ( ($),-    (.),-  )+import Relude  askType ::   Constraints m c cat s =>

@@ -26,11 +26,6 @@   ) where ---import Data.Morpheus.Error.Document.Interface (unknownInterface)---- MORPHEUS--import Control.Applicative (pure) import Data.Morpheus.Internal.Utils   ( Failure (..),   )@@ -51,15 +46,7 @@     renderField,     withContext,   )-import Data.Semigroup-  ( (<>),-    Semigroup (..),-  )-import Prelude-  ( (.),-    Show (..),-    const,-  )+import Relude hiding (local)  newtype TypeSystemContext c = TypeSystemContext   {local :: c}

@@ -56,25 +56,13 @@   ) where --- MORPHEUS--import Control.Applicative (Applicative)-import Control.Monad (Monad)-import Control.Monad.Reader (MonadReader (..))-import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.Trans.Reader-  ( ReaderT (..),-    withReaderT,-  )-import Data.Functor ((<$>), Functor (..))-import Data.Maybe (Maybe (..)) import Data.Morpheus.Error.Utils   ( validationErrorMessage,   ) import Data.Morpheus.Internal.Utils   ( Failure (..),   )-import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..))+import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..), renderGQL) import Data.Morpheus.Types.Internal.AST   ( Directive (..),     FieldDefinition (..),@@ -109,17 +97,10 @@ import Data.Morpheus.Types.Internal.Resolving   ( Eventless,   )-import Data.Semigroup-  ( (<>),-    stimes,-  )-import Prelude-  ( ($),-    (.),-    Bool,-    Int,-    Show,-    otherwise,+import Relude hiding+  ( Constraint,+    asks,+    get,   )  data Prop = Prop@@ -528,18 +509,18 @@     renderSection       "Scope"       ( "referenced by type "-          <> render currentTypeName+          <> renderGQL currentTypeName           <> " of kind "-          <> render currentTypeKind+          <> renderGQL currentTypeKind           <> " in field "-          <> render fieldname+          <> renderGQL fieldname       )  renderSection :: RenderGQL a => Message -> a -> Message renderSection label content =   "\n\n" <> label <> ":\n" <> line     <> "\n\n"-    <> msg (render content)+    <> msg (renderGQL content)     <> "\n\n"   where     line = stimes (50 :: Int) "-"

@@ -8,9 +8,6 @@ -- Description : A simple interface for Morpheus internal Selection Set's representation. module Data.Morpheus.Types.SelectionTree where -import Data.Bool (Bool (..))-import Data.Foldable (concatMap)-import Data.Monoid (mempty) import Data.Morpheus.Internal.Utils (elems, keyOf) import Data.Morpheus.Types.Internal.AST   ( FieldName (..),@@ -20,11 +17,8 @@     UnionTag (..),     VALID,   )-import Data.String-  ( IsString (..),-  ) import Data.Text (unpack)-import Prelude ((.))+import Relude  -- | The 'SelectionTree' instance is a simple interface for interacting -- with morpheus's internal AST while keeping the ability to safely change the concrete

@@ -18,24 +18,19 @@   ) where -import Control.Applicative ((*>), (<*>), Applicative (..), pure)-import Control.Monad ((>=>))-import Control.Monad.Reader (asks)-import Data.Foldable (traverse_)-import Data.Functor ((<$>), fmap)-import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Error.Document.Interface   ( ImplementsError (..),     PartialImplements (..),   )-import Data.Morpheus.Internal.Utils+import Data.Morpheus.Ext.SemigroupM   ( (<:>),-    KeyOf (..),+  )+import Data.Morpheus.Internal.Utils+  ( KeyOf (..),     Selectable (..),     elems,     empty,     failure,-    ordTraverse,   ) import Data.Morpheus.Schema.Schema   ( internalSchema,@@ -98,17 +93,7 @@ import Data.Morpheus.Validation.Internal.Value   ( validateInputByTypeRef,   )-import Data.Proxy (Proxy (..))-import Data.Traversable (traverse)-import Prelude-  ( ($),-    (&&),-    (.),-    (==),-    Bool,-    not,-    otherwise,-  )+import Relude hiding (empty, local)  class ValidateSchema s where   validateSchema :: Bool -> Config -> Schema s -> Eventless (Schema VALID)@@ -165,16 +150,14 @@ validateType   TypeDefinition     { typeName,-      typeFingerprint,       typeDescription,       typeDirectives,       typeContent     } =     inType typeName $       TypeDefinition-        typeName-        typeFingerprint         typeDescription+        typeName         <$> validateDirectives (typeDirectiveLocation typeContent) typeDirectives         <*> validateTypeContent typeContent @@ -195,24 +178,24 @@     { objectImplements,       objectFields     } =-    do-      validateImplements objectImplements objectFields-      DataObject objectImplements <$> ordTraverse validateField objectFields+    DataObject+      <$> validateImplements objectImplements objectFields+      <*> traverse validateField objectFields validateTypeContent DataInputObject {inputObjectFields} =-  DataInputObject <$> ordTraverse validateField inputObjectFields+  DataInputObject <$> traverse validateField inputObjectFields validateTypeContent DataScalar {..} = pure DataScalar {..} validateTypeContent DataEnum {enumMembers} = DataEnum <$> traverse validateEnumMember enumMembers validateTypeContent DataInputUnion {inputUnionMembers} =   DataInputUnion <$> traverse validateUnionMember inputUnionMembers validateTypeContent DataUnion {unionMembers} = DataUnion <$> traverse validateUnionMember unionMembers validateTypeContent (DataInterface fields) =-  DataInterface <$> ordTraverse validateField fields+  DataInterface <$> traverse validateField fields  validateEnumMember ::   DataEnumValue CONST -> SchemaValidator TypeName (DataEnumValue VALID)-validateEnumMember DataEnumValue {enumDirectives = directives, ..} = do-  enumDirectives <- validateDirectives ENUM_VALUE directives-  pure DataEnumValue {..}+validateEnumMember DataEnumValue {enumDirectives = directives, ..} =+  DataEnumValue enumDescription enumName+    <$> validateDirectives ENUM_VALUE directives  validateUnionMember ::   UnionMember cat CONST -> SchemaValidator TypeName (UnionMember cat VALID)@@ -236,11 +219,11 @@   inField     fieldName     ( FieldDefinition-        fieldName         fieldDescription+        fieldName         fieldType-        <$> validateDirectives (directiveLocation (Proxy @cat)) fieldDirectives-          <*> validateOptional (checkFieldContent field) fieldContent+        <$> validateOptional (checkFieldContent field) fieldContent+        <*> validateDirectives (directiveLocation (Proxy @cat)) fieldDirectives     )  checkFieldContent ::@@ -260,7 +243,7 @@   SchemaValidator (TypeName, FieldName) (ArgumentsDefinition VALID) validateArgumentsDefinition (ArgumentsDefinition meta args) =   ArgumentsDefinition meta-    <$> ordTraverse+    <$> traverse       validateArgumentDefinition       args @@ -269,11 +252,11 @@   SchemaValidator (TypeName, FieldName) (ArgumentDefinition VALID) validateArgumentDefinition FieldDefinition {..} =   FieldDefinition-    fieldName     fieldDescription+    fieldName     fieldType-    <$> validateDirectives ARGUMENT_DEFINITION fieldDirectives-    <*> validateOptional (validateArgumentDefaultValue fieldName fieldType) fieldContent+    <$> validateOptional (validateArgumentDefaultValue fieldName fieldType) fieldContent+    <*> validateDirectives ARGUMENT_DEFINITION fieldDirectives  validateArgumentDefaultValue ::   FieldName ->@@ -294,10 +277,12 @@ validateImplements ::   [TypeName] ->   FieldsDefinition OUT CONST ->-  SchemaValidator TypeName ()-validateImplements objectImplements objectFields = do-  interface <- traverse selectInterface objectImplements-  traverse_ (mustBeSubset objectFields) interface+  SchemaValidator TypeName [TypeName]+validateImplements objectImplements objectFields =+  ( traverse selectInterface objectImplements+      >>= traverse_ (mustBeSubset objectFields)+  )+    $> objectImplements  mustBeSubset ::   FieldsDefinition OUT CONST ->@@ -318,9 +303,8 @@       fieldDirectives     } =     inField fieldName $-      do-        _ <- validateDirectives FIELD_DEFINITION fieldDirectives-        selectOr err (isSuptype interfaceField) fieldName objFields+      validateDirectives FIELD_DEFINITION fieldDirectives+        *> selectOr err (isSuptype interfaceField) fieldName objFields     where       err = failImplements Missing @@ -401,7 +385,6 @@ validateDefaultValue typeRef =   validateInputByTypeRef (Typed typeRef) --- TODO: validate directives validateDirectiveDefinition :: DirectiveDefinition CONST -> SchemaValidator () (DirectiveDefinition VALID) validateDirectiveDefinition DirectiveDefinition {directiveDefinitionArgs = args, ..} =   inType "Directive" $ inField directiveDefinitionName $ do

@@ -18,14 +18,8 @@   ) where -import Control.Applicative ((*>), pure)-import Control.Monad ((>=>), (>>=))-import Data.Functor ((<$>), fmap)-import Data.Maybe (fromMaybe, maybe) import Data.Morpheus.Internal.Utils   ( empty,-    ordTraverse,-    ordTraverse_,   ) import Data.Morpheus.Types.Internal.AST   ( Argument (..),@@ -66,12 +60,7 @@   ( ValidateWithDefault,     validateInputByTypeRef,   )-import Data.Traversable (traverse)-import Prelude-  ( ($),-    (.),-    flip,-  )+import Relude hiding (empty)  type VariableConstraints ctx =   ( GetWith ctx (VariableDefinitions VALID),@@ -103,7 +92,9 @@ toArgument :: FieldDefinition IN s -> Value schemaS -> Validator schemaStage ctx (Argument schemaS) toArgument   FieldDefinition {fieldName}-  value = flip (Argument fieldName) value . fromMaybe (Position 0 0) <$> asksScope position+  value = mkArg . fromMaybe (Position 0 0) <$> asksScope position+    where+      mkArg pos = Argument pos fieldName value  validateArgumentValue ::   (ValidateWithDefault ctx schemaS valueS) =>@@ -116,8 +107,8 @@     withPosition argumentPosition       $ startInput (SourceArgument argumentName)       $ Argument-        argumentName         argumentPosition+        argumentName         <$> validateInputByTypeRef (typed fieldType field) argumentValue  validateFieldArguments ::@@ -151,9 +142,9 @@   Arguments s ->   Validator schemaStage ctx (Arguments VALID) validateArguments checkUnknown argsDef rawArgs = do-  args <- ordTraverse resolve rawArgs-  ordTraverse_ checkUnknown args-    *> ordTraverse (validateArgument args) (arguments argsDef)+  args <- traverse resolve rawArgs+  traverse_ checkUnknown args+    *> traverse (validateArgument args) (arguments argsDef)  class Resolve f s ctx where   resolve :: f s -> Validator schemaS ctx (f CONST)

@@ -9,7 +9,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Validation.Internal.Directive@@ -18,10 +17,6 @@   ) where -import Control.Applicative ((*>), pure)-import Control.Monad ((>>=))-import Data.Functor ((<$>))-import Data.List (elem) import Data.Morpheus.Error.Utils   ( validationErrorMessage,   )@@ -54,16 +49,7 @@   ( ArgumentsConstraints,     validateDirectiveArguments,   )-import Data.Semigroup ((<>))-import Data.Traversable (traverse)-import Prelude-  ( ($),-    (&&),-    (==),-    Bool (..),-    Maybe (..),-    otherwise,-  )+import Relude  validateDirectives ::   ArgumentsConstraints ctx schemaS s =>@@ -81,7 +67,7 @@   withDirective directive $ do     Schema {directiveDefinitions} <- askSchema     directiveDef <- selectKnown directive directiveDefinitions-    Directive directiveName directivePosition+    Directive directivePosition directiveName       <$> ( validateDirectiveLocation location directive directiveDef               *> validateDirectiveArguments directiveDef directiveArgs           )

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}@@ -13,18 +14,11 @@   ) where -import Control.Applicative ((*>), pure)-import Data.Either (Either (..))-import Data.Function ((&))-import Data.Functor ((<$>), fmap)-import Data.List (any, elem)-import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Error.Input (typeViolation) import Data.Morpheus.Error.Variable (incompatibleVariableType) import Data.Morpheus.Internal.Utils   ( Failure (..),-    ordTraverse_,-    traverseCollection,+    fromElems,   ) import Data.Morpheus.Types.Internal.AST   ( CONST,@@ -49,6 +43,7 @@     UnionMember (..),     VALID,     ValidValue,+    ValidationErrors,     Value (..),     Variable (..),     Variable (..),@@ -62,9 +57,6 @@     untyped,     withPosition,   )-import Data.Morpheus.Types.Internal.AST.OrdMap-  ( unsafeFromValues,-  ) import Data.Morpheus.Types.Internal.Validation   ( InputContext,     InputSource (..),@@ -82,20 +74,7 @@     selectWithDefaultValue,     withScopeType,   )-import Data.Semigroup ((<>))-import Data.Traversable (traverse)-import Prelude-  ( ($),-    (&&),-    (.),-    Bool (..),-    Eq (..),-    const,-    fst,-    id,-    not,-    otherwise,-  )+import Relude  violation ::   Maybe Message ->@@ -224,7 +203,7 @@ validatInputUnion inputUnion rawFields =   case constraintInputUnion inputUnion rawFields of     Left message -> violation (Just message) (Object rawFields)-    Right (UnionMember {memberName}, Nothing) -> pure (mkInputObject memberName [])+    Right (UnionMember {memberName}, Nothing) -> mkInputObject memberName []     Right (name, Just value) -> validatInputUnionMember name value  validatInputUnionMember ::@@ -235,10 +214,10 @@ validatInputUnionMember member@UnionMember {memberName} value = do   inputDef <- fst <$> askTypeMember member   validValue <- validateInputByType [TypeMaybe] inputDef value-  pure $ mkInputObject memberName [ObjectEntry (toFieldName memberName) validValue]+  mkInputObject memberName [ObjectEntry (toFieldName memberName) validValue] -mkInputObject :: TypeName -> [ObjectEntry s] -> Value s-mkInputObject name xs = Object $ unsafeFromValues $ ObjectEntry "__typename" (Enum name) : xs+mkInputObject :: (Monad m, Failure ValidationErrors m) => TypeName -> [ObjectEntry s] -> m (Value s)+mkInputObject name xs = Object <$> fromElems (ObjectEntry "__typename" (Enum name) : xs)  -- INUT Object validateInputObject ::@@ -247,8 +226,8 @@   Object valueS ->   InputValidator schemaS ctx (Object VALID) validateInputObject fieldsDef object =-  ordTraverse_ (`selectKnown` fieldsDef) object-    *> traverseCollection (validateWithDefault object) fieldsDef+  traverse_ (`selectKnown` fieldsDef) object+    *> traverse (validateWithDefault object) fieldsDef  class ValidateWithDefault c schemaS s where   validateWithDefault ::

@@ -18,12 +18,6 @@   ) where -import Control.Applicative ((<*>), pure)-import Control.Monad ((>>=))-import Data.Functor ((<$>))-import Data.List (elem)-import Data.Maybe (Maybe (..))--- MORPHEUS import Data.Morpheus.Error.Fragment   ( cannotBeSpreadOnType,   )@@ -57,11 +51,7 @@     constraint,     selectKnown,   )-import Data.Traversable (traverse)-import Prelude-  ( ($),-    otherwise,-  )+import Relude  class ResolveFragment (s :: Stage) where   resolveValidFragment ::

@@ -12,11 +12,6 @@   ) where -import Control.Applicative ((*>))-import Control.Monad ((>>=))-import Data.Foldable (concatMap)-import Data.Functor ((<$>), fmap)--- MORPHEUS import Data.Morpheus.Error.Fragment   ( cannotSpreadWithinItself,   )@@ -45,10 +40,7 @@     askFragments,     checkUnused,   )-import Data.Semigroup ((<>))-import Prelude-  ( (.),-  )+import Relude  checkUnusedFragments :: SelectionSet RAW -> BaseValidator () checkUnusedFragments selectionSet = do

@@ -14,15 +14,13 @@   ) where -import Control.Applicative ((<*>), pure)-import Data.Foldable (null)-import Data.Functor ((<$>), fmap)-import Data.List (filter)-import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Error.Selection   ( hasNoSubfields,     subfieldsNotSelected,   )+import Data.Morpheus.Ext.SemigroupM+  ( concatTraverse,+  ) import Data.Morpheus.Internal.Utils   ( Failure (..),     elems,@@ -60,9 +58,6 @@     typed,     withPosition,   )-import Data.Morpheus.Types.Internal.AST.MergeSet-  ( concatTraverse,-  ) import Data.Morpheus.Types.Internal.Validation   ( FragmentValidator,     SelectionValidator,@@ -89,16 +84,7 @@   ( validateInterfaceSelection,     validateUnionSelection,   )-import Data.Semigroup ((<>))-import Prelude-  ( ($),-    (&&),-    (.),-    Eq (..),-    const,-    not,-    otherwise,-  )+import Relude hiding (empty)  selectionsWitoutTypename :: SelectionSet VALID -> [Selection VALID] selectionsWitoutTypename = filter (("__typename" /=) . keyOf) . elems

@@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Validation.Query.UnionSelection   ( validateUnionSelection,@@ -13,12 +14,13 @@   ) where -import Control.Monad ((>=>))-import Data.Maybe (fromMaybe, isJust)--- MORPHEUS-import Data.Morpheus.Internal.Utils+import Data.List (lookup)+import Data.Morpheus.Ext.SemigroupM   ( (<:>),-    elems,+    join,+  )+import Data.Morpheus.Internal.Utils+  ( elems,     empty,     fromElems,     singleton,@@ -41,9 +43,6 @@     mkType,     toCategory,   )-import qualified Data.Morpheus.Types.Internal.AST.MergeSet as MS-  ( join,-  ) import Data.Morpheus.Types.Internal.Validation   ( FragmentValidator,     Scope (..),@@ -55,6 +54,7 @@   ( ResolveFragment (resolveValidFragment),     castFragmentType,   )+import Relude hiding (empty, join)  -- returns all Fragments used for Possible Types splitFragment ::@@ -104,8 +104,7 @@   [TypeDefinition IMPLEMENTABLE VALID] ->   [UnionTag] ->   [(TypeName, [SelectionSet VALID])]-tagUnionFragments types fragments =-  filter notEmpty (map categorizeType types)+tagUnionFragments types fragments = filter notEmpty (categorizeType <$> types)   where     notEmpty = not . null . snd     categorizeType ::@@ -140,7 +139,7 @@   traverse joinCluster     >=> fmap UnionSelection . fromElems   where-    joinCluster (typeName, fragmets) = UnionTag typeName <$> MS.join (selSet : fragmets)+    joinCluster (typeName, fragmets) = UnionTag typeName <$> join (selSet : fragmets)  withTypename ::   SelectionSet VALID ->

@@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Validation.Query.Validation   ( validateRequest,@@ -41,6 +42,10 @@   ) import Data.Morpheus.Validation.Query.Variable   ( resolveOperationVariables,+  )+import Relude hiding+  ( empty,+    fromList,   )  validateRequest ::

@@ -9,14 +9,7 @@   ) where -import Control.Applicative ((*>), pure)-import Control.Monad (Monad ((>>=)))-import Data.Foldable (concat, concatMap)-import Data.Functor ((<$>), fmap) import qualified Data.HashMap.Lazy as M-  ( lookup,-  )-import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Error.Variable (uninitializedVariable) import Data.Morpheus.Internal.Utils   ( Failure (..),@@ -68,19 +61,7 @@ import Data.Morpheus.Validation.Internal.Value   ( validateInputByType,   )-import Data.Semigroup ((<>))-import Data.Traversable-  ( traverse,-  )-import Prelude-  ( ($),-    (&&),-    (.),-    Bool (..),-    Eq (..),-    not,-    otherwise,-  )+import Relude  class ExploreRefs a where   exploreRefs :: a -> [Ref]@@ -108,10 +89,11 @@     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 Selection {selectionArguments, selectionDirectives, selectionContent} =+      ((directiveRefs <> argumentRefs) <>) <$> exploreSelectionContent selectionContent+      where+        directiveRefs = concatMap exploreRefs selectionDirectives+        argumentRefs = concatMap exploreRefs selectionArguments     searchRefs (InlineFragment Fragment {fragmentSelection, fragmentDirectives}) =       (concatMap exploreRefs fragmentDirectives <>)         <$> mapSelection searchRefs fragmentSelection

@@ -6,6 +6,7 @@   ) where +import Relude import Test.Tasty   ( defaultMain,     testGroup,@@ -14,13 +15,10 @@   ( apiTest,   ) import qualified Utils.MergeSchema as MergeSchema+import qualified Utils.Rendering as Rendering import Utils.Schema   ( testSchema,   )-import Prelude-  ( ($),-    IO,-  )  main :: IO () main = do@@ -42,5 +40,27 @@             "on-interface-type-casting",             "on-interface-type-casting-inline",             "on-interface-fail-without-casting"+          ],+        Rendering.test+          "rendering/simple"+          [ "simple",+            "nested",+            "query",+            "mutation",+            "subscription",+            "directive"+          ],+        Rendering.test+          "rendering/union"+          [ "interface",+            "union"+          ],+        Rendering.test+          "rendering/variable"+          [ "simple",+            "input",+            "enum",+            "list",+            "include-exclude"           ]       ]

@@ -8,13 +8,8 @@   ) where -import Control.Applicative (pure) import qualified Data.Aeson as A import Data.Aeson (decode, encode)-import qualified Data.ByteString.Lazy.Char8 as LB (unpack)-import Data.Functor ((<$>), fmap)-import Data.Functor.Identity (Identity (..))-import Data.Maybe (Maybe (..)) import Data.Morpheus.Core (mkApp, runAppStream) import Data.Morpheus.Types.IO import Data.Morpheus.Types.Internal.AST@@ -26,36 +21,27 @@   ( ResponseStream,     ResultT (..),   )-import Data.Semigroup ((<>)) import Data.Text (unpack)+import Relude import Test.Tasty   ( TestTree,     testGroup,   ) import Test.Tasty.HUnit-  ( assertFailure,-    testCase,+  ( testCase,   ) import Utils.Utils   ( assertValidSchema,+    caseFailure,     expectedResponse,     getRequest,     getResolvers,   )-import Prelude-  ( ($),-    (==),-    IO,-    otherwise,-  )  assertion :: A.Value -> ResponseStream e Identity (Value VALID) -> IO () assertion expected (ResultT (Identity actual))   | Just expected == decode actualValue = pure ()-  | otherwise =-    assertFailure $-      LB.unpack-        ("expected: \n\n " <> encode expected <> " \n\n but got: \n\n " <> actualValue)+  | otherwise = caseFailure (encode expected) actualValue   where     actualValue = encode (renderResponse actual) 

@@ -8,15 +8,9 @@   ) where -import Control.Applicative (pure)-import Control.Monad ((>>=))-import Control.Monad.Fail (fail) import Data.Aeson (decode, encode) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as L (readFile)-import qualified Data.ByteString.Lazy.Char8 as LB (unpack)-import Data.Functor ((<$>), fmap)-import Data.Functor.Identity (Identity (..)) import Data.Morpheus.Core   ( App (..),     AppData (..),@@ -38,9 +32,8 @@     ResultT (..),     resultOr,   )-import Data.Semigroup ((<>)) import Data.Text (unpack)-import Data.Traversable (traverse)+import Relude import Test.Tasty   ( TestTree,     testGroup,@@ -50,19 +43,11 @@     testCase,   ) import Utils.Utils-  ( expectedResponse,+  ( caseFailure,+    expectedResponse,     getRequest,     getResolver,   )-import Prelude-  ( ($),-    (.),-    Eq (..),-    IO,-    Maybe (..),-    otherwise,-    show,-  )  readSchema :: FieldName -> IO (Schema VALID) readSchema (FieldName p) = L.readFile (unpack p) >>= (resultOr (fail . show) pure . parseGQLDocument)@@ -76,10 +61,7 @@ schemaAssertion :: App () Identity -> Schema VALID -> IO () schemaAssertion (App AppData {appSchema}) expectedSchema   | render expectedSchema == render appSchema = pure ()-  | otherwise =-    assertFailure-      $ unpack-      $ "expected: \n " <> render expectedSchema <> " \n but got: \n " <> render appSchema+  | otherwise = caseFailure (render expectedSchema) (render appSchema) schemaAssertion (FailApp gqlerror) _ = assertFailure $ " error: " <> show gqlerror  schemaCase :: (FieldName, [FieldName]) -> IO TestTree@@ -111,10 +93,7 @@ assertion :: A.Value -> ResponseStream e Identity (Value VALID) -> IO () assertion expected (ResultT (Identity actual))   | Just expected == decode actualValue = pure ()-  | otherwise =-    assertFailure $-      LB.unpack-        ("expected: \n\n " <> encode expected <> " \n\n but got: \n\n " <> actualValue)+  | otherwise = caseFailure (encode expected) actualValue   where     actualValue = encode (renderResponse actual) 

@@ -0,0 +1,73 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Utils.Rendering+  ( test,+  )+where++import Data.Aeson (encode)+import Data.ByteString.Lazy.Char8+  ( ByteString,+  )+import qualified Data.ByteString.Lazy.Char8 as LB+import Data.Morpheus.Core+  ( defaultConfig,+    parseRequestWith,+    render,+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName (..),+    Operation,+    VALID,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+    Result (..),+  )+import qualified Data.Text as T+import Relude hiding (ByteString)+import Test.Tasty+  ( TestTree,+    testGroup,+  )+import Test.Tasty.HUnit+  ( assertFailure,+    testCase,+  )+import Utils.Utils+  ( assertValidSchema,+    getRequest,+    readSource,+  )++assertion :: ByteString -> Eventless (Operation VALID) -> IO ()+assertion expected Success {result = actual}+  | expected == actualValue = pure ()+  | otherwise =+    assertFailure+      ("expected: \n\n " <> show expected <> " \n\n but got: \n\n " <> show actualValue)+  where+    actualValue = render actual+assertion _ Failure {errors} = assertFailure $ LB.unpack (encode errors)++test :: FieldName -> [FieldName] -> TestTree+test apiPath requestPath =+  testGroup (T.unpack $ readName apiPath) $+    fmap (testRendering apiPath) requestPath++getExpectedRendering :: FieldName -> IO ByteString+getExpectedRendering = readSource . (<> "/rendering.gql")++testRendering ::+  FieldName ->+  FieldName ->+  TestTree+testRendering apiPath path = testCase (T.unpack $ readName path) $ do+  schema <- assertValidSchema apiPath+  let fullPath = apiPath <> "/" <> path+  actual <- parseRequestWith defaultConfig schema <$> getRequest fullPath+  expected <- getExpectedRendering fullPath+  assertion expected actual

@@ -9,13 +9,9 @@   ) where -import Control.Applicative (pure) import Data.Aeson ((.:), (.=), FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, object) import qualified Data.ByteString.Lazy as L (readFile)-import qualified Data.ByteString.Lazy.Char8 as LB (unpack) import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Either (Either (..), either)-import Data.Functor ((<$>), fmap) import Data.Morpheus.Core (parseFullGQLDocument) import Data.Morpheus.Types.Internal.AST   ( GQLErrors,@@ -26,27 +22,17 @@   ( Eventless,     Result (..),   )-import Data.Semigroup ((<>)) import Data.Text (pack)-import GHC.Generics (Generic)+import Relude hiding (ByteString, toString) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertFailure, testCase)+import Test.Tasty.HUnit (testCase) import Utils.Utils   ( CaseTree (..),     FileUrl (..),+    caseFailure,     scanSchemaTests,     toString,   )-import Prelude-  ( ($),-    (.),-    Eq (..),-    FilePath,-    IO,-    String,-    id,-    show,-  )  readSource :: FilePath -> IO ByteString readSource = L.readFile@@ -96,11 +82,8 @@   | err == errors =     pure       ()-assertion expected Success {} =-  assertFailure $-    LB.unpack-      ("expected: \n " <> encode expected <> " \n but got: \n OK")+assertion expected Success {} = caseFailure (encode expected) "OK" assertion expected Failure {errors} =-  assertFailure $-    LB.unpack-      ("expected: \n " <> encode expected <> " \n but got: \n " <> encode (Errors errors))+  caseFailure+    (encode expected)+    (encode (Errors errors))

@@ -1,4 +1,3 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -19,24 +18,25 @@     getSchema,     getResolvers,     getResolver,+    caseFailure,   ) where -import Control.Applicative ((<|>), pure)-import Control.Monad ((>=>), Monad) import Data.Aeson (FromJSON, Value (..), decode) import qualified Data.ByteString.Lazy as L (readFile)+import qualified Data.ByteString.Lazy.Char8 as LB (unpack) import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Either (Either (..)) import Data.Foldable (foldl)-import Data.Functor ((<$>)) import Data.HashMap.Lazy (lookup)-import Data.Maybe (Maybe (..), fromMaybe, maybe) import Data.Morpheus.Core (parseGQLDocument) import Data.Morpheus.Types.IO   ( GQLRequest (..),   )-import Data.Morpheus.Types.Internal.AST (FieldName (..), Schema (..), VALID)+import Data.Morpheus.Types.Internal.AST+  ( FieldName (..),+    Schema (..),+    VALID,+  ) import Data.Morpheus.Types.Internal.Resolving   ( Eventless,     ResModel,@@ -46,26 +46,13 @@     mkValue,     resultOr,   )-import Data.Semigroup ((<>))-import Data.Text (Text, unpack)-import qualified Data.Text.Lazy as LT (toStrict)-import Data.Text.Lazy.Encoding (decodeUtf8)-import Data.Traversable (traverse)+import Data.Text (unpack)+import qualified Data.Text.IO as T+import Relude hiding (ByteString, toString) import System.Directory (doesDirectoryExist, listDirectory) import Test.Tasty.HUnit   ( assertFailure,   )-import Prelude-  ( ($),-    (.),-    Bool,-    FilePath,-    IO,-    Show,-    and,-    map,-    show,-  )  readSource :: FieldName -> IO ByteString readSource = L.readFile . path . readName@@ -146,15 +133,11 @@ expectedResponse (FieldName p) = fromMaybe Null . decode <$> L.readFile (resLib p)  getRequest :: FieldName -> IO GQLRequest-getRequest p = do-  queryBS <- LT.toStrict . decodeUtf8 <$> getGQLBody p-  variables <- maybeVariables p-  pure $-    GQLRequest-      { operationName = Nothing,-        query = queryBS,-        variables-      }+getRequest p =+  GQLRequest+    Nothing+    <$> T.readFile (gqlLib $ readName p)+    <*> maybeVariables p  getResolvers :: Monad m => FieldName -> IO (RootResModel e m) getResolvers p = getResolver ("test/" <> p <> "/resolvers.json")@@ -179,3 +162,9 @@   ResModel o e m lookupRes name (Object fields) = maybe mkNull mkValue (lookup name fields) lookupRes _ _ = mkNull++caseFailure :: ByteString -> ByteString -> IO a+caseFailure expected actualValue =+  assertFailure $+    LB.unpack+      ("expected: \n\n " <> expected <> " \n\n but got: \n\n " <> actualValue)

@@ -0,0 +1,5 @@+query MyQuery @MyDirective {+  deity @MyDirective {+    name @MyDirective(name: "Some Name")+  }+}

@@ -0,0 +1,5 @@+query MyQuery @MyDirective {+  deity @MyDirective {+    name @MyDirective(name: "Some Name")+  }+}