morpheus-graphql-core 0.17.0 → 0.18.0

raw patch · 132 files changed

+3975/−4514 lines, 132 filesdep +morpheus-graphql-testsPVP ok

version bump matches the API change (PVP)

Dependencies added: morpheus-graphql-tests

API changes (from Hackage documentation)

Files

• changelog.md +7/−0
• morpheus-graphql-core.cabal +34/−21
• src/Data/Mergeable.hs +27/−0
• src/Data/Mergeable/Internal/Merge.hs +107/−0
• src/Data/Mergeable/Internal/NameCollision.hs +18/−0
• src/Data/Mergeable/Internal/Resolution.hs +103/−0
• src/Data/Mergeable/IsMap.hs +47/−0
• src/Data/Mergeable/MergeMap.hs +117/−0
• src/Data/Mergeable/OrdMap.hs +88/−0
• src/Data/Mergeable/SafeHashMap.hs +59/−0
• src/Data/Morpheus/Core.hs +3/−5
• src/Data/Morpheus/Error.hs +2/−8
• src/Data/Morpheus/Error/Document/Interface.hs +34/−59
• src/Data/Morpheus/Error/Fragment.hs +30/−27
• src/Data/Morpheus/Error/Input.hs +6/−6
• src/Data/Morpheus/Error/NameCollision.hs +0/−18
• src/Data/Morpheus/Error/Operation.hs +8/−9
• src/Data/Morpheus/Error/Selection.hs +8/−7
• src/Data/Morpheus/Error/Utils.hs +12/−14
• src/Data/Morpheus/Error/Variable.hs +16/−17
• src/Data/Morpheus/Error/Warning.hs +27/−22
• src/Data/Morpheus/Ext/Elems.hs +0/−25
• src/Data/Morpheus/Ext/Failure.hs +0/−21
• src/Data/Morpheus/Ext/KeyOf.hs +1/−1
• src/Data/Morpheus/Ext/Map.hs +0/−103
• src/Data/Morpheus/Ext/MergeSet.hs +0/−119
• src/Data/Morpheus/Ext/OrdMap.hs +0/−93
• src/Data/Morpheus/Ext/Result.hs +66/−63
• src/Data/Morpheus/Ext/SafeHashMap.hs +0/−83
• src/Data/Morpheus/Ext/Selectable.hs +0/−29
• src/Data/Morpheus/Ext/SemigroupM.hs +0/−83
• src/Data/Morpheus/Internal/Ext.hs +7/−19
• src/Data/Morpheus/Internal/TH.hs +0/−179
• src/Data/Morpheus/Internal/Utils.hs +81/−109
• src/Data/Morpheus/Parser.hs +8/−13
• src/Data/Morpheus/Parsing/Document/TypeSystem.hs +32/−19
• src/Data/Morpheus/Parsing/Internal/Arguments.hs +5/−2
• src/Data/Morpheus/Parsing/Internal/Internal.hs +17/−35
• src/Data/Morpheus/Parsing/Internal/Pattern.hs +21/−5
• src/Data/Morpheus/Parsing/Internal/SourceText.hs +139/−0
• src/Data/Morpheus/Parsing/Internal/Terms.hs +138/−210
• src/Data/Morpheus/Parsing/Internal/Value.hs +32/−18
• src/Data/Morpheus/Parsing/Request/Parser.hs +6/−6
• src/Data/Morpheus/Parsing/Request/Selection.hs +3/−3
• src/Data/Morpheus/QuasiQuoter.hs +12/−15
• src/Data/Morpheus/Rendering/RenderGQL.hs +6/−2
• src/Data/Morpheus/Types/GQLScalar.hs +2/−2
• src/Data/Morpheus/Types/ID.hs +2/−1
• src/Data/Morpheus/Types/IO.hs +3/−2
• src/Data/Morpheus/Types/Internal/AST.hs +28/−30
• src/Data/Morpheus/Types/Internal/AST/Base.hs +14/−307
• src/Data/Morpheus/Types/Internal/AST/DirectiveLocation.hs +1/−1
• src/Data/Morpheus/Types/Internal/AST/Error.hs +138/−0
• src/Data/Morpheus/Types/Internal/AST/Fields.hs +55/−60
• src/Data/Morpheus/Types/Internal/AST/Name.hs +160/−0
• src/Data/Morpheus/Types/Internal/AST/OperationType.hs +63/−0
• src/Data/Morpheus/Types/Internal/AST/Selection.hs +155/−127
• src/Data/Morpheus/Types/Internal/AST/Stage.hs +7/−0
• src/Data/Morpheus/Types/Internal/AST/TH.hs +0/−28
• src/Data/Morpheus/Types/Internal/AST/Type.hs +69/−51
• src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs +153/−122
• src/Data/Morpheus/Types/Internal/AST/Union.hs +32/−28
• src/Data/Morpheus/Types/Internal/AST/Value.hs +38/−31
• src/Data/Morpheus/Types/Internal/Validation.hs +52/−94
• src/Data/Morpheus/Types/Internal/Validation/Error.hs +106/−121
• src/Data/Morpheus/Types/Internal/Validation/Internal.hs +44/−51
• src/Data/Morpheus/Types/Internal/Validation/SchemaValidator.hs +79/−32
• src/Data/Morpheus/Types/Internal/Validation/Scope.hs +110/−0
• src/Data/Morpheus/Types/Internal/Validation/Validator.hs +103/−322
• src/Data/Morpheus/Types/SelectionTree.hs +11/−11
• src/Data/Morpheus/Validation/Document/Interface.hs +114/−0
• src/Data/Morpheus/Validation/Document/Validation.hs +115/−286
• src/Data/Morpheus/Validation/Internal/Arguments.hs +20/−24
• src/Data/Morpheus/Validation/Internal/Directive.hs +17/−17
• src/Data/Morpheus/Validation/Internal/Value.hs +40/−62
• src/Data/Morpheus/Validation/Query/Fragment.hs +32/−28
• src/Data/Morpheus/Validation/Query/FragmentPreconditions.hs +17/−17
• src/Data/Morpheus/Validation/Query/Selection.hs +118/−112
• src/Data/Morpheus/Validation/Query/UnionSelection.hs +87/−116
• src/Data/Morpheus/Validation/Query/Validation.hs +11/−11
• src/Data/Morpheus/Validation/Query/Variable.hs +15/−12
• test/Spec.hs +52/−36
• test/Utils/Rendering.hs +0/−73
• test/Utils/Schema.hs +0/−89
• test/Utils/Utils.hs +0/−137
• test/query/parsing/selection-set/empty-selection/query.gql +4/−0
• test/query/parsing/selection-set/empty-selection/response.json +5/−0
• test/query/parsing/selection-set/non-empty-selection/query.gql +5/−0
• test/query/parsing/selection-set/non-empty-selection/response.json +1/−0
• test/query/validation/__typename/arguments/query.gql +3/−0
• test/query/validation/__typename/arguments/response.json +6/−0
• test/query/validation/__typename/schema.gql +3/−0
• test/query/validation/__typename/selection-set/query.gql +5/−0
• test/query/validation/__typename/selection-set/response.json +6/−0
• test/query/validation/__typename/success/query.gql +3/−0
• test/query/validation/__typename/success/response.json +1/−0
• test/rendering/simple/fragment/query.gql +7/−6
• test/rendering/simple/fragment/rendering.gql +4/−12
• test/rendering/simple/fragment/variables.json +0/−3
• test/rendering/union/interface/rendering.gql +2/−8
• test/rendering/union/interface/variables.json +0/−3
• test/rendering/union/union/rendering.gql +6/−3
• test/rendering/union/union/variables.json +0/−3
• test/schema/parsing/descriptions/grave-accent/response.json +1/−0
• test/schema/parsing/descriptions/grave-accent/schema.gql +7/−0
• test/schema/parsing/descriptions/ok/response.json +1/−0
• test/schema/parsing/descriptions/ok/schema.gql +24/−0
• test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/response.json +15/−32
• test/schema/parsing/schema-definition/fail/dupplicate-field/query/response.json +11/−16
• test/schema/parsing/schema-definition/fail/dupplicate-schema-definition/response.json +5/−6
• test/schema/parsing/schema-definition/fail/unknown-fields/bla/response.json +6/−8
• test/schema/parsing/schema-definition/fail/unknown-fields/uppercase/response.json +6/−8
• test/schema/validation/default-value/argument/missing-field/response.json +22/−24
• test/schema/validation/default-value/argument/unexpected-value/response.json +23/−32
• test/schema/validation/default-value/argument/unknown-field/response.json +14/−16
• test/schema/validation/default-value/field/missing-field/response.json +10/−12
• test/schema/validation/default-value/field/unexpected-value/response.json +32/−44
• test/schema/validation/default-value/field/unknown-field/response.json +14/−16
• test/schema/validation/directive/fail/at-invalid-place/response.json +34/−36
• test/schema/validation/directive/fail/missing-argument/response.json +57/−48
• test/schema/validation/directive/fail/sopthisticated/response.json +69/−64
• test/schema/validation/directive/fail/unexpected-value/response.json +34/−36
• test/schema/validation/directive/fail/unknown-directive/response.json +67/−57
• test/schema/validation/interface/field-args/fail/response.json +14/−16
• test/schema/validation/interface/field-type/fail/response.json +11/−16
• test/schema/validation/schema-definition/fail/non-object-kind/from-schema/response.json +11/−16
• test/schema/validation/schema-definition/fail/non-object-kind/without-schema/response.json +11/−16
• test/schema/validation/schema-definition/fail/required query/empty/response.json +5/−8
• test/schema/validation/schema-definition/fail/required query/no-query/response.json +5/−8
• test/schema/validation/schema-definition/fail/required query/no-schema-no-query/response.json +5/−8
• test/schema/validation/schema-definition/fail/required query/schema-with-query/response.json +5/−8
• test/schema/validation/schema-definition/fail/unknown-type/unknown/response.json +5/−16

@@ -1,5 +1,12 @@ # Changelog +## 0.18.0 - 08.11.2021++- GraphQL errors support additional field `extensions :: Maybe Value`+- the parser reports invalid empty selection sets+- The parser is compliant with the GQL specification and supports all valid characters #581+- The parser performance improvement: on average 3-4 times faster, in some cases more than 100 times faster.+ ## 0.17.0 - 25.02.2021  ### New features

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 90068e1d18639f399f1e45aabe9e946400be315246c366b4277f1cae1888f54e+-- hash: b607f4416a8e2ed3786cf203ee2634af203a16673866b658909609815a742be3  name:           morpheus-graphql-core-version:        0.17.0+version:        0.18.0 synopsis:       Morpheus GraphQL Core description:    Build GraphQL APIs with your favorite functional language! category:       web, graphql@@ -23,6 +23,12 @@     changelog.md     README.md data-files:+    test/query/parsing/selection-set/empty-selection/query.gql+    test/query/parsing/selection-set/non-empty-selection/query.gql+    test/query/validation/__typename/arguments/query.gql+    test/query/validation/__typename/schema.gql+    test/query/validation/__typename/selection-set/query.gql+    test/query/validation/__typename/success/query.gql     test/rendering/simple/directive/query.gql     test/rendering/simple/directive/rendering.gql     test/rendering/simple/fragment/query.gql@@ -54,6 +60,8 @@     test/rendering/variable/schema.gql     test/rendering/variable/simple/query.gql     test/rendering/variable/simple/rendering.gql+    test/schema/parsing/descriptions/grave-accent/schema.gql+    test/schema/parsing/descriptions/ok/schema.gql     test/schema/parsing/directive/ok/simple/schema.gql     test/schema/parsing/directive/ok/sophisticated/schema.gql     test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/schema.gql@@ -92,14 +100,18 @@     "test/schema/validation/schema-definition/fail/required query/schema-with-query/schema.gql"     test/schema/validation/schema-definition/fail/unknown-type/unknown/schema.gql     test/schema/validation/schema-definition/ok/full/schema.gql-    test/rendering/simple/fragment/variables.json-    test/rendering/union/interface/variables.json-    test/rendering/union/union/variables.json+    test/query/parsing/selection-set/empty-selection/response.json+    test/query/parsing/selection-set/non-empty-selection/response.json+    test/query/validation/__typename/arguments/response.json+    test/query/validation/__typename/selection-set/response.json+    test/query/validation/__typename/success/response.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/descriptions/grave-accent/response.json+    test/schema/parsing/descriptions/ok/response.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@@ -153,36 +165,35 @@       Data.Morpheus.Types.GQLScalar       Data.Morpheus.Types.ID       Data.Morpheus.Types.SelectionTree-      Data.Morpheus.Internal.TH       Data.Morpheus.Internal.Utils       Data.Morpheus.Internal.Ext   other-modules:+      Data.Mergeable+      Data.Mergeable.Internal.Merge+      Data.Mergeable.Internal.NameCollision+      Data.Mergeable.Internal.Resolution+      Data.Mergeable.IsMap+      Data.Mergeable.MergeMap+      Data.Mergeable.OrdMap+      Data.Mergeable.SafeHashMap       Data.Morpheus.Error.Document.Interface       Data.Morpheus.Error.Fragment       Data.Morpheus.Error.Input-      Data.Morpheus.Error.NameCollision       Data.Morpheus.Error.Operation       Data.Morpheus.Error.Selection       Data.Morpheus.Error.Utils       Data.Morpheus.Error.Variable       Data.Morpheus.Error.Warning-      Data.Morpheus.Ext.Elems       Data.Morpheus.Ext.Empty-      Data.Morpheus.Ext.Failure       Data.Morpheus.Ext.KeyOf-      Data.Morpheus.Ext.Map-      Data.Morpheus.Ext.MergeSet-      Data.Morpheus.Ext.OrdMap       Data.Morpheus.Ext.Result-      Data.Morpheus.Ext.SafeHashMap-      Data.Morpheus.Ext.Selectable-      Data.Morpheus.Ext.SemigroupM       Data.Morpheus.Internal.Graph       Data.Morpheus.Parser       Data.Morpheus.Parsing.Document.TypeSystem       Data.Morpheus.Parsing.Internal.Arguments       Data.Morpheus.Parsing.Internal.Internal       Data.Morpheus.Parsing.Internal.Pattern+      Data.Morpheus.Parsing.Internal.SourceText       Data.Morpheus.Parsing.Internal.Terms       Data.Morpheus.Parsing.Internal.Value       Data.Morpheus.Parsing.Request.Operation@@ -193,10 +204,12 @@       Data.Morpheus.Schema.Schema       Data.Morpheus.Types.Internal.AST.Base       Data.Morpheus.Types.Internal.AST.DirectiveLocation+      Data.Morpheus.Types.Internal.AST.Error       Data.Morpheus.Types.Internal.AST.Fields+      Data.Morpheus.Types.Internal.AST.Name+      Data.Morpheus.Types.Internal.AST.OperationType       Data.Morpheus.Types.Internal.AST.Selection       Data.Morpheus.Types.Internal.AST.Stage-      Data.Morpheus.Types.Internal.AST.TH       Data.Morpheus.Types.Internal.AST.Type       Data.Morpheus.Types.Internal.AST.TypeCategory       Data.Morpheus.Types.Internal.AST.TypeSystem@@ -207,7 +220,9 @@       Data.Morpheus.Types.Internal.Validation.Error       Data.Morpheus.Types.Internal.Validation.Internal       Data.Morpheus.Types.Internal.Validation.SchemaValidator+      Data.Morpheus.Types.Internal.Validation.Scope       Data.Morpheus.Types.Internal.Validation.Validator+      Data.Morpheus.Validation.Document.Interface       Data.Morpheus.Validation.Document.Validation       Data.Morpheus.Validation.Internal.Arguments       Data.Morpheus.Validation.Internal.Directive@@ -240,13 +255,10 @@     , vector >=0.12.0.1 && <0.13   default-language: Haskell2010 -test-suite morpheus-test+test-suite morpheus-graphql-core-test   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:-      Utils.Rendering-      Utils.Schema-      Utils.Utils       Paths_morpheus_graphql_core   hs-source-dirs:       test@@ -260,6 +272,7 @@     , hashable >=1.0.0     , megaparsec >=7.0.0 && <10.0.0     , morpheus-graphql-core+    , morpheus-graphql-tests >=0.18.0 && <0.19.0     , mtl >=2.0 && <=3.0     , relude >=0.3.0     , scientific >=0.3.6.2 && <0.4

@@ -0,0 +1,27 @@+module Data.Mergeable+  ( Merge (..),+    mergeNoDuplicates,+    recursiveMerge,+    mergeConcat,+    Indexed (..),+    NameCollision (..),+    ResolutionT,+    fromListT,+    indexed,+    resolveWith,+    runResolutionT,+    collect,+    IsMap (..),+    MergeMap,+    toNonEmpty,+    OrdMap,+    throwErrors,+  )+where++import Data.Mergeable.Internal.Merge+import Data.Mergeable.Internal.NameCollision+import Data.Mergeable.Internal.Resolution+import Data.Mergeable.IsMap+import Data.Mergeable.MergeMap+import Data.Mergeable.OrdMap

@@ -0,0 +1,107 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Mergeable.Internal.Merge+  ( mergeConcat,+    Merge (..),+    mergeNoDuplicates,+    recursiveMerge,+    collect,+    throwErrors,+  )+where++import Control.Monad.Except (MonadError (throwError))+import qualified Data.HashMap.Lazy as HM+import Data.Mergeable.Internal.NameCollision (NameCollision (nameCollision))+import Data.Mergeable.Internal.Resolution+  ( fromListT,+    resolveWith,+    runResolutionT,+  )+import Relude hiding (empty, join)++class Merge m a where+  merge :: (Monad m) => a -> a -> m a++instance+  ( Eq k,+    Hashable k,+    MonadError e m,+    NameCollision e a+  ) =>+  Merge m (HashMap k a)+  where+  merge x y = mergeNoDuplicates HM.fromList (HM.toList x <> HM.toList y)++mergeConcat ::+  ( Monad m,+    Merge m a,+    MonadError e m+  ) =>+  NonEmpty a ->+  m a+mergeConcat (value :| []) = pure value+mergeConcat (value :| (x : xs)) = do+  a <- merge value x+  mergeConcat (a :| xs)++throwErrors :: MonadError e m => NonEmpty e -> m b+throwErrors (e :| es) = throwError e <* traverse throwError es++-- Merge Object with of Failure as an Option+failOnDuplicates :: (MonadError e m, NameCollision e a) => NonEmpty a -> m a+failOnDuplicates (x :| xs)+  | null xs = pure x+  | otherwise = throwErrors (nameCollision <$> x :| xs)++mergeOnDuplicates ::+  ( Monad m,+    Eq a,+    Merge m a+  ) =>+  a ->+  a ->+  m a+mergeOnDuplicates oldValue newValue+  | oldValue == newValue = pure oldValue+  | otherwise = merge oldValue newValue++mergeNoDuplicates ::+  ( Eq k,+    Hashable k,+    Monad m,+    MonadError e m,+    NameCollision e a+  ) =>+  ([(k, a)] -> b) ->+  [(k, a)] ->+  m b+mergeNoDuplicates f xs = runResolutionT (fromListT xs) f failOnDuplicates++recursiveMerge ::+  ( Eq k,+    Eq a,+    Hashable k,+    Monad m,+    Merge m a+  ) =>+  ([(k, a)] -> b) ->+  [(k, a)] ->+  m b+recursiveMerge f xs = runResolutionT (fromListT xs) f (resolveWith mergeOnDuplicates)++collect ::+  ( Eq k,+    Hashable k,+    Monad m,+    Semigroup v+  ) =>+  [(k, v)] ->+  m (HashMap k v)+collect xs = runResolutionT (fromListT xs) HM.fromList (resolveWith (\x y -> pure (x <> y)))

@@ -0,0 +1,18 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Mergeable.Internal.NameCollision+  ( NameCollision (..),+  )+where++import Data.Mergeable.Internal.Resolution (Indexed (..))+import Relude++class NameCollision e a where+  nameCollision :: a -> e++instance NameCollision e a => NameCollision e (Indexed k a) where+  nameCollision = nameCollision . indexedValue

@@ -0,0 +1,103 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Mergeable.Internal.Resolution+  ( Indexed (..),+    indexed,+    fromListT,+    resolveWith,+    runResolutionT,+    ResolutionT,+  )+where++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,47 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Mergeable.IsMap+  ( IsMap (..),+    selectBy,+    selectOr,+    FromList (..),+  )+where++import Control.Monad.Except (MonadError (throwError))+import qualified Data.HashMap.Lazy as HM+import Data.Mergeable.Internal.Merge (mergeNoDuplicates)+import Data.Mergeable.Internal.NameCollision (NameCollision)+import Relude++class IsMap k m | m -> k where+  unsafeFromList :: [(k, a)] -> m a++  singleton :: k -> a -> m a++  lookup :: k -> m a -> Maybe a++  member :: k -> m a -> Bool+  member = selectOr False (const True)++instance (Eq k, Hashable k) => IsMap k (HashMap k) where+  unsafeFromList = HM.fromList+  singleton = HM.singleton+  lookup = HM.lookup+  member = HM.member++selectBy :: (MonadError e m, IsMap k c, Monad m) => e -> k -> c a -> m a+selectBy err = selectOr (throwError err) pure++selectOr :: IsMap k c => d -> (a -> d) -> k -> c a -> d+selectOr fb f key lib = maybe fb f (lookup key lib)++class FromList m map k a where+  fromList :: (Monad m) => [(k, a)] -> m (map k a)++instance (Hashable k, Eq k, MonadError e m, NameCollision e a) => FromList m HashMap k a where+  fromList = mergeNoDuplicates HM.fromList

@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Mergeable.MergeMap+  ( MergeMap,+    toNonEmpty,+    partition,+  )+where++import Control.Monad.Except (MonadError (..))+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE (partition)+import qualified Data.List.NonEmpty as NM+import Data.Mergeable.Internal.Merge+  ( Merge (..),+    recursiveMerge,+  )+import Data.Mergeable.IsMap (FromList (..), IsMap (..))+import Language.Haskell.TH.Syntax (Lift (..))+import Relude hiding (fromList)++partition :: (a -> Bool) -> MergeMap dups k a -> (Maybe (MergeMap dups k a), Maybe (MergeMap dups k a))+partition f (MergeMap xs) =+  case NE.partition (f . snd) xs of+    ([], _) -> (Nothing, Just (MergeMap xs))+    (_, []) -> (Just (MergeMap xs), Nothing)+    (a : as, b : bs) -> (Just (MergeMap (a :| as)), Just (MergeMap (b :| bs)))++newtype MergeMap (dups :: Bool) k a = MergeMap+  { unpack :: NonEmpty (k, a)+  }+  deriving+    ( Show,+      Eq,+      Functor,+      Foldable,+      Traversable+    )++instance (Lift a, Lift k) => Lift (MergeMap dups k a) where+  lift (MergeMap (x :| xs)) = [|MergeMap (x :| xs)|]++#if MIN_VERSION_template_haskell(2,16,0)+  liftTyped (MergeMap (x :| xs))  = [|| MergeMap (x :| xs) ||]+#endif++instance+  (Hashable k, Eq k) =>+  IsMap k (MergeMap dups k)+  where+  unsafeFromList (x : xs) = MergeMap (x :| xs)+  unsafeFromList [] = error "empty selection sets are not supported."+  singleton k x = MergeMap ((k, x) :| [])+  lookup key (MergeMap (x :| xs)) = L.lookup key (x : xs)++instance+  ( Monad m,+    Eq a,+    Merge m a,+    Hashable k,+    Eq k+  ) =>+  Merge m (MergeMap 'False k a)+  where+  merge (MergeMap x) (MergeMap y) = resolveMergeable (x <> y)++instance Monad m => Merge m (MergeMap 'True k a) where+  merge (MergeMap x) (MergeMap y) = pure $ MergeMap $ x <> y++resolveMergeable ::+  ( Monad m,+    Eq a,+    Merge m a,+    Hashable k,+    Eq k+  ) =>+  NonEmpty (k, a) ->+  m (MergeMap dups k a)+resolveMergeable (x :| xs) = recursiveMerge (MergeMap . NM.fromList) (x : xs)++toNonEmpty :: (IsString e, MonadError e f) => [a] -> f (NonEmpty a)+toNonEmpty [] = throwError $ fromString "empty selection sets are not supported."+toNonEmpty (x : xs) = pure (x :| xs)++instance+  ( Hashable k,+    Eq k,+    Eq a,+    IsString e,+    MonadError e m,+    Merge m a+  ) =>+  FromList m (MergeMap 'False) k a+  where+  fromList = resolveMergeable <=< toNonEmpty++instance+  ( IsString e,+    MonadError e m+  ) =>+  FromList m (MergeMap 'True) k a+  where+  fromList = fmap MergeMap . toNonEmpty

@@ -0,0 +1,88 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Mergeable.OrdMap+  ( OrdMap (..),+  )+where++import Control.Monad.Except (MonadError)+import qualified Data.HashMap.Lazy as HM+import Data.Mergeable.Internal.Merge (Merge (..))+import Data.Mergeable.Internal.NameCollision (NameCollision (..))+import Data.Mergeable.Internal.Resolution+  ( Indexed (..),+    indexed,+  )+import Data.Mergeable.IsMap+  ( FromList (..),+    IsMap (..),+  )+import Data.Morpheus.Ext.Empty (Empty (..))+import Language.Haskell.TH.Syntax (Lift (..))+import Relude hiding (fromList)++-- OrdMap+newtype OrdMap k a = OrdMap+  { mapEntries :: HashMap k (Indexed k a)+  }+  deriving+    ( Show,+      Eq,+      Functor,+      Traversable,+      Empty+    )++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 (Eq k, Hashable k) => IsMap k (OrdMap k) where+  unsafeFromList = OrdMap . HM.fromList . fmap withKey . indexed+    where+      withKey idx = (indexedKey idx, idx)+  singleton k x = OrdMap $ HM.singleton k (Indexed 0 k x)+  lookup key OrdMap {mapEntries} = indexedValue <$> lookup key mapEntries++instance (NameCollision e a, Eq k, Hashable k, Monad m, MonadError e m) => Merge m (OrdMap k a) where+  merge (OrdMap x) (OrdMap y) = OrdMap <$> merge x (fmap (shiftIndexes (HM.size x)) y)++shiftIndexes :: Int -> Indexed k a -> Indexed k a+shiftIndexes n Indexed {..} = Indexed {index = index + n, ..}++instance+  ( Hashable k,+    Eq k,+    NameCollision e a,+    MonadError e m+  ) =>+  FromList m OrdMap k a+  where+  fromList = fmap OrdMap . fromList . map xyz . indexed+    where+      xyz x = (indexedKey x, x)

@@ -0,0 +1,59 @@+{-# 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 UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Mergeable.SafeHashMap+  ( SafeHashMap,+    toHashMap,+  )+where++import Control.Monad.Except (MonadError)+import qualified Data.HashMap.Lazy as HM+import Data.Mergeable+  ( Merge (..),+    NameCollision (..),+  )+import Data.Mergeable.IsMap (IsMap)+import Data.Morpheus.Ext.Empty (Empty)+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+    ( IsMap k,+      Empty+    )++toHashMap :: SafeHashMap k a -> HashMap k a+toHashMap = unpackSafeHashMap++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 e a, Monad m, Hashable k, Eq k, MonadError e m) => Merge m (SafeHashMap k a) where+  merge (SafeHashMap x) (SafeHashMap y) = SafeHashMap <$> merge x y

@@ -30,11 +30,9 @@   ( ByteString,   ) import Data.Morpheus.Ext.Result-  ( Eventless,-  )-import Data.Morpheus.Ext.SemigroupM-  ( (<:>),+  ( GQLResult,   )+import Data.Morpheus.Internal.Utils ((<:>)) import Data.Morpheus.Parser   ( parseRequest,     parseRequestWith,@@ -60,5 +58,5 @@   ) import Relude hiding (ByteString) -parseFullSchema :: ByteString -> Eventless (Schema VALID)+parseFullSchema :: ByteString -> GQLResult (Schema VALID) parseFullSchema = parseSchema >=> (internalSchema <:>)

@@ -3,21 +3,15 @@ module Data.Morpheus.Error   ( errorMessage,     globalErrorMessage,-    gqlWarnings,     renderGQLErrors,     deprecatedField,     subfieldsNotSelected,     NameCollision (..),+    gqlWarnings,   ) where -import Data.Morpheus.Error.NameCollision (NameCollision (..))+import Data.Mergeable import Data.Morpheus.Error.Selection-  ( subfieldsNotSelected,-  ) import Data.Morpheus.Error.Utils import Data.Morpheus.Error.Warning-  ( deprecatedField,-    gqlWarnings,-    renderGQLErrors,-  )

@@ -1,33 +1,36 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Document.Interface   ( unknownInterface,-    PartialImplements (..),     ImplementsError (..),-    Place (..),+    partialImplements,   ) where -import Data.Maybe (Maybe (..))-import Data.Morpheus.Types.Internal.AST.Base-  ( FieldName (..),-    TypeName (..),-    ValidationError,-    msgValidation,+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,+    msg,   )+import Data.Morpheus.Types.Internal.AST.Name+  ( TypeName,+  ) import Data.Morpheus.Types.Internal.AST.Type (TypeRef) import Data.Morpheus.Types.Internal.Validation.SchemaValidator   ( Field (..),-    Interface (..),+    InterfaceName (..),+    ON_INTERFACE,+    TypeEntity (..),     renderField,   )-import Data.Semigroup ((<>))+import Relude -unknownInterface :: TypeName -> ValidationError-unknownInterface name = "Unknown Interface " <> msgValidation name <> "."+unknownInterface :: TypeName -> GQLError+unknownInterface name = "Unknown Interface " <> msg name <> "."  data ImplementsError   = UnexpectedType@@ -36,55 +39,27 @@       }   | Missing -data Place = Place-  { fieldname :: TypeName,-    typename :: FieldName,-    fieldArg :: Maybe (FieldName, TypeName)-  }--class PartialImplements ctx where-  partialImplements :: ctx -> ImplementsError -> ValidationError--instance PartialImplements (Interface, FieldName) where-  partialImplements (Interface interfaceName typename, fieldname) errorType =-    "Interface field "-      <> renderField interfaceName fieldname Nothing-      <> detailedMessage errorType-    where-      detailedMessage UnexpectedType {expectedType, foundType} =-        " expects type "-          <> msgValidation expectedType-          <> " but "-          <> renderField typename fieldname Nothing-          <> " is type "-          <> msgValidation foundType-          <> "."-      detailedMessage Missing =-        " expected but "-          <> msgValidation typename-          <> " does not provide it."+partialImplements :: Field ON_INTERFACE -> ImplementsError -> GQLError+partialImplements (Field fieldName argName (TypeEntity (OnInterface interfaceName) typename)) errorType =+  "Interface field " <> maybe "" (const "argument ") argName+    <> renderField interfaceName fieldName argName+    <> detailedMessageGen+      (renderField typename fieldName argName)+      (maybe (msg typename) (const $ renderField typename fieldName Nothing) argName)+      errorType  -- Interface field TestInterface.name expected but User does not provide it. -- Interface field TestInterface.name expects type String! but User.name is type Int!.--instance PartialImplements (Interface, Field) where-  partialImplements (Interface interfaceName typename, Field fieldname argName) errorType =-    "Interface field argument "-      <> renderField interfaceName fieldname (Just argName)-      <> detailedMessage errorType-    where-      detailedMessage UnexpectedType {expectedType, foundType} =-        " expects type"-          <> msgValidation expectedType-          <> " but "-          <> renderField typename fieldname (Just argName)-          <> " is type "-          <> msgValidation foundType-          <> "."-      detailedMessage Missing =-        " expected but "-          <> renderField typename fieldname Nothing-          <> " does not provide it."- -- Interface field argument TestInterface.name(id:) expected but User.name does not provide it. -- Interface field argument TestInterface.name(id:) expects type ID but User.name(id:) is type String.++detailedMessageGen :: GQLError -> GQLError -> ImplementsError -> GQLError+detailedMessageGen pl1 _ UnexpectedType {expectedType, foundType} =+  " expects type "+    <> msg expectedType+    <> " but "+    <> pl1+    <> " is type "+    <> msg foundType+    <> "."+detailedMessageGen _ pl2 Missing = " expected but " <> pl2 <> " does not provide it."

@@ -8,16 +8,21 @@ where  -- MORPHEUS-import Data.Morpheus.Error.Utils (validationErrorMessage) import Data.Morpheus.Types.Internal.AST.Base-  ( FieldName,-    Position,+  ( Position,     Ref (..),-    TypeName,-    ValidationError (..),+  )+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,+    at,+    atPositions,+    manyMsg,     msg,-    msgSepBy,   )+import Data.Morpheus.Types.Internal.AST.Name+  ( FragmentName,+    TypeName,+  ) import Relude  {-@@ -32,30 +37,28 @@     {...H} -> "Unknown fragment \"H\"." -} -cannotSpreadWithinItself :: NonEmpty (Ref FieldName) -> ValidationError-cannotSpreadWithinItself (fr :| frs) = ValidationError text (fmap refPosition (fr : frs))-  where-    text =-      "Cannot spread fragment "-        <> msg (refName fr)-        <> " within itself via "-        <> msgSepBy ", " (fmap refName (fr : frs))-        <> "."+cannotSpreadWithinItself :: NonEmpty (Ref FragmentName) -> GQLError+cannotSpreadWithinItself (fr :| frs) =+  ( "Cannot spread fragment "+      <> msg (refName fr)+      <> " within itself via "+      <> manyMsg (refName <$> (fr : frs))+      <> "."+  )+    `atPositions` map refPosition (fr : frs)  -- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."-cannotBeSpreadOnType :: Maybe FieldName -> TypeName -> Position -> [TypeName] -> ValidationError+cannotBeSpreadOnType :: Maybe FragmentName -> TypeName -> Position -> [TypeName] -> GQLError cannotBeSpreadOnType key fragmentType position typeMembers =-  validationErrorMessage-    (Just position)-    text+  ( "Fragment "+      <> getName key+      <> "cannot be spread here as objects of type "+      <> manyMsg typeMembers+      <> " can never be of type "+      <> msg fragmentType+      <> "."+  )+    `at` position   where-    text =-      "Fragment "-        <> getName key-        <> "cannot be spread here as objects of type "-        <> msgSepBy ", " typeMembers-        <> " can never be of type "-        <> msg fragmentType-        <> "."     getName (Just x) = msg x <> " "     getName Nothing = ""

@@ -7,19 +7,19 @@ where  import Data.Morpheus.Types.Internal.AST-  ( TypeRef (..),-    ValidationError,+  ( GQLError,+    TypeRef (..),     Value,-    msgValidation,+    msg,   ) import Data.Semigroup ((<>)) -typeViolation :: TypeRef -> Value s -> ValidationError+typeViolation :: TypeRef -> Value s -> GQLError typeViolation expected found =   "Expected type "-    <> msgValidation expected+    <> msg expected     <> " found "-    <> msgValidation found+    <> msg found     <> "."  {-

@@ -1,18 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Error.NameCollision-  ( NameCollision (..),-  )-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

@@ -9,17 +9,16 @@  import Data.Morpheus.Types.Internal.AST.Base   ( Position,-    ValidationError (..),   )+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,+    at,+  ) -mutationIsNotDefined :: Position -> ValidationError+mutationIsNotDefined :: Position -> GQLError mutationIsNotDefined position =-  ValidationError-    "Schema is not configured for mutations."-    [position]+  "Schema is not configured for mutations." `at` position -subscriptionIsNotDefined :: Position -> ValidationError+subscriptionIsNotDefined :: Position -> GQLError subscriptionIsNotDefined position =-  ValidationError-    "Schema is not configured for subscriptions."-    [position]+  "Schema is not configured for subscriptions." `at` position

@@ -11,19 +11,20 @@  import Data.Morpheus.Types.Internal.AST   ( FieldName,+    GQLError,     Position,     Ref (..),     TypeDefinition (..),     TypeName,     VALID,-    ValidationError (..),+    at,     msg,   ) import Data.Semigroup ((<>))  -- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields."-hasNoSubfields :: Ref FieldName -> TypeDefinition s VALID -> ValidationError-hasNoSubfields (Ref selectionName position) TypeDefinition {typeName} = ValidationError text [position]+hasNoSubfields :: Ref FieldName -> TypeDefinition s VALID -> GQLError+hasNoSubfields (Ref selectionName position) TypeDefinition {typeName} = text `at` position   where     text =       "Field "@@ -32,8 +33,8 @@         <> msg typeName         <> " has no subfields." -unknownSelectionField :: TypeName -> Ref FieldName -> ValidationError-unknownSelectionField typeName Ref {refName, refPosition} = ValidationError text [refPosition]+unknownSelectionField :: TypeName -> Ref FieldName -> GQLError+unknownSelectionField typeName Ref {refName, refPosition} = text `at` refPosition   where     text =       "Cannot query field " <> msg refName@@ -42,8 +43,8 @@         <> "."  -- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"?-subfieldsNotSelected :: FieldName -> TypeName -> Position -> ValidationError-subfieldsNotSelected fieldName typeName position = ValidationError text [position]+subfieldsNotSelected :: FieldName -> TypeName -> Position -> GQLError+subfieldsNotSelected fieldName typeName position = text `at` position   where     text =       "Field " <> msg fieldName <> " of type "

@@ -1,27 +1,25 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Utils   ( errorMessage,     globalErrorMessage,-    validationErrorMessage,   ) where  import Data.Morpheus.Types.Internal.AST.Base-  ( GQLError (..),-    GQLErrors,+  ( Position (..),+  )+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,     Message,-    Position (..),-    ValidationError (..),+    at,+    msg,   )-import Relude hiding (ByteString) -validationErrorMessage :: Maybe Position -> Message -> ValidationError-validationErrorMessage pos message = ValidationError message (maybeToList pos)--errorMessage :: Position -> Message -> GQLErrors-errorMessage position message = [GQLError {message, locations = [position]}]+{-# DEPRECATED errorMessage "\"my error\" `at` position" #-}+errorMessage :: Position -> Message -> [GQLError]+errorMessage position message = [msg message `at` position] -globalErrorMessage :: Message -> GQLErrors-globalErrorMessage message = [GQLError {message, locations = []}]+{-# DEPRECATED globalErrorMessage "use validation errors" #-}+globalErrorMessage :: Message -> [GQLError]+globalErrorMessage message = [msg message]

@@ -8,40 +8,39 @@   ) where -import Data.Morpheus.Error.Utils (validationErrorMessage) import Data.Morpheus.Types.Internal.AST   ( FieldName,+    GQLError,     Ref (..),     TypeRef,-    ValidationError,     Variable (..),+    at,     msg,   ) import Relude  -- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"."-incompatibleVariableType :: Ref FieldName -> Variable s -> TypeRef -> ValidationError+incompatibleVariableType :: Ref FieldName -> Variable s -> TypeRef -> GQLError incompatibleVariableType   (Ref variableName argPosition)   Variable {variableType}   argumentType =-    validationErrorMessage (Just argPosition) text-    where-      text =-        "Variable "-          <> msg ("$" <> variableName)-          <> " of type "-          <> msg variableType-          <> " used in position expecting type "-          <> msg argumentType-          <> "."+    ( "Variable "+        <> msg ("$" <> variableName)+        <> " of type "+        <> msg variableType+        <> " used in position expecting type "+        <> msg argumentType+        <> "."+    )+      `at` argPosition -uninitializedVariable :: Variable s -> ValidationError+uninitializedVariable :: Variable s -> GQLError uninitializedVariable Variable {variableName, variableType, variablePosition} =-  validationErrorMessage-    (Just variablePosition)-    $ "Variable "+  ( "Variable "       <> msg ("$" <> variableName)       <> " of required type "       <> msg variableType       <> " was not provided."+  )+    `at` variablePosition

@@ -12,41 +12,46 @@  import Data.Aeson (encode) import Data.ByteString.Lazy.Char8 (unpack)-import Data.Morpheus.Error.Utils (errorMessage) import Data.Morpheus.Types.Internal.AST.Base   ( Description,-    FieldName,-    GQLErrors,     Ref (..),+  )+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,+    GQLErrors,+    at,     msg,+    msg,   )-import Language.Haskell.TH (Q, reportWarning)+import Data.Morpheus.Types.Internal.AST.Name+  ( FieldName,+  )+import Language.Haskell.TH import Relude  renderGQLErrors :: GQLErrors -> String-renderGQLErrors = unpack . encode+renderGQLErrors = unpack . encode . toList -deprecatedEnum :: FieldName -> Ref FieldName -> Maybe Description -> GQLErrors+-- TODO: implement warnings, is not used+deprecatedEnum :: FieldName -> Ref FieldName -> Maybe Description -> GQLError deprecatedEnum typeName Ref {refPosition, refName} reason =-  errorMessage refPosition $-    "the enum value "-      <> msg typeName-      <> "."-      <> msg refName-      <> " is deprecated."-      <> msg (maybe "" (" " <>) reason)+  "the enum value "+    <> msg typeName+    <> "."+    <> msg refName+    <> " is deprecated."+    <> msg (maybe "" (" " <>) reason) `at` refPosition -deprecatedField :: FieldName -> Ref FieldName -> Maybe Description -> GQLErrors+deprecatedField :: FieldName -> Ref FieldName -> Maybe Description -> GQLError deprecatedField typeName Ref {refPosition, refName} reason =-  errorMessage refPosition $-    "the field "-      <> msg typeName-      <> "."-      <> msg refName-      <> " is deprecated."-      <> msg (maybe "" (" " <>) reason)+  "the field "+    <> msg typeName+    <> "."+    <> msg refName+    <> " is deprecated."+    <> msg (maybe "" (" " <>) reason) `at` refPosition -gqlWarnings :: GQLErrors -> Q ()+gqlWarnings :: [GQLError] -> Q () gqlWarnings [] = pure () gqlWarnings warnings = traverse_ handleWarning warnings   where

@@ -1,25 +0,0 @@-{-# 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

@@ -1,21 +0,0 @@-{-# 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

@@ -8,7 +8,7 @@   ) where -import Data.Morpheus.Ext.Map+import Data.Mergeable   ( Indexed (..),   ) import Data.Morpheus.Types.Internal.AST.Base

@@ -1,103 +0,0 @@-{-# 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 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

@@ -1,119 +0,0 @@-{-# 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.Empty (Empty (..))-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-  ( FieldName,-    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,-      Empty-    )--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 FieldName] ->-  [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 FieldName] ->-  a ->-  a ->-  m a-resolveConflict path oldValue newValue-  | oldValue == newValue = pure oldValue-  | otherwise = mergeM path oldValue newValue

@@ -1,93 +0,0 @@-{-# 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.Empty (Empty (..))-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,-      Empty-    )--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-  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)

@@ -4,130 +4,133 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Ext.Result-  ( Eventless,-    Result (..),-    Failure (..),+  ( Result (..),     ResultT (..),-    unpackEvents,     mapEvent,     cleanEvents,     PushEvents (..),     resultOr,     sortErrors,+    toEither,+    GQLResult,   ) where -import Data.Morpheus.Internal.Utils-  ( Failure (..),-  )-import Data.Morpheus.Types.Internal.AST.Base+import Control.Monad.Except (MonadError (..))+import qualified Data.List.NonEmpty as NE+import Data.Morpheus.Types.Internal.AST.Error   ( GQLError (..),-    GQLErrors,-    ValidationError (..),-    toGQLError,+    GQLError,   )+import Data.Text.Lazy.Builder () import Relude -type Eventless = Result ()+type GQLResult = Result GQLError  -- EVENTS class PushEvents e m where   pushEvents :: [e] -> m () -unpackEvents :: Result event a -> [event]-unpackEvents Success {events} = events-unpackEvents _ = []- -- -- Result -- ---data Result events a-  = Success {result :: a, warnings :: GQLErrors, events :: [events]}-  | Failure {errors :: GQLErrors}+data Result err a+  = Success {result :: a, warnings :: [err]}+  | Failure {errors :: NonEmpty err}   deriving (Functor) -instance Applicative (Result e) where-  pure x = Success x [] []-  Success f w1 e1 <*> Success x w2 e2 = Success (f x) (w1 <> w2) (e1 <> e2)+instance Applicative (Result er) where+  pure x = Success x []+  Success f w1 <*> Success x w2 = Success (f x) (w1 <> w2)   Failure e1 <*> Failure e2 = Failure (e1 <> e2)-  Failure e <*> Success _ w _ = Failure (e <> w)-  Success _ w _ <*> Failure e = Failure (e <> w)+  Failure (e :| es) <*> Success _ w = Failure (e :| es <> w)+  Success _ w <*> Failure (e :| es) = Failure (e :| es <> w) -instance Monad (Result e) where+instance Monad (Result er) where   return = pure-  Success v w1 e1 >>= fm = case fm v of-    (Success x w2 e2) -> Success x (w1 <> w2) (e1 <> e2)-    (Failure e) -> Failure (e <> w1)+  Success v w1 >>= fm = case fm v of+    (Success x w2) -> Success x (w1 <> w2)+    (Failure (e :| es)) -> Failure (e :| es <> w1)   Failure e >>= _ = Failure e -instance Failure [GQLError] (Result ev) where-  failure = Failure+instance Bifunctor Result where+  bimap f g Success {..} = Success {warnings = f <$> warnings, result = g result, ..}+  bimap f _ Failure {..} = Failure (f <$> errors) -instance PushEvents events (Result events) where-  pushEvents events = Success {result = (), warnings = [], events}+instance MonadError er (Result er) where+  throwError = Failure . pure+  catchError (Failure (x :| _)) f = f x+  catchError x _ = x -instance Failure [ValidationError] (Result ev) where-  failure = failure . fmap toGQLError+instance IsString err => MonadFail (Result err) where+  fail = Failure . pure . fromString -resultOr :: (GQLErrors -> a') -> (a -> a') -> Result e a -> a'-resultOr _ f (Success x _ _) = f x-resultOr f _ (Failure e) = f e+resultOr :: (NonEmpty err -> a') -> (a -> a') -> Result err a -> a'+resultOr _ f Success {result} = f result+resultOr f _ Failure {errors} = f errors -sortErrors :: Result e a -> Result e a-sortErrors (Failure errors) = Failure (sortOn locations errors)+sortErrors :: Result GQLError a -> Result GQLError a+sortErrors (Failure errors) = Failure (NE.sort errors) sortErrors x = x  -- ResultT-newtype ResultT event (m :: * -> *) a = ResultT-  { runResultT :: m (Result event a)+newtype ResultT event (m :: Type -> Type) a = ResultT+  { runResultT :: m (Result GQLError ([event], a))   }   deriving (Functor)  instance Applicative m => Applicative (ResultT event m) where-  pure = ResultT . pure . pure-  ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) app1 app2+  pure = ResultT . pure . pure . ([],)+  ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) (fx <$> app1) app2+    where+      fx :: Monad f => f ([event], a -> b) -> f (([event], a) -> ([event], b))+      fx x = do+        (e', f) <- x+        pure $ \(e, a) -> (e <> e', f a)  instance Monad m => Monad (ResultT event m) where   return = pure   (ResultT m1) >>= mFunc = ResultT $ do-    result1 <- m1-    case result1 of+    result <- m1+    case result of       Failure errors -> pure $ Failure errors-      Success value1 w1 e1 -> do-        result2 <- runResultT (mFunc value1)-        case result2 of-          Failure errors -> pure $ Failure (errors <> w1)-          Success v2 w2 e2 -> pure $ Success v2 (w1 <> w2) (e1 <> e2)+      Success (events, value) w1 -> do+        result' <- runResultT (mFunc value)+        case result' of+          Failure (e :| es) -> pure $ Failure (e :| es <> w1)+          Success (events', value') w2 -> pure $ Success (events <> events', value') (w1 <> w2)  instance MonadTrans (ResultT event) where-  lift = ResultT . fmap pure+  lift = ResultT . fmap (pure . ([],)) -instance Monad m => Failure GQLErrors (ResultT event m) where-  failure = ResultT . pure . failure+instance Monad m => MonadError GQLError (ResultT event m) where+  throwError = ResultT . pure . throwError+  catchError (ResultT mx) f = ResultT (mx >>= catchResultError)+    where+      catchResultError (Failure (x :| _)) = runResultT (f x)+      catchResultError x = pure x  instance Applicative m => PushEvents event (ResultT event m) where-  pushEvents = ResultT . pure . pushEvents+  pushEvents x = ResultT $ pure $ pure (x, ())  cleanEvents ::   Functor m =>   ResultT e m a ->   ResultT e' m a-cleanEvents resT = ResultT $ replace <$> runResultT resT-  where-    replace (Success v w _) = Success v w []-    replace (Failure e) = Failure e+cleanEvents resT = ResultT $ fmap (first (const [])) <$> runResultT resT  mapEvent ::   Monad m =>   (e -> e') ->   ResultT e m value ->   ResultT e' m value-mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma-  where-    mapEv Success {result, warnings, events} =-      Success {result, warnings, events = fmap func events}-    mapEv (Failure err) = Failure err+mapEvent func (ResultT ma) = ResultT $ fmap (first (map func)) <$> ma++toEither :: Result err b -> Either (NonEmpty err) b+toEither = resultOr Left Right

@@ -1,83 +0,0 @@-{-# 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.Empty (Empty)-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,-      Empty-    )--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, Hashable k) => [(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)

@@ -1,29 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Ext.Selectable-  ( Selectable (..),-    selectBy,-  )-where--import qualified Data.HashMap.Lazy as HM-import Data.Morpheus.Ext.Failure (Failure (..))-import Data.Morpheus.Ext.KeyOf (KeyOf (..))-import Relude--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)--instance (Eq k, Hashable k) => Selectable k a (HashMap k a) where-  selectOr fb f key lib = maybe fb f (HM.lookup key lib)--selectBy :: (Failure e m, Selectable k a c, Monad m) => e -> k -> c -> m a-selectBy err = selectOr (failure err) pure

@@ -1,83 +0,0 @@-{-# 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.Empty (Empty (..))-import Data.Morpheus.Ext.KeyOf (KeyOf (..))-import Data.Morpheus.Ext.Map-  ( fromListT,-    runResolutionT,-  )-import Data.Morpheus.Internal.Utils-  ( Elems (..),-    Failure,-    failOnDuplicates,-  )-import Data.Morpheus.Types.Internal.AST.Base-  ( FieldName,-    Ref,-    ValidationErrors,-  )-import Relude-  ( ($),-    Applicative (..),-    Monad (..),-    Semigroup (..),-    Traversable (..),-  )--class SemigroupM (m :: * -> *) a where-  mergeM :: [Ref FieldName] -> 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,-    Elems a ca,-    SemigroupM m cb,-    Empty cb-  ) =>-  (a -> m cb) ->-  ca ->-  m cb-concatTraverse f smap =-  traverse f (elems smap)-    >>= join--join ::-  ( Empty 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 []

@@ -1,37 +1,25 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Internal.Ext-  ( Eventless,-    Failure (..),+  ( Failure,     PushEvents (..),     Result (..),     ResultT (..),     cleanEvents,     resultOr,-    SemigroupM (..),     mapEvent,-    unpackEvents,     sortErrors,     unsafeFromList,     (<:>),     resolveWith,     runResolutionT,+    toEither,+    Merge (..),+    failure,+    GQLResult,   ) where -import Data.Morpheus.Ext.KeyOf-import Data.Morpheus.Ext.Map-import qualified Data.Morpheus.Ext.OrdMap as OM+import Data.Mergeable import Data.Morpheus.Ext.Result-import qualified Data.Morpheus.Ext.SafeHashMap as SHM-import Data.Morpheus.Ext.SemigroupM-import Relude--class UnsafeFromList f where-  unsafeFromList :: (Hashable k, KeyOf k a, Eq k) => [(k, a)] -> f k a--instance UnsafeFromList OM.OrdMap where-  unsafeFromList = OM.unsafeFromList--instance UnsafeFromList SHM.SafeHashMap where-  unsafeFromList = SHM.unsafeFromList+import Data.Morpheus.Internal.Utils

@@ -1,179 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Internal.TH-  ( _',-    apply,-    applyCons,-    applyVars,-    declareTypeRef,-    funDSimple,-    nameSpaceField,-    nameSpaceType,-    toCon,-    toVar,-    ToName (..),-    toString,-    typeInstanceDec,-    v',-    vars,-  )-where--import Data.Morpheus.Internal.Utils-  ( capitalize,-    nameSpaceField,-    nameSpaceType,-  )-import Data.Morpheus.Types.Internal.AST-  ( FieldName (..),-    TypeName (..),-    TypeRef (..),-    TypeWrapper (..),-    convertToHaskellName,-    readName,-  )-import Data.Text (unpack)-import Language.Haskell.TH-import Relude hiding-  ( ToString (..),-    Type,-  )--_' :: PatQ-_' = toVar (mkName "_")--v' :: ToVar Name a => a-v' = toVar (mkName "v")--declareTypeRef :: (TypeName -> Type) -> TypeRef -> Type-declareTypeRef f TypeRef {typeConName, typeWrappers} =-  wrappedT-    typeWrappers-  where-    wrappedT :: [TypeWrapper] -> Type-    wrappedT (TypeList : xs) = AppT (ConT ''[]) $ wrappedT xs-    wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs-    wrappedT [] = f typeConName--cons :: ToCon a b => [a] -> [b]-cons = map toCon--vars :: ToVar a b => [a] -> [b]-vars = map toVar--class ToName a where-  toName :: a -> Name--instance ToName String where-  toName = mkName--instance ToName Name where-  toName = id--instance ToName TypeName where-  toName = mkName . unpack . capitalize . readTypeName--instance ToName FieldName where-  toName = mkName . unpack . readName . convertToHaskellName--class ToString a b where-  toString :: a -> b--instance ToString a b => ToString a (Q b) where-  toString = pure . toString--instance ToString TypeName Lit where-  toString = stringL . unpack . readTypeName--instance ToString TypeName Pat where-  toString = LitP . toString--instance ToString FieldName Lit where-  toString (FieldName x) = stringL (unpack x)--instance ToString TypeName Exp where-  toString = LitE . toString--instance ToString FieldName Exp where-  toString = LitE . toString--class ToCon a b where-  toCon :: a -> b--instance ToCon a b => ToCon a (Q b) where-  toCon = pure . toCon--instance (ToName a) => ToCon a Type where-  toCon = ConT . toName--instance (ToName a) => ToCon a Exp where-  toCon = ConE . toName--class ToVar a b where-  toVar :: a -> b--instance ToVar a b => ToVar a (Q b) where-  toVar = pure . toVar--instance (ToName a) => ToVar a Type where-  toVar = VarT . toName--instance (ToName a) => ToVar a Exp where-  toVar = VarE . toName--instance (ToName a) => ToVar a Pat where-  toVar = VarP . toName--class Apply a where-  apply :: ToCon i a => i -> [a] -> a--instance Apply TypeQ where-  apply = foldl' appT . toCon--instance Apply Type where-  apply = foldl' AppT . toCon--instance Apply Exp where-  apply = foldl' AppE . toCon--instance Apply ExpQ where-  apply = foldl' appE . toCon--applyVars ::-  ( ToName con,-    ToName var,-    Apply res,-    ToCon con res,-    ToVar var res-  ) =>-  con ->-  [var] ->-  res-applyVars name li = apply name (vars li)--applyCons :: (ToName con, ToName cons) => con -> [cons] -> Q Type-applyCons name li = apply name (cons li)--funDSimple :: Name -> [PatQ] -> ExpQ -> DecQ-funDSimple name args body = funD name [clause args (normalB body) []]--#if MIN_VERSION_template_haskell(2,15,0)--- fix breaking changes-typeInstanceDec :: Name -> Type -> Type -> Dec-typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res)-#else----typeInstanceDec :: Name -> Type -> Type -> Dec-typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res)-#endif

@@ -1,65 +1,63 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Internal.Utils-  ( capitalize,-    nameSpaceField,-    nameSpaceType,-    capitalTypeName,-    Collection (..),-    Selectable (..),-    FromElems (..),-    Failure (..),+  ( singleton,+    IsMap,+    Failure,+    failure,     KeyOf (..),     toPair,     selectBy,-    mapFst,-    mapSnd,-    mapTuple,     traverseCollection,     prop,-    stripFieldNamespace,-    stripConstructorNamespace,     fromLBS,     toLBS,     mergeT,-    Elems (..),-    size,-    failOnDuplicates,     Empty (..),+    elems,+    HistoryT,+    addPath,+    startHistory,+    mergeConcat,+    (<:>),+    selectOr,+    member,+    unsafeFromList,+    insert,+    fromElems,+    throwErrors,   ) where +import Control.Monad.Except (MonadError (throwError)) import Data.ByteString.Lazy (ByteString)-import Data.Char-  ( toLower,-    toUpper,+import Data.Mergeable+  ( IsMap,+    Merge (merge),+    NameCollision (..),+    ResolutionT,+    fromListT,+    mergeConcat,+    throwErrors,   )-import qualified Data.HashMap.Lazy as HM-import Data.Morpheus.Error.NameCollision (NameCollision (..))-import Data.Morpheus.Ext.Elems (Elems (..), size)+import Data.Mergeable.IsMap (FromList (..), member, selectBy, selectOr, unsafeFromList)+import qualified Data.Mergeable.IsMap as M+import Data.Mergeable.SafeHashMap (SafeHashMap) import Data.Morpheus.Ext.Empty-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 (Ref)+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,   )-import Data.Morpheus.Ext.Selectable-import Data.Morpheus.Types.Internal.AST.Base+import Data.Morpheus.Types.Internal.AST.Name   ( FieldName,-    FieldName (..),-    Token,-    TypeName (..),-    ValidationErrors,   )-import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import Instances.TH.Lift ()@@ -67,100 +65,74 @@   ( ByteString,     decodeUtf8,     encodeUtf8,+    fromList,   ) -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)--nameSpaceType :: [FieldName] -> TypeName -> TypeName-nameSpaceType list (TypeName name) = TypeName . T.concat $ fmap capitalize (fmap readName list <> [name])+{-# DEPRECATED Failure "use MonadError" #-} -nameSpaceField :: TypeName -> FieldName -> FieldName-nameSpaceField (TypeName nSpace) (FieldName name) = FieldName (uncapitalize nSpace <> capitalize name)+type Failure = MonadError -dropPrefix :: TypeName -> String -> String-dropPrefix (TypeName name) = drop (T.length name)+{-# DEPRECATED failure "use throwError" #-}+failure :: MonadError e m => e -> m a+failure = throwError -stripConstructorNamespace :: TypeName -> String -> String-stripConstructorNamespace = dropPrefix+(<:>) :: (Merge (HistoryT m) a, Monad m) => a -> a -> m a+x <:> y = startHistory (merge x y) -stripFieldNamespace :: TypeName -> String -> String-stripFieldNamespace prefix = __uncapitalize . dropPrefix prefix-  where-    __uncapitalize [] = []-    __uncapitalize (x : xs) = toLower x : xs+addPath :: MonadReader [a1] m => a1 -> m a2 -> m a2+addPath p = local (\xs -> xs <> [p]) -capitalize :: Text -> Text-capitalize = mapFstChar toUpper+type HistoryT = ReaderT [Ref FieldName] -uncapitalize :: Text -> Text-uncapitalize = mapFstChar toLower+startHistory :: HistoryT m a -> m a+startHistory x = runReaderT x [] -mapFstChar :: (Char -> Char) -> Token -> Token-mapFstChar f x-  | T.null x = x-  | otherwise = T.singleton (f $ T.head x) <> T.tail x+toLBS :: Text -> ByteString+toLBS = encodeUtf8 . LT.fromStrict -capitalTypeName :: FieldName -> TypeName-capitalTypeName = TypeName . capitalize . readName+fromLBS :: ByteString -> Text+fromLBS = LT.toStrict . decodeUtf8 ---(KEY v ~ k) =>-class Collection a coll | coll -> a where-  singleton :: a -> coll+prop :: (b -> b -> m b) -> (a -> b) -> a -> a -> m b+prop f fSel a1 a2 = f (fSel a1) (fSel a2) -instance Collection a [a] where-  singleton x = [x]+{-# DEPRECATED elems "use Foldable.toList" #-}+elems :: Foldable t => t a -> [a]+elems = toList -instance KeyOf k v => Collection v (HashMap k v) where-  singleton x = HM.singleton (keyOf x) x+singleton :: (IsMap k m, KeyOf k a) => a -> m a+singleton x = M.singleton (keyOf x) x  traverseCollection ::-  ( Monad f,+  ( Monad m,+    Failure GQLError m,     KeyOf k b,-    Elems a (t a),-    FromElems f b (t' b),-    Failure ValidationErrors f+    FromList m map k b,+    Foldable t   ) =>-  (a -> f b) ->+  (a -> m b) ->   t a ->-  f (t' b)-traverseCollection f a = fromElems =<< traverse f (elems a)---- list Like Collections-class FromElems m a coll | coll -> a where-  fromElems :: [a] -> m coll--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))+  m (map k b)+traverseCollection f a = fromElems =<< traverse f (toList a) -instance-  ( NameCollision a,-    Failure ValidationErrors m,+fromElems ::+  ( Monad m,     KeyOf k a,-    Monad m+    FromList m map k a   ) =>-  FromElems m a (HashMap k a)-  where-  fromElems xs = runResolutionT (fromListT (toPair <$> xs)) HM.fromList failOnDuplicates---- Merge Object with of Failure as an Option--mapFst :: (a -> a') -> (a, b) -> (a', b)-mapFst f (a, b) = (f a, b)--mapSnd :: (b -> b') -> (a, b) -> (a, b')-mapSnd f (a, b) = (a, f b)+  [a] ->+  m (map k a)+fromElems = fromList . map toPair -mapTuple :: (a -> a') -> (b -> b') -> (a, b) -> (a', b')-mapTuple f1 f2 (a, b) = (f1 a, f2 b)+insert ::+  ( NameCollision e a,+    KeyOf k a,+    Failure e m+  ) =>+  a ->+  SafeHashMap k a ->+  m (SafeHashMap k a)+insert x = merge (singleton x) -failOnDuplicates :: (Failure ValidationErrors m, NameCollision a) => NonEmpty a -> m a-failOnDuplicates (x :| xs)-  | null xs = pure x-  | otherwise = failure $ fmap nameCollision (x : xs)+mergeT :: (KeyOf k a, Foldable t, Monad m) => t a -> t a -> ResolutionT k a c m c+mergeT x y = fromListT (toPair <$> (toList x <> toList y))

@@ -10,13 +10,15 @@  import Data.ByteString.Lazy (ByteString) import Data.Morpheus.Ext.Result-  ( Eventless,+  ( GQLResult,     sortErrors,   )-import Data.Morpheus.Ext.SemigroupM ((<:>))+import Data.Morpheus.Internal.Utils ((<:>))+import Data.Morpheus.Parsing.Document.TypeSystem+  ( parseTypeDefinitions,+  ) import qualified Data.Morpheus.Parsing.Document.TypeSystem as P   ( parseSchema,-    parseTypeDefinitions,   ) import Data.Morpheus.Parsing.Request.Parser   ( parseRequest,@@ -26,11 +28,8 @@   ( GQLRequest (..),   ) import Data.Morpheus.Types.Internal.AST-  ( ANY,-    CONST,-    Operation,+  ( Operation,     Schema (..),-    TypeDefinition (..),     VALID,   ) import Data.Morpheus.Types.Internal.Config@@ -46,7 +45,7 @@ import Relude hiding (ByteString)  parseSchema ::-  ByteString -> Eventless (Schema VALID)+  ByteString -> GQLResult (Schema VALID) parseSchema =   sortErrors     . ( P.parseSchema@@ -58,11 +57,7 @@               }       ) -parseTypeDefinitions ::-  ByteString -> Eventless [TypeDefinition ANY CONST]-parseTypeDefinitions = P.parseTypeDefinitions--parseRequestWith :: Config -> Schema VALID -> GQLRequest -> Eventless (Operation VALID)+parseRequestWith :: Config -> Schema VALID -> GQLRequest -> GQLResult (Operation VALID) parseRequestWith config schema req = do   qu <- parseRequest req   fillSchema <- internalSchema <:> schema

@@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -14,11 +15,13 @@  import Data.ByteString.Lazy (ByteString) import Data.Foldable (foldr')-import Data.Morpheus.Error.NameCollision (NameCollision (..))+import Data.Mergeable (NameCollision (nameCollision), throwErrors) import Data.Morpheus.Ext.Result-  ( Eventless,-    failure,+  ( GQLResult,   )+import Data.Morpheus.Internal.Utils+  ( fromElems,+  ) import Data.Morpheus.Parsing.Internal.Internal   ( Parser,     processParser,@@ -57,6 +60,7 @@     Description,     DirectiveDefinition (..),     Directives,+    DirectivesDefinition,     FieldsDefinition,     OBJECT,     OUT,@@ -93,6 +97,7 @@     { typeContent = DataObject {objectImplements, objectFields},       ..     }+{-# INLINEABLE mkObject #-}  -- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars --@@ -109,6 +114,7 @@       <$> typeDeclaration "scalar"       <*> optionalDirectives       <*> pure (DataScalar (ScalarDefinition pure))+{-# INLINEABLE scalarTypeDefinition #-}  -- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects --@@ -136,14 +142,14 @@       <*> optionalImplementsInterfaces       <*> optionalDirectives       <*> fieldsDefinition---- build object+{-# INLINEABLE objectTypeDefinition #-}  optionalImplementsInterfaces :: Parser [TypeName] optionalImplementsInterfaces = implements <|> pure []   where     implements =       label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseTypeName+{-# INLINEABLE optionalImplementsInterfaces #-}  -- Interfaces: https://graphql.github.io/graphql-spec/June2018/#sec-Interfaces --@@ -160,6 +166,7 @@       <$> typeDeclaration "interface"       <*> optionalDirectives       <*> (DataInterface <$> fieldsDefinition)+{-# INLINEABLE interfaceTypeDefinition #-}  -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions --@@ -182,8 +189,10 @@       <*> (DataUnion <$> unionMemberTypes)   where     unionMemberTypes =-      equal+      lift . fromElems+        =<< equal         *> pipe (mkUnionMember <$> parseTypeName)+{-# INLINEABLE unionTypeDefinition #-}  -- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums --@@ -206,6 +215,7 @@       <$> typeDeclaration "enum"       <*> optionalDirectives       <*> (DataEnum <$> collection enumValueDefinition)+{-# INLINEABLE enumTypeDefinition #-}  -- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects --@@ -226,6 +236,7 @@       <$> typeDeclaration "input"       <*> optionalDirectives       <*> (DataInputObject <$> inputFieldsDefinition)+{-# INLINEABLE inputObjectTypeDefinition #-}  -- 3.13 DirectiveDefinition --@@ -249,6 +260,7 @@         <*> pure directiveDefinitionDescription         <*> optionalCollection argumentsDefinition         <*> (optional (keyword "repeatable") *> keyword "on" *> pipe parseDirectiveLocation)+{-# INLINEABLE parseDirectiveDefinition #-}  -- 3.2 Schema -- SchemaDefinition:@@ -271,12 +283,14 @@              <$> optionalDirectives              <*> setOf parseRootOperationTypeDefinition          )+{-# INLINEABLE parseSchemaDefinition #-}  parseRootOperationTypeDefinition :: Parser RootOperationTypeDefinition parseRootOperationTypeDefinition =   RootOperationTypeDefinition     <$> (parseOperationType <* colon)     <*> parseTypeName+{-# INLINEABLE parseRootOperationTypeDefinition #-}  parseTypeSystemUnit ::   Parser RawTypeDefinition@@ -298,6 +312,7 @@                 <|> enumTypeDefinition description                 <|> scalarTypeDefinition description             )+{-# INLINEABLE parseTypeSystemUnit #-}  typePartition ::   [RawTypeDefinition] ->@@ -328,11 +343,10 @@     [TypeDefinition ANY s],     [DirectiveDefinition CONST]   ) ->-  Eventless-    (Maybe SchemaDefinition, [TypeDefinition ANY s], [DirectiveDefinition CONST])-withSchemaDefinition ([], t, dirs) = pure (Nothing, t, dirs)-withSchemaDefinition ([x], t, dirs) = pure (Just x, t, dirs)-withSchemaDefinition (_ : xs, _, _) = failure (fmap nameCollision xs)+  GQLResult (Maybe SchemaDefinition, [TypeDefinition ANY s], DirectivesDefinition CONST)+withSchemaDefinition ([], t, dirs) = (Nothing,t,) <$> fromElems dirs+withSchemaDefinition ([x], t, dirs) = (Just x,t,) <$> fromElems dirs+withSchemaDefinition (x : xs, _, _) = throwErrors (nameCollision <$> (x :| xs))  parseRawTypeDefinitions :: Parser [RawTypeDefinition] parseRawTypeDefinitions =@@ -342,20 +356,19 @@  typeSystemDefinition ::   ByteString ->-  Eventless+  GQLResult     ( Maybe SchemaDefinition,       [TypeDefinition ANY CONST],-      [DirectiveDefinition CONST]+      DirectivesDefinition CONST     ) typeSystemDefinition =   processParser parseRawTypeDefinitions     >=> withSchemaDefinition . typePartition -parseTypeDefinitions :: ByteString -> Eventless [TypeDefinition ANY CONST]-parseTypeDefinitions = fmap snd3 . typeSystemDefinition--snd3 :: (a, b, c) -> b-snd3 (_, x, _) = x+parseTypeDefinitions :: ByteString -> GQLResult [TypeDefinition ANY CONST]+parseTypeDefinitions =+  fmap (\d -> [td | RawTypeDefinition td <- d])+    . processParser parseRawTypeDefinitions -parseSchema :: ByteString -> Eventless (Schema CONST)+parseSchema :: ByteString -> GQLResult (Schema CONST) parseSchema = typeSystemDefinition >=> buildSchema

@@ -9,7 +9,8 @@     getLocation,   ) import Data.Morpheus.Parsing.Internal.Terms-  ( fieldNameColon,+  ( colon,+    parseName,     uniqTupleOpt,   ) import Data.Morpheus.Parsing.Internal.Value@@ -35,10 +36,12 @@   label "Argument" $     Argument       <$> getLocation-      <*> fieldNameColon+      <*> (parseName <* colon)       <*> parse+{-# INLINEABLE valueArgument #-}  maybeArguments :: Parse (Value s) => Parser (Arguments s) maybeArguments =   label "Arguments" $     uniqTupleOpt valueArgument+{-# INLINEABLE maybeArguments #-}

@@ -10,27 +10,17 @@ where  import Data.ByteString.Lazy (ByteString)-import qualified Data.List.NonEmpty as NonEmpty import Data.Morpheus.Ext.Result-  ( Eventless,+  ( GQLResult,     Result (..),-    failure,   ) import Data.Morpheus.Types.Internal.AST-  ( GQLError (..),-    GQLErrors,+  ( GQLError,     Position (..),+    at,     msg,   )-import Relude-  ( ($),-    (.),-    Applicative (..),-    Either (..),-    Functor (..),-    Void,-    fst,-  )+import Relude hiding (ByteString) import Text.Megaparsec   ( ParseError,     ParseErrorBundle@@ -51,39 +41,31 @@  getLocation :: Parser Position getLocation = fmap toLocation getSourcePos+{-# INLINEABLE getLocation #-}  toLocation :: SourcePos -> Position toLocation SourcePos {sourceLine, sourceColumn} =   Position {line = unPos sourceLine, column = unPos sourceColumn}+{-# INLINEABLE toLocation #-}  type MyError = Void -type Parser = ParsecT MyError ByteString Eventless+type Parser = ParsecT MyError ByteString GQLResult  type ErrorBundle = ParseErrorBundle ByteString MyError -processParser :: Parser a -> ByteString -> Eventless a+processParser :: Parser a -> ByteString -> GQLResult a processParser parser txt = case runParserT parser [] txt of-  Success {result} -> case result of-    Right root -> pure root-    Left parseError -> failure (processErrorBundle parseError)-  Failure {errors} -> failure errors--processErrorBundle :: ErrorBundle -> GQLErrors-processErrorBundle = fmap parseErrorToGQLError . bundleToErrors+  Success {result} ->+    either+      (Failure . fmap parseErrorToGQLError . bundleToErrors)+      pure+      result+  Failure {errors} -> Failure errors  parseErrorToGQLError :: (ParseError ByteString MyError, SourcePos) -> GQLError-parseErrorToGQLError (err, position) =-  GQLError-    { message = msg (parseErrorPretty err),-      locations = [toLocation position]-    }+parseErrorToGQLError (err, position) = msg (parseErrorPretty err) `at` toLocation position -bundleToErrors ::-  ErrorBundle -> [(ParseError ByteString MyError, SourcePos)]+bundleToErrors :: ErrorBundle -> NonEmpty (ParseError ByteString MyError, SourcePos) bundleToErrors ParseErrorBundle {bundleErrors, bundlePosState} =-  NonEmpty.toList $ fst $-    attachSourcePos-      errorOffset-      bundleErrors-      bundlePosState+  fst $ attachSourcePos errorOffset bundleErrors bundlePosState

@@ -16,6 +16,8 @@   ) where +import Data.ByteString.Lazy.Internal (ByteString)+import Data.Morpheus.Internal.Utils (fromElems) import Data.Morpheus.Parsing.Internal.Arguments   ( maybeArguments,   )@@ -46,6 +48,7 @@     Description,     Directive (..),     DirectiveLocation (..),+    Directives,     FieldContent (..),     FieldDefinition (..),     FieldName,@@ -59,7 +62,7 @@     TypeRef,     Value,   )-import Relude hiding (many)+import Relude hiding (ByteString, many) import Text.Megaparsec   ( choice,     label,@@ -81,6 +84,7 @@       <$> optDescription       <*> parseTypeName       <*> optionalDirectives+{-# INLINEABLE enumValueDefinition #-}  -- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition --@@ -98,6 +102,7 @@       <*> (colon *> parseType)       <*> optional (DefaultInputValue <$> parseDefaultValue)       <*> optionalDirectives+{-# INLINEABLE inputValueDefinition #-}  -- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments --@@ -110,6 +115,7 @@ argumentsDefinition =   label "ArgumentsDefinition" $     uniqTuple (fmap ArgumentDefinition inputValueDefinition)+{-# INLINEABLE argumentsDefinition #-}  --  FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition --@@ -120,6 +126,7 @@   Parse (Value s) =>   Parser (FieldsDefinition OUT s) fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition+{-# INLINEABLE fieldsDefinition #-}  --  FieldDefinition --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)@@ -133,16 +140,18 @@       <*> optional (FieldArgs <$> argumentsDefinition)       <*> (colon *> parseType)       <*> optionalDirectives+{-# INLINEABLE fieldDefinition #-}  mkField ::   Maybe Description ->   FieldName ->   Maybe (FieldContent TRUE cat s) ->   TypeRef ->-  [Directive s] ->+  Directives s ->   FieldDefinition cat s mkField fieldDescription fieldName fieldContent fieldType fieldDirectives =   FieldDefinition {..}+{-# INLINEABLE mkField #-}  -- InputFieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives --   InputFieldsDefinition:@@ -152,6 +161,7 @@   Parse (Value s) =>   Parser (InputFieldsDefinition s) inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition+{-# INLINEABLE inputFieldsDefinition #-}  -- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives --@@ -160,8 +170,9 @@ -- Directives[Const] -- Directive[Const](list) ---optionalDirectives :: Parse (Value s) => Parser [Directive s]-optionalDirectives = label "Directives" $ many directive+optionalDirectives :: Parse (Value s) => Parser (Directives s)+optionalDirectives = label "Directives" $ many directive >>= lift . fromElems+{-# INLINEABLE optionalDirectives #-}  -- Directive[Const] --@@ -173,14 +184,16 @@       <$> getLocation       <*> (at *> parseName)       <*> maybeArguments+{-# INLINEABLE directive #-}  -- typDeclaration : Not in spec ,start part of type definitions -- --  typDeclaration --   Description(opt) scalar Name ---typeDeclaration :: FieldName -> Parser TypeName+typeDeclaration :: ByteString -> Parser TypeName typeDeclaration kind = keyword kind *> parseTypeName+{-# INLINEABLE typeDeclaration #-}  parseOperationType :: Parser OperationType parseOperationType =@@ -190,6 +203,7 @@         <|> (string "subscription" $> Subscription)     )       <* ignoredTokens+{-# INLINEABLE parseOperationType #-}  parseDirectiveLocation :: Parser DirectiveLocation parseDirectiveLocation =@@ -218,6 +232,8 @@               ]     )     <* ignoredTokens+{-# INLINEABLE parseDirectiveLocation #-}  toKeyword :: Show a => a -> Parser a toKeyword x = string (fromString $ show x) $> x+{-# INLINEABLE toKeyword #-}

@@ -0,0 +1,139 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-overflowed-literals #-}++module Data.Morpheus.Parsing.Internal.SourceText+  ( parseStringBS,+    ignoredTokens,+    ignoredTokens1,+  )+where++import Data.ByteString.Lazy.Internal+  ( ByteString,+  )+import Data.Morpheus.Parsing.Internal.Internal+  ( Parser,+  )+import Relude hiding (ByteString, empty, many)+import Text.Megaparsec+  ( choice,+    label,+    many,+    satisfy,+    takeWhile1P,+    takeWhileP,+    unexpected,+  )+import Text.Megaparsec.Byte+  ( char,+    space1,+    string,+  )+import Text.Megaparsec.Error+  ( ErrorItem (..),+  )++-- White Space+#define TABULATION 0x0009+#define NEW_LINE 0x000A+#define SPACE 0x0020+#define CARRIAGE_RETURN 0x000D+#define UNICODE_BOM 0xFEFF+#define NON_CHARACTER 0xFFFF++-- Non-alphabetic characters+#define DOUBLE_QUOTE 34+#define BACKSLASH 92+#define COMMA 44+#define HASH_TAG 35++-- Alphabetic characters+#define CHAR_b 98+#define CHAR_f 102+#define CHAR_n 110+#define CHAR_r 114+#define CHAR_t 116++-- https://spec.graphql.org/June2018/#sec-Source-Text+-- SourceCharacter : [\u0009\u000A\u000D\u0020-\uFFFF]/+isSourceCharacter :: Word8 -> Bool+isSourceCharacter TABULATION = True+isSourceCharacter NEW_LINE = True+isSourceCharacter CARRIAGE_RETURN = True+isSourceCharacter x = SPACE <= x && x <= NON_CHARACTER+{-# INLINE isSourceCharacter #-}++inlineString :: Parser ByteString+inlineString =+  label "String" $+    char DOUBLE_QUOTE+      *> parseContent+      <* ignoredTokens+{-# INLINE inlineString #-}++parseContent :: Parser ByteString+parseContent = do+  xs <- takeWhileP Nothing (\x -> isSourceCharacter x && DOUBLE_QUOTE /= x && x /= BACKSLASH && NEW_LINE /= x)+  z <- satisfy (const True)+  case z of+    DOUBLE_QUOTE -> pure xs+    BACKSLASH -> (xs <>) <$> ((<>) <$> escapeChar <*> parseContent)+    w -> unexpected (Tokens (w :| []))+  where+    escapeChar :: Parser ByteString+    escapeChar =+      choice+        [ char CHAR_b $> "\b",+          char CHAR_f $> "\f",+          char CHAR_n $> "\n",+          char CHAR_r $> "\r",+          char CHAR_t $> "\t",+          char BACKSLASH $> "\\",+          char DOUBLE_QUOTE $> "\"",+          char 47 $> "/"+        ]+    {-# INLINE escapeChar #-}+{-# INLINE parseContent #-}++blockString :: Parser ByteString+blockString = string "\"\"\"" *> content <* ignoredTokens+  where+    content :: Parser ByteString+    content = do+      text <- takeWhileP Nothing (\x -> isSourceCharacter x && x /= DOUBLE_QUOTE)+      doubleQuotes <- takeWhileP Nothing (== DOUBLE_QUOTE)+      case doubleQuotes of+        "\"\"\"" -> pure text+        _ -> ((text <> doubleQuotes) <>) <$> content+    {-# INLINE content #-}+{-# INLINE blockString #-}++parseStringBS :: Parser ByteString+parseStringBS = blockString <|> inlineString+{-# INLINE parseStringBS #-}++-- Ignored Tokens : https://graphql.github.io/graphql-spec/June2018/#sec-Source-Text.Ignored-Tokens+ignoredTokens :: Parser ()+ignoredTokens = label "IgnoredTokens" $ many ignored $> ()+{-# INLINE ignoredTokens #-}++-- isIgnored :: UnicodeBOM, WhiteSpace, LineTerminator, Comment , Comma+ignored :: Parser ()+ignored = (takeWhile1P Nothing isIgnored <|> comment) $> ()+  where+    isIgnored x =+      (x >= TABULATION && x <= CARRIAGE_RETURN)+        || x == SPACE+        || x == COMMA+        || x == UNICODE_BOM+    {-# INLINE isIgnored #-}+    comment = char HASH_TAG *> takeWhileP Nothing (\x -> isSourceCharacter x && x /= NEW_LINE)+    {-# INLINE comment #-}+{-# INLINE ignored #-}++ignoredTokens1 :: Parser ()+ignoredTokens1 = space1 *> ignoredTokens+{-# INLINE ignoredTokens1 #-}

@@ -1,7 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Parsing.Internal.Terms@@ -16,173 +15,171 @@     uniqTupleOpt,     parseTypeCondition,     spreadLiteral,-    parseNonNull,-    parseWrappedType,     parseAlias,     sepByAnd,     parseName,     parseType,     keyword,-    symbol,     optDescription,     optionalCollection,-    parseNegativeSign,     parseTypeName,     pipe,-    fieldNameColon,     brackets,     equal,-    comma,     colon,     at,+    symbol,   ) where -import Data.ByteString.Lazy-  ( pack,-  )-import Data.Morpheus.Ext.Result (Eventless)+import Data.ByteString.Lazy.Internal (ByteString)+import Data.Mergeable.IsMap (FromList)+import Data.Morpheus.Ext.Result (GQLResult) import Data.Morpheus.Internal.Utils   ( Empty (..),-    FromElems (..),     KeyOf,     fromElems,+    fromElems,     fromLBS,-    toLBS,   ) import Data.Morpheus.Parsing.Internal.Internal   ( Parser,     Position,     getLocation,   )+import Data.Morpheus.Parsing.Internal.SourceText+  ( ignoredTokens,+    ignoredTokens1,+    parseStringBS,+  )+import qualified Data.Morpheus.Types.Internal.AST as AST import Data.Morpheus.Types.Internal.AST-  ( DataTypeWrapper (..),-    Description,-    FieldName (..),+  ( Description,+    FieldName,     Ref (..),-    Token,-    TypeName (..),+    TypeName,     TypeRef (..),-    toHSWrappers,-  )-import Data.Text-  ( strip,+    TypeWrapper (..),+    packName,   )-import Relude hiding (empty, many)+import Data.Morpheus.Types.Internal.AST.Name (Name)+import Relude hiding (ByteString, empty, many) import Text.Megaparsec   ( (<?>),     between,-    choice,     label,-    many,-    manyTill,     sepBy,     sepBy1,     sepEndBy,-    skipManyTill,+    takeWhile1P,+    takeWhileP,     try,   ) import Text.Megaparsec.Byte   ( char,-    digitChar,-    letterChar,-    newline,-    printChar,-    space,-    space1,     string,   ) -parseNegativeSign :: Parser Bool-parseNegativeSign = (minus $> True <* ignoredTokens) <|> pure False--parseName :: Parser FieldName-parseName = FieldName <$> name+-- ':'+#define COLON 58+-- '@'+#define AT 64+-- '='+#define EQUAL 61+-- '|'+#define PIPE 124+-- '$'+#define DOLLAR 36+-- '&'+#define AMPERSAND 38+-- '_'+#define UNDERSCORE 95+-- '!'+#define BANG 33 -parseTypeName :: Parser TypeName-parseTypeName = label "TypeName" $ TypeName <$> name+#define CHAR_A 65 -keyword :: FieldName -> Parser ()-keyword (FieldName word) = string (toLBS word) *> space1 *> ignoredTokens+#define CHAR_Z 90 -symbol :: Word8 -> Parser ()-symbol x = char x *> ignoredTokens+#define CHAR_a 97 --- braces: {}-braces :: Parser a -> Parser a-braces = between (symbol 123) (symbol 125)+#define CHAR_z 122 --- brackets: []-brackets :: Parser a -> Parser a-brackets = between (symbol 91) (symbol 93)+#define DIGIT_0 48 --- parens : '()'-parens :: Parser a -> Parser a-parens = between (symbol 40) (symbol 41)+#define DIGIT_9 57 --- underscore : '_'-underscore :: Parser Word8-underscore = char 95+symbol :: Word8 -> Parser ()+symbol x = char x *> ignoredTokens+{-# INLINE symbol #-} -comma :: Parser ()-comma = label "," $ char 44 *> space+colon :: Parser ()+colon = symbol COLON+{-# INLINE colon #-} --- dollar :: $-dollar :: Parser ()-dollar = label "$" $ symbol 36+at :: Parser ()+at = symbol AT+{-# INLINE at #-} --- equal :: '=' equal :: Parser ()-equal = label "=" $ symbol 61---- colon :: ':'-colon :: Parser ()-colon = label ":" $ symbol 58---- minus: '-'-minus :: Parser ()-minus = label "-" $ symbol 45+equal = symbol EQUAL+{-# INLINE equal #-} --- verticalPipe: '|'-verticalPipe :: Parser ()-verticalPipe = label "|" $ symbol 124+pipe :: Parser a -> Parser [a]+pipe x = optional (symbol PIPE) *> (x `sepBy1` symbol PIPE)+{-# INLINE pipe #-} -ampersand :: Parser ()-ampersand = label "&" $ symbol 38+-- parens : '()'+parens :: Parser a -> Parser a+parens = between (symbol 40) (symbol 41)+{-# INLINE parens #-} --- at: '@'-at :: Parser ()-at = label "@" $ symbol 64+-- braces: {}+braces :: Parser a -> Parser a+braces = between (symbol 123) (symbol 125)+{-# INLINE braces #-} --- PRIMITIVE-------------------------------------+-- brackets: []+brackets :: Parser a -> Parser a+brackets = between (symbol 91) (symbol 93)+{-# INLINE brackets #-}  -- 2.1.9 Names -- https://spec.graphql.org/draft/#Name--- Name ::---  NameStart NameContinue[list,opt]----name :: Parser Token+-- Name+name :: Parser AST.Token name =   label "Name" $-    fromLBS . pack-      <$> ((:) <$> nameStart <*> nameContinue)+    fromLBS <$> do+      (<>) <$> takeWhile1P Nothing isStartChar <*> takeWhileP Nothing isContinueChar       <* ignoredTokens+  where+    isStartChar x =+      (x >= CHAR_a && x <= CHAR_z)+        || (x >= CHAR_A && x <= CHAR_Z)+        || x == UNDERSCORE+    {-# INLINE isStartChar #-}+    isContinueChar x =+      isStartChar x+        || (x >= DIGIT_0 && x <= DIGIT_9) -- digit+    {-# INLINE isContinueChar #-}+{-# INLINE name #-} --- NameStart::---   Letter---   _-nameStart :: Parser Word8-nameStart = letterChar <|> underscore+parseName :: Parser (Name t)+parseName = packName <$> name+{-# INLINE parseName #-} ---  NameContinue::---   Letter---   Digit-nameContinue :: Parser [Word8]-nameContinue = many (letterChar <|> underscore <|> digitChar)+parseTypeName :: Parser TypeName+parseTypeName = packName <$> name+{-# INLINE parseTypeName #-} +keyword :: ByteString -> Parser ()+keyword x = string x *> ignoredTokens1+{-# INLINE keyword #-}+ varName :: Parser FieldName-varName = dollar *> parseName <* ignoredTokens+varName = symbol DOLLAR *> parseName <* ignoredTokens+{-# INLINE varName #-}  -- Variable : https://graphql.github.io/graphql-spec/June2018/#Variable --@@ -194,124 +191,59 @@     flip Ref       <$> getLocation       <*> varName+{-# INLINE variable #-}  -- Descriptions: https://graphql.github.io/graphql-spec/June2018/#Description -- -- Description: --   StringValue-parseDescription :: Parser Description-parseDescription = strip <$> parseString- optDescription :: Parser (Maybe Description)-optDescription = optional parseDescription--parseString :: Parser Token-parseString = blockString <|> singleLineString--blockString :: Parser Token-blockString = stringWith (string "\"\"\"") (printChar <|> newline)--singleLineString :: Parser Token-singleLineString = stringWith (string "\"") escapedChar--stringWith :: Parser quote -> Parser Word8 -> Parser Token-stringWith quote parser =-  fromLBS . pack-    <$> ( quote-            *> manyTill parser quote-            <* ignoredTokens-        )--escapedChar :: Parser Word8-escapedChar = label "EscapedChar" $ printChar >>= handleEscape--handleEscape :: Word8 -> Parser Word8-handleEscape 92 = choice escape-handleEscape x = pure x--escape :: [Parser Word8]-escape = escapeCh <$> escapeOptions-  where-    escapeCh :: (Word8, Word8) -> Parser Word8-    escapeCh (code, replacement) = char code $> replacement--escapeOptions :: [(Word8, Word8)]-escapeOptions =-  [ (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---  Ignored:---    UnicodeBOM---    WhiteSpace---    LineTerminator---    Comment---    Comma-ignoredTokens :: Parser ()-ignoredTokens =-  label "IgnoredTokens" $-    space-      *> many ignored-      *> space--ignored :: Parser ()-ignored = label "Ignored" (comment <|> comma)--comment :: Parser ()-comment =-  label "Comment" $-    octothorpe *> skipManyTill printChar newline *> space---- exclamationMark: '!'-exclamationMark :: Parser ()-exclamationMark = label "!" $symbol 33+optDescription = optional parseString+{-# INLINE optDescription #-} --- octothorpe: '#'-octothorpe :: Parser ()-octothorpe = label "#" $ char 35 $> ()+parseString :: Parser AST.Token+parseString = label "String" $ fromLBS <$> parseStringBS+{-# INLINE parseString #-}  ------------------------------------------------------------------------- sepByAnd :: Parser a -> Parser [a]-sepByAnd entry = entry `sepBy` (optional ampersand *> ignoredTokens)--pipe :: Parser a -> Parser [a]-pipe x = optional verticalPipe *> (x `sepBy1` verticalPipe)+sepByAnd entry = entry `sepBy` (optional (symbol AMPERSAND) *> ignoredTokens)+{-# INLINE sepByAnd #-}  ----------------------------- collection :: Parser a -> Parser [a] collection entry = braces (entry `sepEndBy` ignoredTokens)+{-# INLINE collection #-} -setOf :: (FromElems Eventless a coll, KeyOf k a) => Parser a -> Parser coll+setOf :: (FromList GQLResult map k a, KeyOf k a) => Parser a -> Parser (map k a) setOf = collection >=> lift . fromElems+{-# INLINE setOf #-} -optionalCollection :: Empty c => Parser c -> Parser c+optionalCollection :: (Empty c) => Parser c -> Parser c optionalCollection x = x <|> pure empty+{-# INLINE optionalCollection #-} -parseNonNull :: Parser [DataTypeWrapper]-parseNonNull =-  (exclamationMark $> [NonNullType])-    <|> pure []+parseNonNull :: Parser Bool+parseNonNull = (symbol BANG $> True) <|> pure False+{-# INLINE parseNonNull #-} -uniqTuple :: (FromElems Eventless a coll, KeyOf k a) => Parser a -> Parser coll+uniqTuple :: (FromList GQLResult map k a, KeyOf k a) => Parser a -> Parser (map k a) uniqTuple parser =   label "Tuple" $     parens       (parser `sepBy` ignoredTokens <?> "empty Tuple value!")       >>= lift . fromElems+{-# INLINE uniqTuple #-} -uniqTupleOpt :: (FromElems Eventless a coll, Empty coll, KeyOf k a) => Parser a -> Parser coll+uniqTupleOpt ::+  ( FromList GQLResult map k a,+    Empty (map k a),+    KeyOf k a+  ) =>+  Parser a ->+  Parser (map k a) uniqTupleOpt x = uniqTuple x <|> pure empty--fieldNameColon :: Parser FieldName-fieldNameColon = parseName <* colon+{-# INLINE uniqTupleOpt #-}  -- Type Conditions: https://graphql.github.io/graphql-spec/June2018/#sec-Type-Conditions --@@ -320,9 +252,11 @@ -- parseTypeCondition :: Parser TypeName parseTypeCondition = keyword "on" *> parseTypeName+{-# INLINE parseTypeCondition #-}  spreadLiteral :: Parser Position-spreadLiteral = getLocation <* string "..." <* space+spreadLiteral = getLocation <* string "..." <* ignoredTokens+{-# INLINE spreadLiteral #-}  -- Field Alias : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Alias -- Alias@@ -330,26 +264,20 @@ parseAlias :: Parser (Maybe FieldName) parseAlias = try (optional alias) <|> pure Nothing   where-    alias = label "alias" fieldNameColon+    alias = label "alias" (parseName <* colon)+{-# INLINE parseAlias #-}  parseType :: Parser TypeRef-parseType = parseTypeW <$> parseWrappedType <*> parseNonNull--parseTypeW :: ([DataTypeWrapper], TypeName) -> [DataTypeWrapper] -> TypeRef-parseTypeW (wrappers, typeConName) nonNull =-  TypeRef-    { typeConName,-      typeWrappers = toHSWrappers (nonNull <> wrappers)-    }--parseWrappedType :: Parser ([DataTypeWrapper], TypeName)-parseWrappedType = (unwrapped <|> wrapped) <* ignoredTokens+parseType = uncurry TypeRef <$> (unwrapped <|> wrapped)   where-    unwrapped :: Parser ([DataTypeWrapper], TypeName)-    unwrapped = ([],) <$> parseTypeName <* ignoredTokens+    unwrapped :: Parser (TypeName, TypeWrapper)+    unwrapped = (,) <$> parseTypeName <*> (BaseType <$> parseNonNull)+    {-# INLINE unwrapped #-}     -----------------------------------------------    wrapped :: Parser ([DataTypeWrapper], TypeName)-    wrapped = brackets (wrapAsList <$> (unwrapped <|> wrapped) <*> parseNonNull)--wrapAsList :: ([DataTypeWrapper], TypeName) -> [DataTypeWrapper] -> ([DataTypeWrapper], TypeName)-wrapAsList (wrappers, tName) nonNull = (ListType : nonNull <> wrappers, tName)+    wrapped :: Parser (TypeName, TypeWrapper)+    wrapped = do+      (typename, wrapper) <- brackets (unwrapped <|> wrapped)+      isRequired <- parseNonNull+      pure (typename, TypeList wrapper isRequired)+    {-# INLINE wrapped #-}+{-# INLINE parseType #-}

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}@@ -15,13 +16,14 @@   ) import Data.Morpheus.Parsing.Internal.Terms   ( brackets,+    colon,     equal,-    fieldNameColon,     ignoredTokens,-    parseNegativeSign,+    parseName,     parseString,     parseTypeName,     setOf,+    symbol,     variable,   ) import Data.Morpheus.Types.Internal.AST@@ -44,44 +46,56 @@   ) import Text.Megaparsec.Byte.Lexer (scientific) +-- '-'+#define MINUS 45+ valueNull :: Parser (Value a) valueNull = string "null" $> Null+{-# INLINE valueNull #-}  booleanValue :: Parser (Value a)-booleanValue = boolTrue <|> boolFalse-  where-    boolTrue = string "true" $> Scalar (Boolean True)-    boolFalse = string "false" $> Scalar (Boolean False)+booleanValue =+  Scalar . Boolean+    <$> ( string "true" $> True+            <|> string "false" $> False+        )+{-# INLINE booleanValue #-}  valueNumber :: Parser (Value a)-valueNumber =-  Scalar . decodeScientific-    <$> (signedNumber <$> parseNegativeSign <*> scientific)+valueNumber = Scalar . decodeScientific <$> ((*) <$> negation <*> scientific)   where-    signedNumber isNegative number-      | isNegative = - number-      | otherwise = number+    negation = (symbol MINUS $> (-1) <* ignoredTokens) <|> pure 1+    {-# INLINE negation #-}+{-# INLINE valueNumber #-}  enumValue :: Parser (Value a) enumValue = Enum <$> parseTypeName <* ignoredTokens+{-# INLINE enumValue #-}  stringValue :: Parser (Value a)-stringValue = label "stringValue" $ Scalar . String <$> parseString+stringValue = Scalar . String <$> parseString+{-# INLINE stringValue #-}  listValue :: Parser a -> Parser [a]-listValue parser = label "list" $ brackets (parser `sepBy` ignoredTokens)+listValue parser = label "List" $ brackets (parser `sepBy` ignoredTokens)+{-# INLINE listValue #-}  objectEntry :: Parser (Value a) -> Parser (ObjectEntry a)-objectEntry parser =-  label "ObjectEntry" $-    ObjectEntry <$> fieldNameColon <*> parser+objectEntry parser = ObjectEntry <$> (parseName <* colon) <*> parser+{-# INLINE objectEntry #-}  objectValue :: Parser (Value a) -> Parser (OrdMap FieldName (ObjectEntry a)) objectValue = label "ObjectValue" . setOf . objectEntry+{-# INLINE objectValue #-}  parsePrimitives :: Parser (Value a) parsePrimitives =-  valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue+  valueNull+    <|> booleanValue+    <|> valueNumber+    <|> enumValue+    <|> stringValue+{-# INLINE parsePrimitives #-}  parseDefaultValue :: Parser (Value s) parseDefaultValue = equal *> parseV

@@ -14,11 +14,11 @@   ) import Data.HashMap.Lazy (toList) import Data.Morpheus.Ext.Result-  ( Eventless,+  ( GQLResult,   )-import Data.Morpheus.Ext.SafeHashMap (unsafeFromList) import Data.Morpheus.Internal.Utils-  ( empty,+  ( IsMap (unsafeFromList),+    empty,     fromElems,     toLBS,   )@@ -38,8 +38,8 @@ import Data.Morpheus.Types.IO (GQLRequest (..)) import Data.Morpheus.Types.Internal.AST   ( ExecutableDocument (..),-    FieldName (..),     Variables,+    packName,     replaceValue,   ) import Relude hiding@@ -64,7 +64,7 @@       <* ignoredTokens       <* eof -parseRequest :: GQLRequest -> Eventless ExecutableDocument+parseRequest :: GQLRequest -> GQLResult ExecutableDocument parseRequest GQLRequest {query, variables} =   processParser     (parseExecutableDocument $ toVariables variables)@@ -73,5 +73,5 @@     toVariables :: Maybe Aeson.Value -> Variables     toVariables (Just (Aeson.Object x)) = unsafeFromList $ toMorpheusValue <$> toList x       where-        toMorpheusValue (key, value) = (FieldName key, replaceValue value)+        toMorpheusValue (key, value) = (packName key, replaceValue value)     toVariables _ = empty

@@ -31,8 +31,7 @@     spreadLiteral,   ) import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    Fragment (..),+  ( Fragment (..),     Position,     RAW,     Ref (..),@@ -40,6 +39,7 @@     SelectionContent (..),     SelectionSet,   )+import Data.Morpheus.Types.Internal.AST.Name import Relude import Text.Megaparsec   ( label,@@ -125,7 +125,7 @@   fragmentPosition <- spreadLiteral   InlineFragment <$> fragmentBody "INLINE_FRAGMENT" fragmentPosition -fragmentBody :: FieldName -> Position -> Parser (Fragment RAW)+fragmentBody :: FragmentName -> Position -> Parser (Fragment RAW) fragmentBody fragmentName fragmentPosition = label "FragmentBody" $ do   fragmentType <- parseTypeCondition   fragmentDirectives <- optionalDirectives

@@ -38,19 +38,20 @@ import Language.Haskell.TH.Quote import Relude hiding (ByteString) +notSupported :: Text -> a+notSupported things =+  error $+    things+      <> " are not supported by the GraphQL QuasiQuoter"+ gql :: QuasiQuoter gql =   QuasiQuoter     { quoteExp = gqlExpression . pack,-      quotePat = notHandled "Patterns",-      quoteType = notHandled "Types",-      quoteDec = notHandled "Declarations"+      quotePat = notSupported "Patterns",+      quoteType = notSupported "Types",+      quoteDec = notSupported "Declarations"     }-  where-    notHandled things =-      error $-        things-          <> " are not supported by the GraphQL QuasiQuoter"  gqlExpression :: ByteString -> Q Exp gqlExpression queryText = case parseRequest request of@@ -70,14 +71,10 @@ dsl =   QuasiQuoter     { quoteExp = dslExpression . pack,-      quotePat = notHandled "Patterns",-      quoteType = notHandled "Types",-      quoteDec = notHandled "Declarations"+      quotePat = notSupported "Patterns",+      quoteType = notSupported "Types",+      quoteDec = notSupported "Declarations"     }-  where-    notHandled things =-      error $-        things <> " are not supported by the GraphQL QuasiQuoter"  dslExpression :: ByteString -> Q Exp dslExpression doc = case parseSchema doc of

@@ -58,6 +58,10 @@   where   renderGQL = maybe "" renderGQL +instance (RenderGQL l, RenderGQL r) => RenderGQL (Either l r) where+  renderGQL (Left x) = renderGQL x+  renderGQL (Right x) = renderGQL x+ instance RenderGQL ByteString where   renderGQL = Rendering . const @@ -105,8 +109,8 @@ renderObject :: (RenderGQL a) => [a] -> Rendering renderObject fields = space <> "{" <> renderAtNewLine fields <> newline <> "}" -renderMembers :: (RenderGQL a) => [a] -> Rendering-renderMembers members = intercalate (space <> "|" <> space) (fmap renderGQL members)+renderMembers :: (RenderGQL a, Foldable t) => t a -> Rendering+renderMembers members = intercalate (space <> "|" <> space) (fmap renderGQL (toList members))  renderArguments :: (RenderGQL a) => [a] -> Rendering renderArguments arguments

@@ -40,11 +40,11 @@       pure value  -- | GraphQL Scalar Serializer-class EncodeScalar (a :: *) where+class EncodeScalar (a :: Type) where   encodeScalar :: a -> ScalarValue  -- | GraphQL Scalar parser-class DecodeScalar (a :: *) where+class DecodeScalar (a :: Type) where   -- value parsing and validating   --   -- for exhaustive pattern matching  should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean'

@@ -34,7 +34,8 @@       Generic,       Eq,       Hashable,-      IsString+      IsString,+      Semigroup     )  instance DecodeScalar ID where

@@ -30,6 +30,7 @@ import Data.Morpheus.Types.Internal.AST   ( FieldName,     GQLError (..),+    GQLError,     ValidValue,   ) import Relude hiding@@ -37,8 +38,8 @@     encodeUtf8,   ) -renderResponse :: Result e ValidValue -> GQLResponse-renderResponse (Failure errors) = Errors (sortOn locations errors)+renderResponse :: Result GQLError ValidValue -> GQLResponse+renderResponse (Failure errors) = Errors $ sort $ toList errors renderResponse Success {result} = Data result  -- | GraphQL HTTP Request Body

@@ -9,8 +9,7 @@   ( Ref (..),     Position (..),     Message,-    anonymousRef,-    FieldName (..),+    FieldName,     Description,     Stage,     CONST,@@ -21,8 +20,6 @@     Object,     replaceValue,     decodeScientific,-    convertToJSONName,-    convertToHaskellName,     RawValue,     ValidValue,     RawObject,@@ -45,14 +42,13 @@     DataEnum,     FieldsDefinition,     ArgumentDefinition (..),-    DataUnion,+    UnionTypeDefinition,     ArgumentsDefinition,     FieldDefinition (..),     InputFieldsDefinition,     TypeContent (..),     TypeDefinition (..),     Schema (..),-    DataTypeWrapper (..),     TypeKind (..),     TypeWrapper (..),     TypeRef (..),@@ -62,18 +58,14 @@     MUTATION,     SUBSCRIPTION,     Directive (..),-    ConsD (..),     TypeCategory (..),-    DataInputUnion,     VariableContent (..),-    TypeLib,+    TypeDefinitions,     initTypeLib,     kindOf,     toNullable,-    toHSWrappers,     isNullable,-    toGQLWrapper,-    isWeaker,+    Subtyping (..),     isNotSystemTypeName,     isLeaf,     isResolverType,@@ -86,7 +78,6 @@     lookupDeprecated,     lookupDeprecatedReason,     lookupWith,-    hsTypeName,     ExecutableDocument (..),     Variables,     unsafeFromFields,@@ -104,20 +95,17 @@     toAny,     TRUE,     FALSE,-    TypeName (..),+    TypeName,     Token,     Msg (..),-    intercalateName,-    toFieldName,+    intercalate,     fieldsToArguments,-    mkConsEnum,     Directives,-    DirectiveDefinitions,+    DirectivesDefinition,     DirectiveDefinition (..),     DirectiveLocation (..),     FieldContent (..),-    fieldContentArgs,-    mkInputValue,+    fieldArguments,     mkType,     mkObjectField,     UnionMember (..),@@ -128,17 +116,10 @@     UnionSelection,     SchemaDefinition (..),     buildSchema,-    InternalError (..),-    ValidationError (..),-    msgInternal,     getOperationDataType,     Typed (Typed),     typed,     untyped,-    msgValidation,-    withPosition,-    ValidationErrors,-    toGQLError,     LEAF,     INPUT_OBJECT,     ToCategory (..),@@ -153,17 +134,34 @@     getInputUnionValue,     unitFieldName,     unitTypeName,+    mkBaseType,+    mkMaybeType,+    isPossibleInterfaceType,+    packName,+    unpackName,+    at,+    atPositions,+    typeDefinitions,+    FragmentName,+    isInternal,+    internal,+    splitSystemSelection,+    lookupDataType,+    Name,+    withPath,   ) where -import Data.Morpheus.Ext.OrdMap (OrdMap (..))-import Data.Morpheus.Ext.SafeHashMap (SafeHashMap)+import Data.Mergeable.OrdMap (OrdMap (..))+import Data.Mergeable.SafeHashMap (SafeHashMap) import Data.Morpheus.Types.Internal.AST.Base import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..))+import Data.Morpheus.Types.Internal.AST.Error import Data.Morpheus.Types.Internal.AST.Fields+import Data.Morpheus.Types.Internal.AST.Name+import Data.Morpheus.Types.Internal.AST.OperationType import Data.Morpheus.Types.Internal.AST.Selection import Data.Morpheus.Types.Internal.AST.Stage-import Data.Morpheus.Types.Internal.AST.TH import Data.Morpheus.Types.Internal.AST.Type import Data.Morpheus.Types.Internal.AST.TypeCategory import Data.Morpheus.Types.Internal.AST.TypeSystem

@@ -5,76 +5,25 @@ {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST.Base   ( Ref (..),     Position (..),-    Message (..),-    FieldName (..),     Description,-    OperationType (..),-    QUERY,-    MUTATION,-    SUBSCRIPTION,     Token,-    isNotSystemTypeName,-    sysFields,-    hsTypeName,-    toOperationType,-    GQLError (..),-    GQLErrors,     TRUE,     FALSE,-    TypeName (..),-    Msg (..),-    intercalateName,-    toFieldName,-    convertToJSONName,-    convertToHaskellName,-    InternalError (..),-    msgInternal,-    ValidationError (..),-    msgValidation,-    ValidationErrors,-    withPosition,-    toGQLError,-    unitTypeName,-    unitFieldName,-    anonymousRef,   ) where  import Data.Aeson   ( FromJSON,-    ToJSON,-    Value,-    encode,-  )-import Data.ByteString.Lazy (ByteString)-import Data.Char (toLower)-import Data.Morpheus.Rendering.RenderGQL-  ( RenderGQL (..),-    fromText,-    renderGQL,-  )-import Data.Text (intercalate, pack)-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import Data.Text.Lazy.Encoding (decodeUtf8)-import Language.Haskell.TH-  ( ExpQ,-    stringE,+    ToJSON (..),   ) import Language.Haskell.TH.Syntax   ( Lift (..),-    Q,-    TExp,-    unsafeTExpCoerce,   ) import Relude hiding   ( ByteString,@@ -89,145 +38,6 @@ -- Strings type Token = Text --- Error / Warning Messages-newtype Message = Message {readMessage :: Text}-  deriving-    (Generic)-  deriving newtype-    (Show, Eq, Ord, IsString, Semigroup, Hashable, FromJSON, ToJSON)--instance Lift Message where-  lift = liftString . readMessage--#if MIN_VERSION_template_haskell(2,16,0)-  liftTyped = liftTypedString . readMessage-#endif--newtype InternalError = InternalError-  { readInternalError :: Text-  }-  deriving-    (Generic)-  deriving newtype-    (Show, Eq, Ord, IsString, Semigroup, Hashable, FromJSON, ToJSON)--data ValidationError = ValidationError-  { validationMessage :: Message,-    validationLocations :: [Position]-  }-  deriving (Show)--instance IsString ValidationError where-  fromString = (`ValidationError` []) . msg--instance Semigroup ValidationError where-  ValidationError m1 p1 <> ValidationError m2 p2 =-    ValidationError (m1 <> m2) (p1 <> p2)--withPosition :: Maybe Position -> ValidationError -> ValidationError-withPosition pos (ValidationError m ps) = ValidationError m (ps <> maybeToList pos)--type ValidationErrors = [ValidationError]--toGQLError :: ValidationError -> GQLError-toGQLError (ValidationError m p) = GQLError m p---- instance Lift InternalError where---   lift = liftString . readInternalError---- #if MIN_VERSION_template_haskell(2,16,0)---   liftTyped = liftTypedString . readInternalError--- #endif--msgInternal :: (Msg a) => a -> InternalError-msgInternal = InternalError . readMessage . msg--msgValidation :: (Msg a) => a -> ValidationError-msgValidation = (`ValidationError` []) . msg--class Msg a where-  msg :: a -> Message-  msgSepBy :: Text -> [a] -> Message-  msgSepBy t = Message . intercalate t . fmap (readMessage . msg)--instance Msg Message where-  msg = id--instance Msg InternalError where-  msg = Message . ("Internal Error! " <>) . readInternalError--instance Msg String where-  msg = Message . pack--instance Msg ByteString where-  msg = Message . LT.toStrict . decodeUtf8--instance Msg Text where-  msg = Message--instance Msg Value where-  msg = msg . encode---- FieldName : lower case names-newtype FieldName = FieldName {readName :: Text}-  deriving-    (Generic)-  deriving newtype-    (Show, Ord, Eq, IsString, Hashable, Semigroup, FromJSON, ToJSON)--instance Lift FieldName where-  lift = liftString . readName--#if MIN_VERSION_template_haskell(2,16,0)-  liftTyped = liftTypedString . readName-#endif--instance Msg FieldName where-  msg FieldName {readName} = Message $ "\"" <> readName <> "\""--instance RenderGQL FieldName where-  renderGQL = fromText . readName--intercalateName :: FieldName -> [FieldName] -> FieldName-intercalateName (FieldName x) = FieldName . intercalate x . fmap readName--toFieldName :: TypeName -> FieldName-toFieldName = FieldName . readTypeName---- TypeName-newtype TypeName = TypeName {readTypeName :: Text}-  deriving-    (Generic)-  deriving newtype-    ( Show,-      Ord,-      Eq,-      IsString,-      Hashable,-      Semigroup,-      FromJSON,-      ToJSON-    )--instance Lift TypeName where-  lift = liftString . readTypeName--#if MIN_VERSION_template_haskell(2,16,0)-  liftTyped = liftTypedString . readTypeName-#endif--liftTypedString :: IsString a => Token -> Q (TExp a)-liftTypedString = unsafeTExpCoerce . stringE . T.unpack--liftString :: Token -> ExpQ-liftString = stringE . T.unpack--instance Msg TypeName where-  msg TypeName {readTypeName} = Message $ "\"" <> readTypeName <> "\""--instance RenderGQL TypeName where-  renderGQL = fromText . readTypeName- -- Description type Description = Text @@ -235,48 +45,27 @@   { line :: Int,     column :: Int   }-  deriving (Show, Generic, FromJSON, ToJSON, Lift)--instance Ord Position where-  compare x y = compare (line x) (line y)+  deriving+    ( Show,+      Generic,+      FromJSON,+      ToJSON,+      Lift+    )  -- Positions 2 Value with same structure -- but different Positions should be Equal instance Eq Position where   _ == _ = True -data GQLError = GQLError-  { message :: Message,-    locations :: [Position]-  }-  deriving (Show, Eq, Generic, FromJSON, ToJSON)--type GQLErrors = [GQLError]--data OperationType-  = Query-  | Subscription-  | Mutation-  deriving (Show, Eq, Lift, Generic, Hashable)--instance RenderGQL OperationType where-  renderGQL = fromString . fmap toLower . show--instance Msg OperationType where-  msg Query = msg ("query" :: TypeName)-  msg Mutation = msg ("mutation" :: TypeName)-  msg Subscription = msg ("subscription" :: TypeName)--type QUERY = 'Query--type MUTATION = 'Mutation--type SUBSCRIPTION = 'Subscription+instance Ord Position where+  compare (Position l1 c1) (Position l2 c2) = compare l1 l2 <> compare c1 c2 --- Document Reference with its Position--- Position  only for error messages--- includes position for debugging, where Ref "a" 1 === Ref "a" 3+-- | Document Reference with its Position --+-- Position is used only for error messages. that means:+--+-- Ref "a" 1 === Ref "a" 3 data Ref name = Ref   { refName :: name,     refPosition :: Position@@ -285,85 +74,3 @@  instance Ord name => Ord (Ref name) where   compare (Ref x _) (Ref y _) = compare x y--anonymousRef :: name -> Ref name-anonymousRef refName = Ref {refName, refPosition = Position 0 0}--isNotSystemTypeName :: TypeName -> Bool-isNotSystemTypeName =-  ( `notElem`-      [ "__Schema",-        "__Type",-        "__Directive",-        "__TypeKind",-        "__Field",-        "__DirectiveLocation",-        "__InputValue",-        "__EnumValue",-        "String",-        "Float",-        "Int",-        "Boolean",-        "ID"-      ]-  )--sysFields :: [FieldName]-sysFields = ["__typename", "__schema", "__type"]--hsTypeName :: TypeName -> TypeName-hsTypeName "String" = "Text"-hsTypeName "Boolean" = "Bool"-hsTypeName name = name--toOperationType :: TypeName -> Maybe OperationType-toOperationType "Subscription" = Just Subscription-toOperationType "Mutation" = Just Mutation-toOperationType "Query" = Just Query-toOperationType _ = Nothing---- handle reserved Names-isReserved :: FieldName -> Bool-isReserved "case" = True-isReserved "class" = True-isReserved "data" = True-isReserved "default" = True-isReserved "deriving" = True-isReserved "do" = True-isReserved "else" = True-isReserved "foreign" = True-isReserved "if" = True-isReserved "import" = True-isReserved "in" = True-isReserved "infix" = True-isReserved "infixl" = True-isReserved "infixr" = True-isReserved "instance" = True-isReserved "let" = True-isReserved "module" = True-isReserved "newtype" = True-isReserved "of" = True-isReserved "then" = True-isReserved "type" = True-isReserved "where" = True-isReserved "_" = True-isReserved _ = False-{-# INLINE isReserved #-}--convertToJSONName :: FieldName -> FieldName-convertToJSONName (FieldName hsName)-  | not (T.null hsName) && isReserved (FieldName name) && (T.last hsName == '\'') = FieldName name-  | otherwise = FieldName hsName-  where-    name = T.init hsName--convertToHaskellName :: FieldName -> FieldName-convertToHaskellName name-  | isReserved name = name <> "'"-  | otherwise = name--unitTypeName :: TypeName-unitTypeName = "Unit"--unitFieldName :: FieldName-unitFieldName = "_"

@@ -6,7 +6,7 @@   ) where -import Data.Morpheus.Types.Internal.AST.Base (Msg (..))+import Data.Morpheus.Types.Internal.AST.Error (Msg (..)) import Language.Haskell.TH.Syntax (Lift) import Relude hiding (Show, show) import Prelude (Show (..))

@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.Internal.AST.Error+  ( at,+    atPositions,+    internal,+    isInternal,+    GQLErrors,+    GQLError+      ( message,+        locations+      ),+    manyMsg,+    Msg (..),+    Message,+    withPath,+  )+where++import Data.Aeson+  ( FromJSON,+    Options (..),+    ToJSON (..),+    Value,+    defaultOptions,+    encode,+    genericToJSON,+  )+import Data.ByteString.Lazy (ByteString)+import Data.Morpheus.Types.Internal.AST.Base+  ( Position (..),+  )+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Encoding (decodeUtf8)+import Relude hiding (ByteString, decodeUtf8)++type Message = Text++internal :: GQLError -> GQLError+internal x = x {errorType = Just Internal}++isInternal :: GQLError -> Bool+isInternal GQLError {errorType = Just Internal} = True+isInternal _ = False++at :: GQLError -> Position -> GQLError+at err pos = atPositions err [pos]+{-# INLINE at #-}++atPositions :: Foldable t => GQLError -> t Position -> GQLError+atPositions GQLError {..} pos = case toList pos of+  [] -> GQLError {..}+  posList -> GQLError {locations = locations <> Just posList, ..}+{-# INLINE atPositions #-}++withPath :: GQLError -> [Text] -> GQLError+withPath err [] = err+withPath err path = err {path = Just path}++manyMsg :: (Foldable t, Msg a) => t a -> GQLError+manyMsg =+  msg . T.intercalate ", "+    . fmap (message . msg)+    . toList++data ErrorType = Internal+  deriving+    ( Show,+      Eq,+      Generic,+      FromJSON,+      ToJSON+    )++instance Semigroup ErrorType where+  Internal <> Internal = Internal++data GQLError = GQLError+  { message :: Message,+    locations :: Maybe [Position],+    path :: Maybe [Text],+    errorType :: Maybe ErrorType,+    extensions :: Maybe (Map Text Value)+  }+  deriving+    ( Show,+      Eq,+      Generic,+      FromJSON+    )++instance Ord GQLError where+  compare x y = compare (locations x) (locations y) <> compare (message x) (message y)++instance IsString GQLError where+  fromString = msg++instance ToJSON GQLError where+  toJSON = genericToJSON (defaultOptions {omitNothingFields = True})++instance Semigroup GQLError where+  GQLError m1 l1 p1 t1 e1 <> GQLError m2 l2 p2 t2 e2 = GQLError (m1 <> m2) (l1 <> l2) (p1 <> p2) (t1 <> t2) (e1 <> e2)++type GQLErrors = NonEmpty GQLError++class Msg a where+  msg :: a -> GQLError++instance Msg GQLError where+  msg = id++instance Msg String where+  msg = msg . T.pack++instance Msg Text where+  msg message =+    GQLError+      { message,+        locations = Nothing,+        errorType = Nothing,+        extensions = Nothing,+        path = Nothing+      }++instance Msg ByteString where+  msg = msg . LT.toStrict . decodeUtf8++instance Msg Value where+  msg = msg . encode

@@ -23,7 +23,7 @@     FieldsDefinition,     FieldContent (..),     InputFieldsDefinition,-    DirectiveDefinitions,+    DirectivesDefinition,     DirectiveDefinition (..),     Directives,     Directive (..),@@ -32,8 +32,7 @@     lookupDeprecatedReason,     unsafeFromFields,     fieldsToArguments,-    fieldContentArgs,-    mkInputValue,+    fieldArguments,     mkObjectField,     mkField,     renderArgumentValues,@@ -41,19 +40,17 @@   ) where -import Data.Morpheus.Error.NameCollision-  ( NameCollision (..),-  )-import Data.Morpheus.Ext.OrdMap-  ( OrdMap,-    unsafeFromList,+import Data.Mergeable+  ( IsMap (lookup),+    NameCollision (..),+    OrdMap,   ) import Data.Morpheus.Internal.Utils-  ( Elems (..),-    Empty (..),+  ( Empty (..),     KeyOf (..),-    Selectable (..),+    selectOr,     toPair,+    unsafeFromList,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),@@ -66,17 +63,20 @@   ) import Data.Morpheus.Types.Internal.AST.Base   ( Description,-    FieldName,-    FieldName (..),-    Msg (..),     Position,     TRUE,-    TypeName,-    ValidationError (..),-    msgValidation,-    sysFields,   ) import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation)+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,+    at,+    msg,+  )+import Data.Morpheus.Types.Internal.AST.Name+  ( FieldName,+    TypeName,+    isNotSystemFieldName,+  ) import Data.Morpheus.Types.Internal.AST.Stage   ( Stage,   )@@ -118,17 +118,15 @@   renderGQL Argument {argumentName, argumentValue} =     renderEntry argumentName argumentValue -instance NameCollision (Argument s) where+instance NameCollision GQLError (Argument s) where   nameCollision Argument {argumentName, argumentPosition} =-    ValidationError-      { validationMessage = "There can Be only One Argument Named " <> msg argumentName,-        validationLocations = [argumentPosition]-      }+    ("There can Be only One Argument Named " <> msg argumentName)+      `at` argumentPosition  type Arguments (s :: Stage) = OrdMap FieldName (Argument s)  renderArgumentValues :: Arguments s -> Rendering-renderArgumentValues = renderArguments . filter notNull . elems+renderArgumentValues = renderArguments . filter notNull . toList   where     notNull Argument {argumentValue = Null} = False     notNull _ = True@@ -142,6 +140,12 @@   }   deriving (Show, Lift, Eq) +instance NameCollision GQLError (Directive s) where+  nameCollision Directive {directiveName} =+    "The directive "+      <> msg ("@" <> directiveName)+      <> " can only be used once at his location."+ instance KeyOf FieldName (Directive s) where   keyOf = directiveName @@ -150,14 +154,14 @@     "@" <> renderGQL directiveName       <> renderArgumentValues directiveArgs -type Directives s = [Directive s]+type Directives s = OrdMap FieldName (Directive s)  renderDirectives :: Directives s -> Rendering renderDirectives xs   | null dirs = ""   | otherwise = space <> intercalate space (fmap renderGQL dirs)   where-    dirs = filter notSystem xs+    dirs = filter notSystem (toList xs)     notSystem Directive {directiveName = "include"} = False     notSystem Directive {directiveName = "skip"} = False     notSystem _ = True@@ -170,20 +174,22 @@   }   deriving (Show, Lift) -type DirectiveDefinitions s = [DirectiveDefinition s]+instance NameCollision GQLError (DirectiveDefinition s) where+  nameCollision DirectiveDefinition {directiveDefinitionName} =+    "There can Be only One DirectiveDefinition Named "+      <> msg directiveDefinitionName+      <> "." +type DirectivesDefinition s = OrdMap FieldName (DirectiveDefinition s)+ instance KeyOf FieldName (DirectiveDefinition s) where   keyOf = directiveDefinitionName -instance Selectable FieldName (ArgumentDefinition s) (DirectiveDefinition s) where-  selectOr fb f key DirectiveDefinition {directiveDefinitionArgs} =-    selectOr fb f key directiveDefinitionArgs+-- instance IsMap FieldName (ArgumentDefinition s) (DirectiveDefinition s) where+--   lookup key DirectiveDefinition {directiveDefinitionArgs} = lookup key directiveDefinitionArgs -lookupDeprecated :: [Directive s] -> Maybe (Directive s)-lookupDeprecated = find isDeprecation-  where-    isDeprecation Directive {directiveName = "deprecated"} = True-    isDeprecation _ = False+lookupDeprecated :: Directives s -> Maybe (Directive s)+lookupDeprecated = lookup "deprecated"  lookupDeprecatedReason :: Directive s -> Maybe Description lookupDeprecatedReason Directive {directiveArgs} =@@ -236,7 +242,7 @@     fieldName :: FieldName,     fieldType :: TypeRef,     fieldContent :: Maybe (FieldContent TRUE cat s),-    fieldDirectives :: [Directive s]+    fieldDirectives :: Directives s   }   deriving (Show, Lift, Eq) @@ -250,9 +256,9 @@     } ->     FieldContent (OUT <=? cat) cat s -fieldContentArgs :: FieldContent b cat s -> ArgumentsDefinition s-fieldContentArgs (FieldArgs args) = args-fieldContentArgs _ = empty+fieldArguments :: FieldDefinition c s -> ArgumentsDefinition s+fieldArguments FieldDefinition {fieldContent = Just (FieldArgs args)} = args+fieldArguments _ = empty  deriving instance Eq (FieldContent bool cat s) @@ -263,13 +269,9 @@ instance KeyOf FieldName (FieldDefinition cat s) where   keyOf = fieldName -instance Selectable FieldName (ArgumentDefinition s) (FieldDefinition OUT s) where-  selectOr fb f key FieldDefinition {fieldContent = Just (FieldArgs args)} = selectOr fb f key args-  selectOr fb _ _ _ = fb--instance NameCollision (FieldDefinition cat s) where+instance NameCollision GQLError (FieldDefinition cat s) where   nameCollision FieldDefinition {fieldName} =-    "There can Be only One field Named " <> msgValidation fieldName+    "There can Be only One field Named " <> msg fieldName  instance RenderGQL (FieldDefinition cat s) where   renderGQL FieldDefinition {fieldName, fieldType, fieldContent = Just (FieldArgs args)} =@@ -278,14 +280,14 @@     renderEntry fieldName fieldType  instance RenderGQL (FieldsDefinition cat s) where-  renderGQL = renderObject . filter fieldVisibility . elems+  renderGQL = renderObject . filter fieldVisibility . toList  instance Nullable (FieldDefinition cat s) where   isNullable = isNullable . fieldType   toNullable field = field {fieldType = toNullable (fieldType field)}  fieldVisibility :: FieldDefinition cat s -> Bool-fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields+fieldVisibility = isNotSystemFieldName . fieldName  mkField ::   Maybe (FieldContent TRUE cat s) ->@@ -298,20 +300,13 @@       fieldContent,       fieldDescription = Nothing,       fieldType,-      fieldDirectives = []+      fieldDirectives = empty     } -mkInputValue :: FieldName -> [TypeWrapper] -> TypeName -> FieldDefinition cat s-mkInputValue fieldName typeWrappers typeConName =-  mkField-    Nothing-    fieldName-    TypeRef {typeWrappers, typeConName}- mkObjectField ::   ArgumentsDefinition s ->   FieldName ->-  [TypeWrapper] ->+  TypeWrapper ->   TypeName ->   FieldDefinition OUT s mkObjectField args fieldName typeWrappers typeConName =@@ -337,7 +332,7 @@ type ArgumentsDefinition s = OrdMap FieldName (ArgumentDefinition s)  instance RenderGQL (ArgumentsDefinition s) where-  renderGQL = renderArguments . elems+  renderGQL = renderArguments . toList  instance RenderGQL (ArgumentDefinition s) where   renderGQL = renderGQL . argument@@ -350,6 +345,6 @@ instance KeyOf FieldName (ArgumentDefinition s) where   keyOf = keyOf . argument -instance NameCollision (ArgumentDefinition s) where+instance NameCollision GQLError (ArgumentDefinition s) where   nameCollision ArgumentDefinition {argument} =-    "There can Be only One argument Named " <> msgValidation (fieldName argument)+    "There can Be only One argument Named " <> msg (fieldName argument)

@@ -0,0 +1,160 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.Internal.AST.Name+  ( Name,+    packName,+    unpackName,+    FieldName,+    TypeName,+    unitTypeName,+    unitFieldName,+    isNotSystemTypeName,+    isNotSystemFieldName,+    intercalate,+    NAME (..),+    FragmentName,+  )+where++import Data.Aeson+  ( FromJSON,+    ToJSON (..),+  )+import Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+    fromText,+    renderGQL,+  )+import Data.Morpheus.Types.Internal.AST.Error+  ( Msg (..),+  )+import qualified Data.Text as T+#if MIN_VERSION_template_haskell(2,17,0)+import Language.Haskell.TH+  ( Quote,+    Code,+    unsafeCodeCoerce,+    stringE+  )+import Language.Haskell.TH.Syntax(+    Lift(..)+  )+# else+import Language.Haskell.TH+  ( stringE,+  )+import Language.Haskell.TH.Syntax+  ( Lift (..),+    Q,+    TExp,+    unsafeTExpCoerce,+  )+#endif+import Relude hiding+  ( ByteString,+    decodeUtf8,+    intercalate,+  )++data NAME+  = TYPE+  | FIELD+  | FRAGMENT++newtype Name (t :: NAME) = Name {unpackName :: Text}+  deriving+    (Generic)+  deriving newtype+    ( Show,+      Ord,+      Eq,+      IsString,+      ToString,+      Hashable,+      Semigroup,+      FromJSON,+      ToJSON+    )++instance Msg (Name t) where+  msg name = msg $ "\"" <> unpackName name <> "\""++packName :: Text -> Name t+packName = Name++instance Lift (Name t) where+  lift = stringE . T.unpack . unpackName++#if MIN_VERSION_template_haskell(2,17,0)+  liftTyped = liftTypedString . unpackName+    where+      liftTypedString :: (Quote m) => Text -> Code m (Name t)+      liftTypedString = unsafeCodeCoerce . stringE . T.unpack+      {-# INLINE liftTypedString #-}+#elif MIN_VERSION_template_haskell(2,16,0)+  liftTyped = liftTypedString . unpackName+    where+      liftTypedString :: IsString a => Text -> Q (TExp a)+      liftTypedString = unsafeTExpCoerce . stringE . T.unpack+      {-# INLINE liftTypedString #-}+#endif++instance RenderGQL (Name a) where+  renderGQL = fromText . unpackName++type FieldName = Name 'FIELD++type TypeName = Name 'TYPE++type FragmentName = Name 'FRAGMENT++intercalate :: Name t1 -> [Name t2] -> Name t3+intercalate (Name x) = Name . T.intercalate x . fmap unpackName+{-# INLINE intercalate #-}++unitTypeName :: TypeName+unitTypeName = "Unit"+{-# INLINE unitTypeName #-}++unitFieldName :: FieldName+unitFieldName = "_"+{-# INLINE unitFieldName #-}++isNotSystemTypeName :: TypeName -> Bool+isNotSystemTypeName =+  ( `notElem`+      [ "__Schema",+        "__Type",+        "__Directive",+        "__TypeKind",+        "__Field",+        "__DirectiveLocation",+        "__InputValue",+        "__EnumValue",+        "String",+        "Float",+        "Int",+        "Boolean",+        "ID"+      ]+  )+{-# INLINE isNotSystemTypeName #-}++isNotSystemFieldName :: FieldName -> Bool+isNotSystemFieldName =+  ( `notElem`+      [ "__typename",+        "__schema",+        "__type"+      ]+  )+{-# INLINE isNotSystemFieldName #-}

@@ -0,0 +1,63 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.Internal.AST.OperationType+  ( OperationType (..),+    QUERY,+    MUTATION,+    SUBSCRIPTION,+    toOperationType,+  )+where++import Data.Char (toLower)+import Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+  )+import Data.Morpheus.Types.Internal.AST.Error (Msg (..))+import Data.Morpheus.Types.Internal.AST.Name (TypeName)+import Language.Haskell.TH.Syntax+  ( Lift,+  )+import Relude hiding+  ( ByteString,+    decodeUtf8,+    intercalate,+  )++type QUERY = 'Query++type MUTATION = 'Mutation++type SUBSCRIPTION = 'Subscription++data OperationType+  = Query+  | Subscription+  | Mutation+  deriving+    ( Show,+      Eq,+      Lift,+      Generic,+      Hashable+    )++instance RenderGQL OperationType where+  renderGQL = fromString . fmap toLower . show++toOperationType :: TypeName -> Maybe OperationType+toOperationType "Subscription" = Just Subscription+toOperationType "Mutation" = Just Mutation+toOperationType "Query" = Just Query+toOperationType _ = Nothing+{-# INLINE toOperationType #-}++instance Msg OperationType where+  msg Query = msg ("query" :: TypeName)+  msg Mutation = msg ("mutation" :: TypeName)+  msg Subscription = msg ("subscription" :: TypeName)

@@ -26,28 +26,28 @@     DefaultValue,     getOperationName,     getOperationDataType,+    splitSystemSelection,   ) where +import Control.Monad.Except (MonadError (throwError)) import Data.Foldable (foldr')-import Data.Morpheus.Error.NameCollision-  ( NameCollision (..),+import Data.Mergeable+  ( Merge (..),+    MergeMap,+    NameCollision (..),+    OrdMap,   )+import Data.Mergeable.MergeMap (partition) import Data.Morpheus.Error.Operation   ( 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 (..),+  ( (<:>),+    HistoryT,     KeyOf (..),-    elems,+    addPath,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),@@ -57,19 +57,14 @@     space,   ) import Data.Morpheus.Types.Internal.AST.Base-  ( FieldName,-    Message,-    Msg (..),-    OperationType (..),-    Position,+  ( Position,     Ref (..),-    TypeName (..),-    ValidationError (..),-    ValidationErrors,-    intercalateName,+  )+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,+    at,+    atPositions,     msg,-    msgValidation,-    readName,   ) import Data.Morpheus.Types.Internal.AST.Fields   ( Arguments,@@ -77,8 +72,17 @@     renderArgumentValues,     renderDirectives,   )+import Data.Morpheus.Types.Internal.AST.Name+  ( FieldName,+    FragmentName,+    TypeName,+    intercalate,+    isNotSystemFieldName,+  )+import Data.Morpheus.Types.Internal.AST.OperationType (OperationType (..)) import Data.Morpheus.Types.Internal.AST.Stage-  ( RAW,+  ( ALLOW_DUPLICATES,+    RAW,     Stage,     VALID,   )@@ -95,10 +99,11 @@     VariableDefinitions,   ) import Language.Haskell.TH.Syntax (Lift (..))-import Relude+import Relude hiding (intercalate, show)+import Prelude (show)  data Fragment (stage :: Stage) = Fragment-  { fragmentName :: FieldName,+  { fragmentName :: FragmentName,     fragmentType :: TypeName,     fragmentPosition :: Position,     fragmentSelection :: SelectionSet stage,@@ -107,48 +112,56 @@   deriving (Show, Eq, Lift)  -- ERRORs-instance NameCollision (Fragment s) where+instance NameCollision GQLError (Fragment s) where   nameCollision Fragment {fragmentName, fragmentPosition} =-    ValidationError-      ("There can be only one fragment named " <> msg fragmentName <> ".")-      [fragmentPosition]+    ("There can be only one fragment named " <> msg fragmentName <> ".")+      `at` fragmentPosition -instance KeyOf FieldName (Fragment s) where+instance KeyOf FragmentName (Fragment s) where   keyOf = fragmentName -type Fragments (s :: Stage) = OrdMap FieldName (Fragment s)+type Fragments (s :: Stage) = OrdMap FragmentName (Fragment s)  data SelectionContent (s :: Stage) where   SelectionField :: SelectionContent s   SelectionSet :: SelectionSet s -> SelectionContent s-  UnionSelection :: UnionSelection VALID -> SelectionContent VALID+  UnionSelection ::+    { defaultSelection :: SelectionSet VALID,+      conditionalSelections :: UnionSelection VALID+    } ->+    SelectionContent VALID  renderSelectionSet :: SelectionSet VALID -> Rendering-renderSelectionSet = renderObject . elems+renderSelectionSet = renderObject . toList  instance RenderGQL (SelectionContent VALID) where   renderGQL SelectionField = ""   renderGQL (SelectionSet selSet) = renderSelectionSet selSet-  renderGQL (UnionSelection unionSets) = renderObject (elems unionSets)+  renderGQL (UnionSelection interfaceFields unionSets) =+    renderObject unionSelectionElements+    where+      unionSelectionElements :: [Either (Selection VALID) UnionTag]+      unionSelectionElements =+        map Left (toList interfaceFields)+          <> map Right (sortOn unionTagName $ toList unionSets)  instance   ( Monad m,-    Failure ValidationErrors m,-    SemigroupM m (SelectionSet s)+    MonadError GQLError m,+    Merge (HistoryT m) (SelectionSet s)   ) =>-  SemigroupM m (SelectionContent s)+  Merge (HistoryT m) (SelectionContent s)   where-  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+  merge (SelectionSet s1) (SelectionSet s2) = SelectionSet <$> merge s1 s2+  merge (UnionSelection m1 u1) (UnionSelection m2 u2) = UnionSelection <$> merge m1 m2 <*> merge u1 u2+  merge oldC currentC     | oldC == currentC = pure oldC-    | otherwise =-      failure-        [ ValidationError-            { validationMessage = msg (intercalateName "." $ fmap refName path),-              validationLocations = fmap refPosition path-            }-        ]+    | otherwise = do+      path <- ask+      throwError+        ( msg (intercalate "." $ fmap refName path)+            `atPositions` fmap refPosition path+        )  deriving instance Show (SelectionContent a) @@ -171,32 +184,42 @@       <> renderGQL unionTagName       <> renderSelectionSet unionTagSelection -mergeConflict :: [Ref FieldName] -> ValidationError -> ValidationErrors-mergeConflict [] err = [err]-mergeConflict refs@(rootField : xs) err =-  [ ValidationError-      { validationMessage = renderSubfields <> validationMessage err,-        validationLocations = fmap refPosition refs <> validationLocations err-      }-  ]+mergeConflict :: (Monad m, MonadError GQLError m) => GQLError -> HistoryT m a+mergeConflict err = do+  path <- ask+  __mergeConflict path   where-    fieldConflicts ref = msg (refName ref) <> " conflict because "-    renderSubfield ref txt = txt <> "subfields " <> fieldConflicts ref-    renderStart = "Fields " <> fieldConflicts rootField-    renderSubfields =-      foldr'-        renderSubfield-        renderStart-        xs+    __mergeConflict :: (Monad m, MonadError GQLError m) => [Ref FieldName] -> HistoryT m a+    __mergeConflict [] = throwError err+    __mergeConflict refs@(rootField : xs) =+      throwError+        (renderSubfields `atPositions` fmap refPosition refs <> err)+      where+        fieldConflicts ref = msg (refName ref) <> " conflict because "+        renderSubfield ref txt = txt <> "subfields " <> fieldConflicts ref+        renderStart = "Fields " <> fieldConflicts rootField+        renderSubfields =+          foldr'+            renderSubfield+            renderStart+            xs -instance (Monad m, Failure ValidationErrors m) => SemigroupM m UnionTag where-  mergeM path (UnionTag oldTag oldSel) (UnionTag _ currentSel) =-    UnionTag oldTag <$> mergeM path oldSel currentSel+instance+  ( Monad m,+    MonadError GQLError m+  ) =>+  Merge (HistoryT m) UnionTag+  where+  merge (UnionTag oldTag oldSel) (UnionTag _ currentSel) =+    UnionTag oldTag <$> merge oldSel currentSel -type UnionSelection (s :: Stage) = MergeSet s TypeName UnionTag+type UnionSelection (s :: Stage) = MergeMap (ALLOW_DUPLICATES s) TypeName UnionTag -type SelectionSet (s :: Stage) = MergeSet s FieldName (Selection s)+type SelectionSet (s :: Stage) = MergeMap (ALLOW_DUPLICATES s) FieldName (Selection s) +splitSystemSelection :: SelectionSet s -> (Maybe (SelectionSet s), Maybe (SelectionSet s))+splitSystemSelection = partition (not . isNotSystemFieldName . selectionName)+ data Selection (s :: Stage) where   Selection ::     { selectionPosition :: Position,@@ -208,7 +231,7 @@     } ->     Selection s   InlineFragment :: Fragment RAW -> Selection RAW-  Spread :: Directives RAW -> Ref FieldName -> Selection RAW+  Spread :: Directives RAW -> Ref FragmentName -> Selection RAW  instance RenderGQL (Selection VALID) where   renderGQL@@ -228,76 +251,81 @@       } = fromMaybe selectionName selectionAlias   keyOf _ = "" -useDifferentAliases :: Message+useDifferentAliases :: GQLError useDifferentAliases =   "Use different aliases on the "     <> "fields to fetch both if this was intentional."  instance   ( Monad m,-    SemigroupM m (SelectionSet a),-    Failure ValidationErrors m+    MonadError GQLError m,+    Merge (HistoryT m) (SelectionSet s)   ) =>-  SemigroupM m (Selection a)+  Merge (HistoryT m) (Selection s)   where-  mergeM-    path-    old@Selection {selectionPosition = pos1}-    current@Selection {selectionPosition = pos2} =-      do-        selectionName <- mergeName-        let currentPath = path <> [Ref selectionName pos1]-        selectionArguments <- mergeArguments currentPath-        selectionContent <- mergeM currentPath (selectionContent old) (selectionContent current)+  merge = mergeSelection++mergeSelection ::+  ( Monad m,+    MonadError GQLError m,+    Merge (HistoryT m) (SelectionSet s)+  ) =>+  Selection s ->+  Selection s ->+  HistoryT m (Selection s)+mergeSelection+  old@Selection {selectionPosition = pos1}+  current@Selection {selectionPosition = pos2} =+    do+      selectionName <- mergeName [pos1, pos2] old current+      addPath (Ref selectionName pos1) $ do+        selectionArguments <- mergeArguments+        selectionContent <- merge (selectionContent old) (selectionContent current)+        dirs <- selectionDirectives old <:> selectionDirectives current         pure $           Selection             { selectionAlias = mergeAlias,               selectionPosition = pos1,-              selectionDirectives = selectionDirectives old <> selectionDirectives current,+              selectionDirectives = dirs,               ..             }-      where-        -- passes if:+    where+      mergeAlias+        | all (isJust . selectionAlias) [old, current] = selectionAlias old+        | otherwise = Nothing+      --- arguments must be equal+      mergeArguments+        | selectionArguments old == selectionArguments current = pure $ selectionArguments current+        | otherwise =+          mergeConflict $+            ("they have differing arguments. " <> useDifferentAliases)+              `atPositions` [pos1, pos2]+mergeSelection x y = mergeConflict ("INTERNAL: can't merge. " <> msgValue x <> msgValue y <> useDifferentAliases) -        --     user1: user-        --   }-        -- fails if:+msgValue :: Show a => a -> GQLError+msgValue = msg . show -        --     user1: product-        --   }-        mergeName-          | selectionName old == selectionName current = pure $ selectionName current-          | otherwise =-            failure $ mergeConflict path $-              ValidationError-                { validationMessage =-                    "" <> msg (selectionName old) <> " and " <> msg (selectionName current)-                      <> " are different fields. "-                      <> useDifferentAliases,-                  validationLocations = [pos1, pos2]-                }-        ----------------------        -- alias name is relevant only if they collide by allies like:-        --   { user1: user-        --     user1: user-        --   }-        mergeAlias-          | all (isJust . selectionAlias) [old, current] = selectionAlias old-          | otherwise = Nothing-        --- arguments must be equal-        mergeArguments currentPath-          | selectionArguments old == selectionArguments current = pure $ selectionArguments current-          | otherwise =-            failure $ mergeConflict currentPath $-              ValidationError-                { validationMessage = "they have differing arguments. " <> useDifferentAliases,-                  validationLocations = [pos1, pos2]-                }-  mergeM path _ _ =-    failure $-      mergeConflict-        path-        ("INTERNAL: can't merge. " <> msgValidation useDifferentAliases :: ValidationError)+-- fails if alias matches but name not:+--   { user1: user+--     user1: product+--   }+mergeName ::+  (Monad m, MonadError GQLError m, Foldable t) =>+  t Position ->+  Selection s1 ->+  Selection s2 ->+  HistoryT m FieldName+mergeName pos old current+  | selectionName old == selectionName current = pure $ selectionName current+  | otherwise =+    mergeConflict $+      ( msg (selectionName old)+          <> " and "+          <> msg (selectionName current)+          <> " are different fields. "+          <> useDifferentAliases+      )+        `atPositions` pos  deriving instance Show (Selection a) @@ -332,11 +360,11 @@         <> newline  getOperationName :: Maybe FieldName -> TypeName-getOperationName = maybe "AnonymousOperation" (TypeName . readName)+getOperationName = maybe "AnonymousOperation" coerce -getOperationDataType :: Failure ValidationError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)+getOperationDataType :: MonadError GQLError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID) getOperationDataType Operation {operationType = Query} lib = pure (query lib) getOperationDataType Operation {operationType = Mutation, operationPosition} lib =-  maybe (failure $ mutationIsNotDefined operationPosition) pure (mutation lib)+  maybe (throwError $ mutationIsNotDefined operationPosition) pure (mutation lib) getOperationDataType Operation {operationType = Subscription, operationPosition} lib =-  maybe (failure $ subscriptionIsNotDefined operationPosition) pure (subscription lib)+  maybe (throwError $ subscriptionIsNotDefined operationPosition) pure (subscription lib)

@@ -8,9 +8,12 @@     RAW,     Stage (..),     CONST_OR_VALID,+    ALLOW_DUPLICATES,   ) where +import Data.Bool (Bool (..))+ type CONST = 'CONST  type VALID = 'VALID@@ -25,3 +28,7 @@ type family CONST_OR_VALID (a :: Stage) :: Stage where   CONST_OR_VALID VALID = VALID   CONST_OR_VALID a = CONST++type family ALLOW_DUPLICATES s where+  ALLOW_DUPLICATES RAW = 'True+  ALLOW_DUPLICATES a = 'False

@@ -1,28 +0,0 @@--- Template Haskell Types-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Types.Internal.AST.TH-  ( ConsD (..),-    mkConsEnum,-  )-where--import Data.Morpheus.Types.Internal.AST.Base-  ( TypeName,-    hsTypeName,-  )-import Data.Morpheus.Types.Internal.AST.TypeSystem-  ( DataEnumValue (..),-  )-import Relude--data ConsD f = ConsD-  { cName :: TypeName,-    cFields :: [f]-  }-  deriving (Show)--mkConsEnum :: DataEnumValue s -> ConsD f-mkConsEnum DataEnumValue {enumName} = ConsD {cName = hsTypeName enumName, cFields = []}

@@ -6,16 +6,15 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Types.Internal.AST.Type-  ( DataTypeWrapper (..),-    TypeRef (..),+  ( TypeRef (..),     TypeWrapper (..),     Nullable (..),     Strictness (..),     TypeKind (..),-    isWeaker,+    Subtyping (..),     mkTypeRef,-    toGQLWrapper,-    toHSWrappers,+    mkBaseType,+    mkMaybeType,   ) where @@ -25,12 +24,16 @@     render,     renderGQL,   )-import Data.Morpheus.Types.Internal.AST.Base-  ( FieldName (..),-    Msg (..),-    OperationType,-    TypeName (..),+import Data.Morpheus.Types.Internal.AST.Error+  ( Msg (..),   )+import Data.Morpheus.Types.Internal.AST.Name+  ( TypeName,+    packName,+  )+import Data.Morpheus.Types.Internal.AST.OperationType+  ( OperationType (..),+  ) import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Encoding (decodeUtf8) import Language.Haskell.TH.Syntax (Lift (..))@@ -82,71 +85,86 @@  -- TypeWrappers ------------------------------------------------------------------------------------ data TypeWrapper-  = TypeList-  | TypeMaybe+  = TypeList !TypeWrapper !Bool+  | BaseType !Bool   deriving (Show, Eq, Lift) -data DataTypeWrapper-  = ListType-  | NonNullType-  deriving (Show, Lift)--isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool-isWeaker (TypeMaybe : xs1) (TypeMaybe : xs2) = isWeaker xs1 xs2-isWeaker (TypeMaybe : _) _ = True-isWeaker (_ : xs1) (_ : xs2) = isWeaker xs1 xs2-isWeaker _ _ = False+mkBaseType :: TypeWrapper+mkBaseType = BaseType True -toGQLWrapper :: [TypeWrapper] -> [DataTypeWrapper]-toGQLWrapper (TypeMaybe : (TypeMaybe : tw)) = toGQLWrapper (TypeMaybe : tw)-toGQLWrapper (TypeMaybe : (TypeList : tw)) = ListType : toGQLWrapper tw-toGQLWrapper (TypeList : tw) = [NonNullType, ListType] <> toGQLWrapper tw-toGQLWrapper [TypeMaybe] = []-toGQLWrapper [] = [NonNullType]+mkMaybeType :: TypeWrapper+mkMaybeType = BaseType False -toHSWrappers :: [DataTypeWrapper] -> [TypeWrapper]-toHSWrappers (NonNullType : (NonNullType : xs)) =-  toHSWrappers (NonNullType : xs)-toHSWrappers (NonNullType : (ListType : xs)) = TypeList : toHSWrappers xs-toHSWrappers (ListType : xs) = [TypeMaybe, TypeList] <> toHSWrappers xs-toHSWrappers [] = [TypeMaybe]-toHSWrappers [NonNullType] = []+-- If S is a subtype of T, "S <: T"+-- A is a subtype of B, then all terms of type A also have type B.+-- type B = Int | Null+-- type A = Int+-- A <: B+--+-- interface A { a: String }+--+-- type B implements A { a: String!}+--+-- type B is subtype of A since :  {String} ⊂ {String, null}+--+-- interface A { a: String! }+--+-- type B implements A { a: String }+--+-- type B is not subtype of A since :  {String, null} ⊂ {String}+--+-- type A = { T, Null}+-- type B = T+-- type B is subtype of A since :  {T} ⊂ {T, Null}+-- type B is Subtype if B since: {T} ⊂ {T}+class Subtyping t where+  isSubtype :: t -> t -> Bool -renderWrapped :: RenderGQL a => a -> [TypeWrapper] -> Rendering-renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers)-  where-    showGQLWrapper [] = renderGQL x-    showGQLWrapper (ListType : xs) = "[" <> showGQLWrapper xs <> "]"-    showGQLWrapper (NonNullType : xs) = showGQLWrapper xs <> "!"+instance Subtyping TypeWrapper where+  isSubtype (TypeList b nonNull1) (TypeList a nonNull2) =+    nonNull1 >= nonNull2 && isSubtype b a+  isSubtype (BaseType b) (BaseType a) = b >= a+  isSubtype b a = b == a  -- TypeRef ------------------------------------------------------------------- data TypeRef = TypeRef   { typeConName :: TypeName,-    typeWrappers :: [TypeWrapper]+    typeWrappers :: TypeWrapper   }   deriving (Show, Eq, Lift)  mkTypeRef :: TypeName -> TypeRef-mkTypeRef typeConName = TypeRef {typeConName, typeWrappers = []}+mkTypeRef typeConName = TypeRef {typeConName, typeWrappers = mkBaseType} +instance Subtyping TypeRef where+  isSubtype t1 t2 =+    typeConName t1 == typeConName t2+      && typeWrappers t1 `isSubtype` typeWrappers t2+ instance RenderGQL TypeRef where-  renderGQL TypeRef {typeConName, typeWrappers} = renderWrapped typeConName typeWrappers+  renderGQL TypeRef {typeConName, typeWrappers} = renderWrapper typeWrappers+    where+      renderWrapper (TypeList xs isNonNull) = "[" <> renderWrapper xs <> "]" <> renderNonNull isNonNull+      renderWrapper (BaseType isNonNull) = renderGQL typeConName <> renderNonNull isNonNull +renderNonNull :: Bool -> Rendering+renderNonNull True = "!"+renderNonNull False = ""+ instance Msg TypeRef where-  msg = msg . FieldName . LT.toStrict . decodeUtf8 . render+  msg = msg . packName . LT.toStrict . decodeUtf8 . render  class Nullable a where   isNullable :: a -> Bool   toNullable :: a -> a -instance Nullable [TypeWrapper] where-  isNullable (TypeMaybe : _) = True-  isNullable _ = False-  toNullable (TypeMaybe : xs) = TypeMaybe : xs-  toNullable xs = TypeMaybe : xs+instance Nullable TypeWrapper where+  isNullable (TypeList _ nonNull) = not nonNull+  isNullable (BaseType nonNull) = not nonNull+  toNullable (TypeList t _) = TypeList t False+  toNullable BaseType {} = BaseType False  instance Nullable TypeRef where   isNullable = isNullable . typeWrappers

@@ -23,14 +23,13 @@ module Data.Morpheus.Types.Internal.AST.TypeSystem   ( ScalarDefinition (..),     DataEnum,-    DataUnion,+    UnionTypeDefinition,     TypeContent (..),     TypeDefinition (..),     Schema (..),     DataEnumValue (..),-    TypeLib,+    TypeDefinitions,     TypeCategory,-    DataInputUnion,     mkEnumContent,     mkUnionContent,     mkType,@@ -49,31 +48,40 @@     possibleTypes,     possibleInterfaceTypes,     defineSchemaWith,+    isPossibleInterfaceType,+    typeDefinitions,+    lookupDataType,   ) where  -- MORPHEUS-import Data.Morpheus.Error.NameCollision-  ( NameCollision (..),-  )-import Data.Morpheus.Ext.OrdMap-  ( OrdMap,++-- MORPHEUS++-- MORPHEUS++-- MORPHEUS+import Control.Monad.Except (MonadError (throwError))+import qualified Data.HashMap.Lazy as HM+import Data.Mergeable+  ( IsMap (lookup),+    Merge (..),+    NameCollision (..),+    OrdMap,   )-import Data.Morpheus.Ext.SafeHashMap+import Data.Mergeable.SafeHashMap   ( SafeHashMap,-    insert,-  )-import Data.Morpheus.Ext.SemigroupM-  ( (<:>),-    SemigroupM (..),+    toHashMap,   ) import Data.Morpheus.Internal.Utils-  ( Elems (..),+  ( (<:>),     Empty (..),-    Failure (..),-    FromElems (..),+    IsMap (..),     KeyOf (..),-    Selectable (..),+    insert,+    selectOr,+    toPair,+    unsafeFromList,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),@@ -86,22 +94,28 @@   ) import Data.Morpheus.Types.Internal.AST.Base   ( Description,-    OperationType (..),     TRUE,     Token,-    TypeName,-    ValidationError,-    ValidationErrors,-    isNotSystemTypeName,-    msgValidation,-    toOperationType,   )+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,+    msg,+  ) import Data.Morpheus.Types.Internal.AST.Fields-  ( Directive,-    DirectiveDefinition (..),+  ( DirectiveDefinition (..),     Directives,+    DirectivesDefinition,     FieldsDefinition,   )+import Data.Morpheus.Types.Internal.AST.Name+  ( TypeName,+    isNotSystemTypeName,+    unpackName,+  )+import Data.Morpheus.Types.Internal.AST.OperationType+  ( OperationType (..),+    toOperationType,+  ) import Data.Morpheus.Types.Internal.AST.Stage   ( CONST,     Stage,@@ -128,14 +142,14 @@     type (<=?),   ) import Data.Morpheus.Types.Internal.AST.Union-  ( DataInputUnion,-    DataUnion,+  ( UnionTypeDefinition,     mkInputUnionFields,     mkUnionMember,   ) import Data.Morpheus.Types.Internal.AST.Value   ( Value (..),   )+import qualified Data.Text as T import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift (..)) import Relude hiding@@ -185,7 +199,7 @@ data DataEnumValue s = DataEnumValue   { enumDescription :: Maybe Description,     enumName :: TypeName,-    enumDirectives :: [Directive s]+    enumDirectives :: Directives s   }   deriving (Show, Lift, Eq) @@ -201,32 +215,30 @@ --    OperationType: NamedType  data Schema (s :: Stage) = Schema-  { types :: TypeLib s,+  { types :: TypeDefinitions s,     query :: TypeDefinition OBJECT s,     mutation :: Maybe (TypeDefinition OBJECT s),     subscription :: Maybe (TypeDefinition OBJECT s),-    directiveDefinitions :: [DirectiveDefinition s]+    directiveDefinitions :: DirectivesDefinition s   }   deriving (Show, Lift)  instance   ( Monad m,-    Failure ValidationErrors m+    MonadError GQLError m   ) =>-  SemigroupM-    m-    (Schema s)+  Merge m (Schema s)   where-  mergeM _ s1 s2 =+  merge s1 s2 =     Schema-      <$> (types s1 <:> types s2)+      <$> merge (types s1) (types s2)       <*> mergeOperation (query s1) (query s2)       <*> mergeOptional (mutation s1) (mutation s2)       <*> mergeOptional (subscription s1) (subscription s2)-      <*> pure (directiveDefinitions s1 <> directiveDefinitions s2)+      <*> directiveDefinitions s1 <:> directiveDefinitions s2  mergeOptional ::-  (Monad m, Failure ValidationErrors m) =>+  (Monad m, MonadError GQLError m) =>   Maybe (TypeDefinition OBJECT s) ->   Maybe (TypeDefinition OBJECT s) ->   m (Maybe (TypeDefinition OBJECT s))@@ -235,7 +247,7 @@ mergeOptional (Just x) (Just y) = Just <$> mergeOperation x y  mergeOperation ::-  (Monad m, Failure ValidationErrors m) =>+  (Monad m, MonadError GQLError m) =>   TypeDefinition OBJECT s ->   TypeDefinition OBJECT s ->   m (TypeDefinition OBJECT s)@@ -243,7 +255,7 @@   TypeDefinition {typeContent = DataObject i1 fields1}   TypeDefinition {typeContent = DataObject i2 fields2, ..} =     do-      fields <- fields1 <:> fields2+      fields <- merge fields1 fields2       pure $ TypeDefinition {typeContent = DataObject (i1 <> i2) fields, ..}  data SchemaDefinition = SchemaDefinition@@ -253,16 +265,12 @@   deriving (Show)  instance RenderGQL SchemaDefinition where-  renderGQL = renderSchemaDefinition . elems . unSchemaDefinition+  renderGQL = renderSchemaDefinition . toList . unSchemaDefinition -renderSchemaDefinition :: RenderGQL a => [a] -> Rendering+renderSchemaDefinition :: [RootOperationTypeDefinition] -> Rendering renderSchemaDefinition entries = "schema" <> renderObject entries <> newline -instance Selectable OperationType RootOperationTypeDefinition SchemaDefinition where-  selectOr fallback f key SchemaDefinition {unSchemaDefinition} =-    selectOr fallback f key unSchemaDefinition--instance NameCollision SchemaDefinition where+instance NameCollision GQLError SchemaDefinition where   nameCollision _ = "There can Be only One SchemaDefinition."  instance KeyOf TypeName SchemaDefinition where@@ -280,9 +288,9 @@   }   deriving (Show, Eq) -instance NameCollision RootOperationTypeDefinition where+instance NameCollision GQLError RootOperationTypeDefinition where   nameCollision RootOperationTypeDefinition {rootOperationType} =-    "There can Be only One TypeDefinition for schema." <> msgValidation rootOperationType+    "There can Be only One TypeDefinition for schema." <> msg rootOperationType  instance KeyOf OperationType RootOperationTypeDefinition where   keyOf = rootOperationType@@ -294,34 +302,29 @@         rootOperationTypeDefinitionName       } = renderEntry rootOperationType rootOperationTypeDefinitionName -type TypeLib s = SafeHashMap TypeName (TypeDefinition ANY s)+type TypeDefinitions s = SafeHashMap TypeName (TypeDefinition ANY s) -instance Selectable TypeName (TypeDefinition ANY s) (Schema s) where-  selectOr fb f name lib = maybe fb f (lookupDataType name lib)+typeDefinitions :: Schema s -> HashMap TypeName (TypeDefinition ANY s)+typeDefinitions schema@Schema {..} = toHashMap types <> HM.fromList operations+  where+    operations = map toPair $ rootTypeDefinitions schema -instance Elems (TypeDefinition ANY s) (Schema s) where-  elems Schema {..} =-    elems types-      <> concatMap fromOperation [Just query, mutation, subscription]+rootTypeDefinitions :: Schema s -> [TypeDefinition ANY s]+rootTypeDefinitions Schema {..} = map toAny $ catMaybes [Just query, mutation, subscription] -instance-  ( Monad m,-    Failure ValidationErrors m-  ) =>-  FromElems m (TypeDefinition ANY s) (Schema s)-  where-  fromElems types =-    traverse3-      (popByKey types)-      ( RootOperationTypeDefinition Query "Query",-        RootOperationTypeDefinition Mutation "Mutation",-        RootOperationTypeDefinition Subscription "Subscription"-      )-      >>= defineSchemaWith types+mkSchema :: (Monad m, MonadError GQLError m) => [TypeDefinition ANY s] -> m (Schema s)+mkSchema types =+  traverse3+    (popByKey types)+    ( RootOperationTypeDefinition Query "Query",+      RootOperationTypeDefinition Mutation "Mutation",+      RootOperationTypeDefinition Subscription "Subscription"+    )+    >>= defineSchemaWith types  defineSchemaWith ::   ( Monad f,-    Failure ValidationErrors f+    MonadError GQLError f   ) =>   [TypeDefinition cat s] ->   ( Maybe (TypeDefinition OBJECT s),@@ -333,7 +336,7 @@   let types = excludeTypes [Just query, mutation, subscription] oTypes   let schema = (initTypeLib query) {mutation, subscription}   foldlM (flip defineType) schema types-defineSchemaWith _ (Nothing, _, _) = failure ["Query root type must be provided." :: ValidationError]+defineSchemaWith _ (Nothing, _, _) = throwError "Query root type must be provided."  excludeTypes :: [Maybe (TypeDefinition c1 s)] -> [TypeDefinition c2 s] -> [TypeDefinition c2 s] excludeTypes exclusionTypes = filter ((`notElem` blacklist) . typeName)@@ -342,29 +345,30 @@     blacklist = fmap typeName (catMaybes exclusionTypes)  withDirectives ::-  [DirectiveDefinition s] ->+  (Monad m, MonadError GQLError m) =>+  DirectivesDefinition s ->   Schema s ->-  Schema s-withDirectives dirs Schema {..} =-  Schema-    { directiveDefinitions = directiveDefinitions <> dirs,-      ..-    }+  m (Schema s)+withDirectives dirs Schema {..} = do+  dirs' <- directiveDefinitions <:> dirs+  pure $+    Schema+      { directiveDefinitions = dirs',+        ..+      }  buildSchema ::-  (Monad m, Failure ValidationErrors m) =>+  (Monad m, MonadError GQLError m) =>   ( Maybe SchemaDefinition,     [TypeDefinition ANY s],-    [DirectiveDefinition s]+    DirectivesDefinition s   ) ->   m (Schema s)-buildSchema (Nothing, types, dirs) = withDirectives dirs <$> fromElems types+buildSchema (Nothing, types, dirs) = mkSchema types >>= withDirectives dirs buildSchema (Just schemaDef, types, dirs) =-  withDirectives-    dirs-    <$> ( traverse3 selectOp (Query, Mutation, Subscription)-            >>= defineSchemaWith types-        )+  traverse3 selectOp (Query, Mutation, Subscription)+    >>= defineSchemaWith types+    >>= withDirectives dirs   where     selectOp op = selectOperation schemaDef op types @@ -372,26 +376,26 @@ traverse3 f (a1, a2, a3) = (,,) <$> f a1 <*> f a2 <*> f a3  typeReference ::-  (Monad m, Failure ValidationErrors m) =>+  (Monad m, MonadError GQLError m) =>   [TypeDefinition ANY s] ->   RootOperationTypeDefinition ->   m (Maybe (TypeDefinition OBJECT s)) typeReference types rootOperation =   popByKey types rootOperation     >>= maybe-      (failure ["Unknown type " <> msgValidation (rootOperationTypeDefinitionName rootOperation) <> "."])+      (throwError $ "Unknown type " <> msg (rootOperationTypeDefinitionName rootOperation) <> ".")       (pure . Just)  selectOperation ::   ( Monad f,-    Failure ValidationErrors f+    MonadError GQLError f   ) =>   SchemaDefinition ->   OperationType ->   [TypeDefinition ANY s] ->   f (Maybe (TypeDefinition OBJECT s))-selectOperation schemaDef operationType lib =-  selectOr (pure Nothing) (typeReference lib) operationType schemaDef+selectOperation SchemaDefinition {unSchemaDefinition} operationType lib =+  selectOr (pure Nothing) (typeReference lib) operationType unSchemaDefinition  initTypeLib :: TypeDefinition OBJECT s -> Schema s initTypeLib query =@@ -413,7 +417,7 @@   isType name query     <|> (mutation >>= isType name)     <|> (subscription >>= isType name)-    <|> selectOr Nothing Just name types+    <|> lookup name types  -- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types -------------------------------------------------------------------------@@ -433,14 +437,20 @@   }   deriving (Show, Lift, Eq) +instance Ord (TypeDefinition k s) where+  compare a b =+    compare (indexOf $ typeContent a) (indexOf $ typeContent b)+      <> compare (typeName a) (typeName b)+ instance KeyOf TypeName (TypeDefinition a s) where   keyOf = typeName  instance Strictness (TypeDefinition k s) where   isResolverType = isResolverType . typeContent -instance NameCollision (TypeDefinition cat s) where-  nameCollision x = "There can Be only One TypeDefinition Named " <> msgValidation (typeName x) <> "."+instance NameCollision GQLError (TypeDefinition cat s) where+  nameCollision x =+    "There can Be only One TypeDefinition Named " <> msg (typeName x) <> "."  instance   ToCategory (TypeContent TRUE) cat cat' =>@@ -467,7 +477,10 @@   TypeName ->   Schema s ->   [TypeDefinition ANY s]-possibleInterfaceTypes name schema = mapMaybe (isPossibleInterfaceType name) (elems schema)+possibleInterfaceTypes name schema =+  mapMaybe+    (isPossibleInterfaceType name)+    (toList $ typeDefinitions schema)  isPossibleInterfaceType ::   TypeName ->@@ -506,7 +519,7 @@     } ->     CondTypeContent INPUT_OBJECT a s   DataInputUnion ::-    { inputUnionMembers :: DataInputUnion s+    { inputUnionMembers :: UnionTypeDefinition IN s     } ->     CondTypeContent IN a s   DataObject ::@@ -515,7 +528,7 @@     } ->     CondTypeContent OBJECT a s   DataUnion ::-    { unionMembers :: DataUnion s+    { unionMembers :: UnionTypeDefinition OUT s     } ->     CondTypeContent OUT a s   DataInterface ::@@ -529,6 +542,15 @@  deriving instance Lift (TypeContent a b s) +indexOf :: TypeContent b a s -> Int+indexOf DataScalar {} = 0+indexOf DataEnum {} = 1+indexOf DataInputObject {} = 2+indexOf DataInputUnion {} = 3+indexOf DataInterface {} = 4+indexOf DataObject {} = 5+indexOf DataUnion {} = 6+ instance Strictness (TypeContent TRUE k s) where   isResolverType DataObject {} = True   isResolverType DataUnion {} = True@@ -579,7 +601,7 @@   TypeDefinition     { typeName,       typeDescription = Nothing,-      typeDirectives = [],+      typeDirectives = empty,       typeContent     } @@ -590,14 +612,14 @@ mkEnumContent typeData = DataEnum (fmap mkEnumValue typeData)  mkUnionContent :: [TypeName] -> TypeContent TRUE OUT s-mkUnionContent typeData = DataUnion $ fmap mkUnionMember typeData+mkUnionContent typeData = DataUnion $ unsafeFromList $ map (toPair . mkUnionMember) typeData  mkEnumValue :: TypeName -> DataEnumValue s mkEnumValue enumName =   DataEnumValue     { enumName,       enumDescription = Nothing,-      enumDirectives = []+      enumDirectives = empty     }  isLeaf :: TypeContent TRUE a s -> Bool@@ -616,13 +638,9 @@     __kind DataInputUnion {} = KindInputUnion     __kind DataInterface {} = KindInterface -fromOperation :: Maybe (TypeDefinition OBJECT s) -> [TypeDefinition ANY s]-fromOperation (Just datatype) = [toAny datatype]-fromOperation Nothing = []- defineType ::   ( Monad m,-    Failure ValidationErrors m+    MonadError GQLError m   ) =>   TypeDefinition k s ->   Schema s ->@@ -635,7 +653,7 @@ lookupWith f key = find ((== key) . f)  popByKey ::-  (Applicative m, Failure ValidationErrors m) =>+  (MonadError GQLError m) =>   [TypeDefinition ANY s] ->   RootOperationTypeDefinition ->   m (Maybe (TypeDefinition OBJECT s))@@ -643,28 +661,41 @@   Just dt@TypeDefinition {typeContent = DataObject {}} ->     pure (fromAny dt)   Just {} ->-    failure-      [ msgValidation (show opType)-          <> " root type must be Object type if provided, it cannot be "-          <> msgValidation name-      ]+    throwError $+      msg (show opType)+        <> " root type must be Object type if provided, it cannot be "+        <> msg name   _ -> pure Nothing  -- -- OTHER -------------------------------------------------------------------------------------------------- +hasDefaultOperationName :: RootOperationTypeDefinition -> Bool+hasDefaultOperationName+  RootOperationTypeDefinition+    { rootOperationType,+      rootOperationTypeDefinitionName = name+    } = show rootOperationType == T.unpack (unpackName name)+ instance RenderGQL (Schema s) where-  renderGQL schema =-    intercalate newline (fmap renderGQL visibleTypes <> [renderSchemaDefinition entries])+  renderGQL schema@Schema {..} =+    intercalate newline (fmap renderGQL visibleTypes <> schemaDefinition)     where+      schemaDefinition+        | all hasDefaultOperationName entries = []+        | otherwise = [renderSchemaDefinition entries]       entries =-        RootOperationTypeDefinition Query (typeName $ query schema)-          : catMaybes-            [ RootOperationTypeDefinition Mutation . typeName <$> mutation schema,-              RootOperationTypeDefinition Subscription . typeName <$> subscription schema-            ]-      visibleTypes = filter (isNotSystemTypeName . typeName) (elems schema)+        catMaybes+          [ RootOperationTypeDefinition Query . typeName <$> Just query,+            RootOperationTypeDefinition Mutation . typeName <$> mutation,+            RootOperationTypeDefinition Subscription . typeName <$> subscription+          ]+      visibleTypes =+        filter+          (isNotSystemTypeName . typeName)+          (sort $ toList types)+          <> rootTypeDefinitions schema  instance RenderGQL (TypeDefinition a s) where   renderGQL TypeDefinition {typeName, typeContent} = __render typeContent <> newline

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}@@ -12,46 +13,46 @@   ( constraintInputUnion,     mkUnionMember,     mkNullaryMember,-    DataUnion,-    DataInputUnion,+    UnionTypeDefinition,     UnionMember (..),     mkInputUnionFields,     getInputUnionValue,   ) where +import Control.Monad.Except (throwError)+import Data.Mergeable (NameCollision (..), OrdMap) import Data.Morpheus.Internal.Utils-  ( Failure (..),+  ( Empty (empty),     KeyOf (..),-    elems,     selectBy,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),   )-import Data.Morpheus.Types.Internal.AST.Base-  ( FieldName (..),-    Message (..),+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,     Msg (..),-    TypeName (..),-    toFieldName,-    unitTypeName,+    msg,   ) import Data.Morpheus.Types.Internal.AST.Fields   ( FieldDefinition (..),     FieldsDefinition,     unsafeFromFields,   )+import Data.Morpheus.Types.Internal.AST.Name+  ( TypeName,+    unitTypeName,+  ) import Data.Morpheus.Types.Internal.AST.Stage   ( Stage,   ) import Data.Morpheus.Types.Internal.AST.Type   ( TypeRef (..),-    TypeWrapper (..),+    mkMaybeType,   ) import Data.Morpheus.Types.Internal.AST.TypeCategory   ( IN,-    OUT,     TypeCategory,   ) import Data.Morpheus.Types.Internal.AST.Value@@ -60,7 +61,7 @@     Value (..),   ) import Language.Haskell.TH.Syntax (Lift (..))-import Relude+import Relude hiding (empty)  mkUnionMember :: TypeName -> UnionMember cat s mkUnionMember name = UnionMember name False@@ -74,9 +75,12 @@   }   deriving (Show, Lift, Eq) -type DataUnion s = [UnionMember OUT s]+instance NameCollision GQLError (UnionMember c s) where+  nameCollision UnionMember {memberName} =+    "There can Be only one union variant named "+      <> msg memberName -type DataInputUnion s = [UnionMember IN s]+type UnionTypeDefinition k s = OrdMap TypeName (UnionMember k s)  instance RenderGQL (UnionMember cat s) where   renderGQL = renderGQL . memberName@@ -90,44 +94,44 @@ getInputUnionValue ::   forall stage.   Object stage ->-  Either Message (TypeName, Value stage)+  Either GQLError (TypeName, Value stage) getInputUnionValue hm =-  case elems hm of-    [] -> failure ("Exclusive input objects must provide a value for at least one field." :: Message)-    [ObjectEntry (FieldName name) value] -> pure (TypeName name, value)-    _ -> failure ("Exclusive input objects are not allowed to provide values for multiple fields." :: Message)+  case toList hm of+    [] -> throwError "Exclusive input objects must provide a value for at least one field."+    [ObjectEntry name value] -> pure (coerce name, value)+    _ -> throwError "Exclusive input objects are not allowed to provide values for multiple fields."  constraintInputUnion ::   forall stage schemaStage.-  [UnionMember IN schemaStage] ->+  UnionTypeDefinition IN schemaStage ->   Object stage ->-  Either Message (UnionMember IN schemaStage, Value stage)+  Either GQLError (UnionMember IN schemaStage, Value stage) constraintInputUnion tags hm = do   (name, value) <- getInputUnionValue hm   (,value) <$> isPossibleInputUnion tags name -isPossibleInputUnion :: [UnionMember IN s] -> TypeName -> Either Message (UnionMember IN s)+isPossibleInputUnion :: UnionTypeDefinition IN s -> TypeName -> Either GQLError (UnionMember IN s) isPossibleInputUnion tags name =   selectBy     (msg name <> " is not possible union type")     name     tags -mkInputUnionFields :: [UnionMember IN s] -> FieldsDefinition IN s-mkInputUnionFields = unsafeFromFields . fmap mkInputUnionField+mkInputUnionFields :: Foldable t => t (UnionMember IN s) -> FieldsDefinition IN s+mkInputUnionFields = unsafeFromFields . fmap mkInputUnionField . toList  mkInputUnionField :: UnionMember IN s -> FieldDefinition IN s mkInputUnionField UnionMember {memberName, nullary} =   FieldDefinition-    { fieldName = toFieldName memberName,+    { fieldName = coerce memberName,       fieldDescription = Nothing,       fieldContent = Nothing,       fieldType =         TypeRef           { typeConName,-            typeWrappers = [TypeMaybe]+            typeWrappers = mkMaybeType           },-      fieldDirectives = []+      fieldDirectives = empty     }   where     typeConName

@@ -43,17 +43,13 @@   ) import Data.Foldable (foldr') import qualified Data.HashMap.Lazy as M-import Data.Morpheus.Error.NameCollision+import Data.Mergeable   ( NameCollision (..),-  )-import Data.Morpheus.Ext.OrdMap-  ( OrdMap,-    unsafeFromList,+    OrdMap,   ) import Data.Morpheus.Internal.Utils   ( KeyOf (..),-    elems,-    mapTuple,+    unsafeFromList,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),@@ -63,15 +59,20 @@     space,   ) import Data.Morpheus.Types.Internal.AST.Base-  ( FieldName,-    FieldName (..),-    Msg (..),-    Position,+  ( Position,     Ref (..),-    TypeName (..),-    ValidationError (..),-    msgValidation,   )+import Data.Morpheus.Types.Internal.AST.Error+  ( GQLError,+    Msg (..),+    at,+  )+import Data.Morpheus.Types.Internal.AST.Name+  ( FieldName,+    TypeName,+    packName,+    unpackName,+  ) import Data.Morpheus.Types.Internal.AST.Stage   ( CONST,     CONST_OR_VALID,@@ -88,6 +89,7 @@ import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift (..)) import Relude+import qualified Data.Text as T  -- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'. -- for performance reason type 'Text' represents GraphQl 'String' value@@ -99,6 +101,9 @@   | Value A.Value   deriving (Show, Eq, Generic, Lift) +instance IsString ScalarValue where+  fromString = String . T.pack+ instance RenderGQL ScalarValue where   renderGQL (Int x) = renderGQL x   renderGQL (Float x) = renderGQL x@@ -146,12 +151,10 @@ instance KeyOf FieldName (Variable s) where   keyOf = variableName -instance NameCollision (Variable s) where+instance NameCollision GQLError (Variable s) where   nameCollision Variable {variableName, variablePosition} =-    ValidationError-      { validationMessage = "There can Be only One Variable Named " <> msg variableName,-        validationLocations = [variablePosition]-      }+    ("There can Be only One Variable Named " <> msg variableName)+      `at` variablePosition  type VariableDefinitions s = OrdMap FieldName (Variable s) @@ -164,6 +167,9 @@   Scalar :: ScalarValue -> Value stage   Null :: Value stage +instance IsString (Value stage) where+  fromString = Scalar . fromString+ deriving instance Show (Value a)  deriving instance Eq (Value s)@@ -175,11 +181,12 @@   deriving (Eq, Show)  instance RenderGQL (ObjectEntry a) where-  renderGQL (ObjectEntry (FieldName name) value) = fromText name <> ": " <> renderGQL value+  renderGQL (ObjectEntry name value) = fromText (unpackName name) <> ": " <> renderGQL value -instance NameCollision (ObjectEntry s) where+instance NameCollision GQLError (ObjectEntry s) where   nameCollision ObjectEntry {entryName} =-    "There can Be only One field Named " <> msgValidation entryName :: ValidationError+    "There can Be only One field Named "+      <> msg entryName  instance KeyOf FieldName (ObjectEntry s) where   keyOf = entryName@@ -211,8 +218,8 @@   renderGQL (Object xs) = "{" <> entries <> "}"     where       entries-        | null (elems xs) = ""-        | otherwise = space <> renderInputSeq (elems xs) <> space+        | null xs = ""+        | otherwise = space <> renderInputSeq (toList xs) <> space   renderGQL (List list) = "[" <> renderInputSeq list <> "]"  instance Msg (Value a) where@@ -222,14 +229,14 @@   toJSON (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) =     A.toJSON x   toJSON (VariableValue Ref {refName}) =-    A.String $ "($ref:" <> readName refName <> ")"+    A.String $ "($ref:" <> unpackName refName <> ")"   toJSON Null = A.Null-  toJSON (Enum (TypeName x)) = A.String x+  toJSON (Enum x) = A.String (unpackName x)   toJSON (Scalar x) = A.toJSON x   toJSON (List x) = A.toJSON x-  toJSON (Object fields) = A.object $ fmap toEntry (elems fields)+  toJSON (Object fields) = A.object $ fmap toEntry (toList fields)     where-      toEntry (ObjectEntry (FieldName name) value) = name A..= A.toJSON value+      toEntry (ObjectEntry name value) = unpackName name A..= A.toJSON value    -------------------------------------------   toEncoding (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) =@@ -240,9 +247,9 @@   toEncoding (Enum x) = A.toEncoding x   toEncoding (Scalar x) = A.toEncoding x   toEncoding (List x) = A.toEncoding x-  toEncoding (Object ordMap) = A.pairs $ renderSeries encodeField (elems ordMap)+  toEncoding (Object ordMap) = A.pairs $ renderSeries encodeField (toList ordMap)     where-      encodeField (ObjectEntry (FieldName key) value) = key A..= value+      encodeField (ObjectEntry key value) = unpackName key A..= value  -- fixes GHC 8.2.2, which can't deduce (Semigroup p) from context (Monoid p) renderSeries :: (Semigroup p, Monoid p) => (e -> p) -> [e] -> p@@ -261,7 +268,7 @@ replaceValue (A.Object v) =   mkObject $     fmap-      (mapTuple FieldName replaceValue)+      (bimap packName replaceValue)       (M.toList v) replaceValue (A.Array li) = List (fmap replaceValue (V.toList li)) replaceValue A.Null = Null

@@ -17,17 +17,12 @@     InputSource (..),     OperationContext (..),     runValidator,-    DirectiveValidator,     askType,     askTypeMember,     selectRequired,     selectKnown,     Constraint (..),     constraint,-    withScope,-    withScopeType,-    withPosition,-    asks,     asksScope,     selectWithDefaultValue,     startInput,@@ -37,54 +32,55 @@     Prop (..),     constraintInputUnion,     ScopeKind (..),-    withDirective,+    setDirective,     inputValueSource,     askVariables,     Scope (..),     MissingRequired (..),     InputContext,-    GetWith,-    SetWith,     Unknown,-    askSchema,     askFragments,-    MonadContext,-    CurrentSelection (..),     getOperationType,     selectType,     FragmentValidator,     askInterfaceTypes,+    askTypeDefinitions,+    withScope,+    setPosition,+    setSelection,+    ValidatorContext (..),   ) where +-- Resolution,++import Control.Monad.Except (throwError) import Data.Morpheus.Internal.Utils-  ( Failure (..),+  ( IsMap,     KeyOf (..),-    Selectable,     member,     selectBy,     selectOr,+    throwErrors,   ) import Data.Morpheus.Types.Internal.AST   ( ANY,     FieldContent (..),     FieldDefinition (..),-    FieldName (..),+    FieldName,     IN,     Position (..),     Ref (..),     TRUE,-    TypeCategory,-    TypeContent (..),-    TypeDefinition (..),-    TypeName (..),-    ValidationError,+    TypeName,     Value (..),     constraintInputUnion,     fromAny,     isNullable,-    msgValidation,+    msg,+    withPath,   )+import Data.Morpheus.Types.Internal.AST.TypeSystem import Data.Morpheus.Types.Internal.Validation.Error   ( KindViolation (..),     MissingRequired (..),@@ -98,63 +94,26 @@     getOperationType,   ) import Data.Morpheus.Types.Internal.Validation.Validator-  ( BaseValidator,-    Constraint (..),-    CurrentSelection (..),-    DirectiveValidator,-    FragmentValidator,-    GetWith (..),-    InputContext,-    InputSource (..),-    InputValidator,-    MonadContext (..),-    OperationContext (..),-    Prop (..),-    -- Resolution,-    Scope (..),-    ScopeKind (..),-    SelectionValidator,-    SetWith (..),-    Validator (..),-    ValidatorContext (..),-    askFragments,-    askSchema,-    askVariables,-    asks,-    asksScope,-    inField,-    inputMessagePrefix,-    inputValueSource,-    runValidator,-    startInput,-    withDirective,-    withPosition,-    withScope,-    withScopeType,-  )-import Relude hiding-  ( Constraint,-    asks,-  )+import Relude hiding (Constraint) -getUnused :: (KeyOf k b, Selectable k a c) => c -> [b] -> [b]-getUnused uses = filter (not . (`member` uses) . keyOf)+getUnused :: (KeyOf k b, IsMap k c, Foldable t) => c a -> t b -> [b]+getUnused uses = filter (not . (`member` uses) . keyOf) . toList -failOnUnused :: Unused ctx b => [b] -> Validator s ctx ()-failOnUnused x-  | null x = pure ()-  | otherwise = do-    ctx <- validatorCTX <$> Validator ask-    failure $ fmap (unused ctx) x+failOnUnused :: Unused a => [a] -> Validator s (OperationContext s1 s2) ()+failOnUnused [] = pure ()+failOnUnused (x : xs) = do+  ctx <- Validator ask+  throwErrors $ (`withPath` path (scope ctx)) . unused (localContext ctx) <$> (x :| xs)  checkUnused ::   ( KeyOf k b,-    Selectable k a ca,-    Unused ctx b+    IsMap k c,+    Unused b,+    Foldable t   ) =>-  ca ->-  [b] ->-  Validator s ctx ()+  c a ->+  t b ->+  Validator s (OperationContext s1 s2) () checkUnused uses = failOnUnused . getUnused uses  constraint ::@@ -167,34 +126,33 @@   pure TypeDefinition {typeContent = DataObject {objectFields, ..}, ..} constraint IMPLEMENTABLE _ TypeDefinition {typeContent = DataInterface fields, ..} =   pure TypeDefinition {typeContent = DataInterface fields, ..}-constraint INPUT ctx x = maybe (failure [kindViolation INPUT ctx]) pure (fromAny x)-constraint target ctx _ = failure [kindViolation target ctx]+constraint INPUT ctx x = maybe (throwError (kindViolation INPUT ctx)) pure (fromAny x)+constraint target ctx _ = throwError (kindViolation target ctx)  selectRequired ::-  ( Selectable FieldName value c,-    MissingRequired c ctx+  ( IsMap FieldName c,+    MissingRequired (c a) ctx   ) =>   Ref FieldName ->-  c ->-  Validator s ctx value+  c a ->+  Validator s ctx a selectRequired selector container =   do-    ValidatorContext {scope, validatorCTX} <- Validator ask+    ValidatorContext {scope, localContext} <- Validator ask     selectBy-      [missingRequired scope validatorCTX selector container]+      (missingRequired scope localContext selector container)       (keyOf selector)       container  selectWithDefaultValue ::-  forall ctx values value s validValue.-  ( Selectable FieldName value values,-    MissingRequired values ctx,-    MonadContext (Validator s) s ctx+  forall ctx c s validValue a.+  ( IsMap FieldName c,+    MissingRequired (c a) ctx   ) =>   (Value s -> Validator s ctx validValue) ->-  (value -> Validator s ctx validValue) ->+  (a -> Validator s ctx validValue) ->   FieldDefinition IN s ->-  values ->+  c a ->   Validator s ctx validValue selectWithDefaultValue   f@@ -220,30 +178,30 @@         | otherwise = failSelection       -----------------       failSelection = do-        ValidatorContext {scope, validatorCTX} <- Validator ask+        ValidatorContext {scope, localContext} <- Validator ask         position <- asksScope position-        failure [missingRequired scope validatorCTX (Ref fieldName (fromMaybe (Position 0 0) position)) values]+        throwError $ missingRequired scope localContext (Ref fieldName (fromMaybe (Position 0 0) position)) values  selectType ::   TypeName ->   Validator s ctx (TypeDefinition ANY s) selectType name =-  askSchema >>= selectBy err name+  asks schema >>= maybe (throwError err) pure . lookupDataType name   where-    err = "Unknown Type " <> msgValidation name <> "." :: ValidationError+    err = "Unknown Type " <> msg name <> "."  selectKnown ::-  ( Selectable k a c,-    Unknown c sel ctx,+  ( IsMap k c,+    Unknown sel ctx,     KeyOf k sel   ) =>   sel ->-  c ->+  c a ->   Validator s ctx a selectKnown selector lib =   do-    ValidatorContext {scope, validatorCTX} <- Validator ask+    ValidatorContext {scope, localContext} <- Validator ask     selectBy-      (unknown scope validatorCTX lib selector)+      (unknown scope localContext selector)       (keyOf selector)       lib

@@ -19,36 +19,29 @@ import Data.Morpheus.Types.Internal.AST   ( Argument (..),     Arguments,-    CONST,     Directive (..),-    DirectiveDefinition (..),-    DirectiveDefinitions,-    FieldDefinition (..),     FieldName,-    FieldsDefinition,     Fragment (..),-    Fragments,+    FragmentName,+    GQLError,     IMPLEMENTABLE,     IN,-    OUT,     Object,     ObjectEntry (..),     Ref (..),-    Schema,     TypeCategory,     TypeName,     TypeRef (..),-    ValidationError (..),     Variable (..),     VariableDefinitions,+    at,+    atPositions,     getOperationName,     msg,-    msgValidation,-    withPosition,+    withPath,   ) import Data.Morpheus.Types.Internal.Validation.Validator-  ( CurrentSelection (..),-    InputContext (..),+  ( InputContext (..),     OperationContext (..),     Scope (..),     ScopeKind (..),@@ -56,154 +49,148 @@   ) import Relude -class Unused ctx c where-  unused :: ctx -> c -> ValidationError+class Unused c where+  unused :: OperationContext s1 s2 -> c -> GQLError  -- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".",-instance Unused (OperationContext s1 s2) (Variable s) where+instance Unused (Variable s) where   unused-    OperationContext {selection = CurrentSelection {operationName}}+    OperationContext {operationName}     Variable {variableName, variablePosition} =-      ValidationError-        { validationMessage =-            "Variable " <> msg ("$" <> variableName)-              <> " is never used in operation "-              <> msg (getOperationName operationName)-              <> ".",-          validationLocations = [variablePosition]-        }+      ( "Variable " <> msg ("$" <> variableName)+          <> " is never used in operation "+          <> msg (getOperationName operationName)+          <> "."+      )+        `at` variablePosition -instance Unused (OperationContext s1 s2) (Fragment s) where+instance Unused (Fragment s) where   unused     _     Fragment {fragmentName, fragmentPosition} =-      ValidationError-        { validationMessage =-            "Fragment " <> msg fragmentName-              <> " is never used.",-          validationLocations = [fragmentPosition]-        }+      ( "Fragment " <> msg fragmentName+          <> " is never used."+      )+        `at` fragmentPosition  class MissingRequired c ctx where-  missingRequired :: Scope -> ctx -> Ref FieldName -> c -> ValidationError+  missingRequired :: Scope -> ctx -> Ref FieldName -> c -> GQLError  instance MissingRequired (Arguments s) ctx where   missingRequired-    Scope {position, kind, fieldname}+    Scope {position, kind, fieldName, path}     _     Ref {refName}     _ =-      ValidationError-        { validationMessage =-            inScope kind-              <> " argument "-              <> msg refName-              <> " is required but not provided.",-          validationLocations = maybeToList position-        }+      ( ( inScope kind+            <> " argument "+            <> msg refName+            <> " is required but not provided."+        )+          `atPositions` position+      )+        `withPath` path       where-        inScope DIRECTIVE = "Directive " <> msg ("@" <> fieldname)-        inScope _ = "Field " <> msg fieldname+        inScope DIRECTIVE = "Directive " <> msg fieldName+        inScope _ = "Field " <> msg fieldName  instance MissingRequired (Object s) (InputContext ctx) where   missingRequired-    Scope {position}+    Scope {position, path}     ctx     Ref {refName}     _ =-      withPosition-        position-        ( renderInputPrefix+      ( ( renderInputPrefix             ctx             <> "Undefined Field "-            <> msgValidation refName+            <> msg refName             <> "."         )+          `atPositions` position+      )+        `withPath` path  instance MissingRequired (VariableDefinitions s) (OperationContext s1 s2) where   missingRequired-    _+    Scope {path}     OperationContext-      { selection = CurrentSelection {operationName}+      { operationName       }     Ref {refName, refPosition}     _ =-      ValidationError-        { validationMessage =-            "Variable "-              <> msg refName-              <> " is not defined by operation "-              <> msg (getOperationName operationName)-              <> ".",-          validationLocations = [refPosition]-        }+      ( ( "Variable "+            <> msg refName+            <> " is not defined by operation "+            <> msg (getOperationName operationName)+            <> "."+        )+          `at` refPosition+      )+        `withPath` path -class Unknown c ref ctx where-  -- type UnknownSelector c-  unknown :: Scope -> ctx -> c -> ref -> ValidationError+class Unknown ref ctx where+  unknown :: Scope -> ctx -> ref -> GQLError  -- {...H} -> "Unknown fragment \"H\"."-instance Unknown (Fragments s) (Ref FieldName) ctx where-  unknown _ _ _ Ref {refName, refPosition} =-    ValidationError-      { validationMessage = "Unknown Fragment " <> msg refName <> ".",-        validationLocations = [refPosition]-      }+instance Unknown (Ref FragmentName) ctx where+  unknown Scope {path} _ Ref {refName, refPosition} =+    (("Unknown Fragment " <> msg refName <> ".") `at` refPosition) `withPath` path -instance Unknown (Schema s) (Ref TypeName) ctx where-  unknown _ _ _ Ref {refName, refPosition} =-    ValidationError-      { validationMessage = "Unknown type " <> msg refName <> ".",-        validationLocations = [refPosition]-      }+instance Unknown (Ref TypeName) ctx where+  unknown Scope {path} _ Ref {refName, refPosition} =+    (("Unknown type " <> msg refName <> ".") `at` refPosition) `withPath` path -instance Unknown (FieldDefinition OUT s) (Argument CONST) ctx where-  unknown _ _ FieldDefinition {fieldName} Argument {argumentName, argumentPosition} =-    ValidationError-      { validationMessage = "Unknown Argument " <> msg argumentName <> " on Field " <> msg fieldName <> ".",-        validationLocations = [argumentPosition]-      }+instance Unknown (Argument s') ctx where+  unknown Scope {kind, path, fieldName} _ Argument {argumentName, argumentPosition} =+    ( ( "Unknown Argument "+          <> msg argumentName+          <> " on "+          <> scope kind+          <> " "+          <> msg fieldName+          <> "."+      )+        `at` argumentPosition+    )+      `withPath` path+    where+      scope DIRECTIVE = "Directive"+      scope _ = "Field" -instance Unknown (FieldsDefinition IN s) (ObjectEntry valueS) (InputContext ctx) where+instance Unknown (Ref FieldName) ctx where+  unknown Scope {currentTypeName, path} _ ref =+    unknownSelectionField currentTypeName ref `withPath` path++instance Unknown (ObjectEntry valueS) (InputContext ctx) where   unknown-    Scope {position}+    Scope {position, path}     ctx-    _     ObjectEntry {entryName} =-      withPosition position $-        renderInputPrefix ctx <> "Unknown Field " <> msgValidation entryName <> "."--instance Unknown (DirectiveDefinition s) (Argument s') ctx where-  unknown _ _ DirectiveDefinition {directiveDefinitionName} Argument {argumentName, argumentPosition} =-    ValidationError-      { validationMessage = "Unknown Argument " <> msg argumentName <> " on Directive " <> msg directiveDefinitionName <> ".",-        validationLocations = [argumentPosition]-      }--instance Unknown (DirectiveDefinitions s) (Directive s') ctx where-  unknown _ _ _ Directive {directiveName, directivePosition} =-    ValidationError-      { validationMessage = "Unknown Directive " <> msg directiveName <> ".",-        validationLocations = [directivePosition]-      }+      ( ( renderInputPrefix ctx+            <> "Unknown Field "+            <> msg entryName+            <> "."+        )+          `atPositions` position+      )+        `withPath` path -instance Unknown (FieldsDefinition OUT s) (Ref FieldName) (OperationContext s1 s2) where-  unknown Scope {currentTypeName} _ _ = unknownSelectionField currentTypeName+instance Unknown (Directive s') ctx where+  unknown Scope {path} _ Directive {directiveName, directivePosition} =+    (("Unknown Directive " <> msg directiveName <> ".") `at` directivePosition) `withPath` path  class KindViolation (t :: TypeCategory) ctx where-  kindViolation :: c t -> ctx -> ValidationError+  kindViolation :: c t -> ctx -> GQLError  instance KindViolation IMPLEMENTABLE (Fragment s) where   kindViolation _ Fragment {fragmentName, fragmentType, fragmentPosition} =-    ValidationError-      { validationMessage =-          "Fragment "-            <> msg fragmentName-            <> " cannot condition on non composite type "-            <> msg fragmentType-            <> ".",-        validationLocations = [fragmentPosition]-      }+    ( "Fragment "+        <> msg fragmentName+        <> " cannot condition on non composite type "+        <> msg fragmentType+        <> "."+    )+      `at` fragmentPosition  instance KindViolation IN (Variable s) where   kindViolation@@ -213,12 +200,10 @@         variablePosition,         variableType = TypeRef {typeConName}       } =-      ValidationError-        { validationMessage =-            "Variable "-              <> msg ("$" <> variableName)-              <> " cannot be non-input type "-              <> msg typeConName-              <> ".",-          validationLocations = [variablePosition]-        }+      ( "Variable "+          <> msg ("$" <> variableName)+          <> " cannot be non-input type "+          <> msg typeConName+          <> "."+      )+        `at` variablePosition