morpheus-graphql-core 0.14.1 → 0.15.0

raw patch · 55 files changed

+1272/−508 lines, 55 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +2/−2
• changelog.md +51/−6
• morpheus-graphql-core.cabal +22/−3
• src/Data/Morpheus/Core.hs +16/−61
• src/Data/Morpheus/Error.hs +2/−0
• src/Data/Morpheus/Internal/TH.hs +12/−10
• src/Data/Morpheus/Internal/Utils.hs +137/−67
• src/Data/Morpheus/Parsing/Document/TypeSystem.hs +1/−1
• src/Data/Morpheus/Parsing/Internal/Terms.hs +6/−6
• src/Data/Morpheus/Parsing/Request/Parser.hs +4/−4
• src/Data/Morpheus/Rendering/RenderGQL.hs +7/−0
• src/Data/Morpheus/Types/App.hs +170/−0
• src/Data/Morpheus/Types/GQLScalar.hs +1/−2
• src/Data/Morpheus/Types/Internal/AST.hs +6/−7
• src/Data/Morpheus/Types/Internal/AST/Base.hs +10/−7
• src/Data/Morpheus/Types/Internal/AST/Fields.hs +19/−16
• src/Data/Morpheus/Types/Internal/AST/MergeSet.hs +12/−30
• src/Data/Morpheus/Types/Internal/AST/SafeHashMap.hs +5/−0
• src/Data/Morpheus/Types/Internal/AST/Selection.hs +8/−8
• src/Data/Morpheus/Types/Internal/AST/TypeCategory.hs +2/−2
• src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs +35/−44
• src/Data/Morpheus/Types/Internal/AST/Value.hs +4/−1
• src/Data/Morpheus/Types/Internal/Resolving.hs +6/−7
• src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +41/−18
• src/Data/Morpheus/Types/Internal/Stitching.hs +147/−0
• src/Data/Morpheus/Types/Internal/Validation.hs +9/−9
• src/Data/Morpheus/Validation/Query/UnionSelection.hs +26/−3
• test/Lib.hs +0/−177
• test/Spec.hs +3/−0
• test/Utils/Api.hs +9/−8
• test/Utils/MergeSchema.hs +130/−0
• test/Utils/Schema.hs +3/−3
• test/Utils/Utils.hs +181/−0
• test/api/validation/fragment/on-interface-inline/response.json +12/−3
• test/api/validation/fragment/on-interface-type-casting-inline/response.json +3/−0
• test/api/validation/fragment/on-interface-type-casting/response.json +3/−0
• test/api/validation/fragment/on-interface/response.json +12/−3
• test/merge/schema/query-subscription-mutation/api/app.gql +7/−0
• test/merge/schema/query-subscription-mutation/api/app.json +8/−0
• test/merge/schema/query-subscription-mutation/api/ext.gql +12/−0
• test/merge/schema/query-subscription-mutation/api/ext.json +9/−0
• test/merge/schema/query-subscription-mutation/expected/ok.gql +13/−0
• test/merge/schema/query-subscription-mutation/request/mutation/query.gql +4/−0
• test/merge/schema/query-subscription-mutation/request/mutation/response.json +6/−0
• test/merge/schema/query-subscription-mutation/request/query/query.gql +4/−0
• test/merge/schema/query-subscription-mutation/request/query/response.json +6/−0
• test/merge/schema/simple-query/api/app.gql +12/−0
• test/merge/schema/simple-query/api/app.json +8/−0
• test/merge/schema/simple-query/api/ext.gql +9/−0
• test/merge/schema/simple-query/api/ext.json +9/−0
• test/merge/schema/simple-query/expected/ok.gql +14/−0
• test/merge/schema/simple-query/request/query/query.gql +8/−0
• test/merge/schema/simple-query/request/query/response.json +10/−0
• test/schema/parsing/schema-definition/fail/dupplicate-field/query-mutation-subscription/response.json +12/−0
• test/schema/parsing/schema-definition/fail/dupplicate-field/query/response.json +4/−0

@@ -43,6 +43,6 @@         ("power", pure $ mkList [mkString "Shapeshifting"])       ] -api :: GQLRequest -> ResponseStream e Identity (Value VALID)-api = runApi schema resolver+api :: ByteString -> IO  ByteString+api = runApp (mkApp schema resolver) ```

@@ -1,5 +1,49 @@ # Changelog +## 0.15.0 - 12.09.2020++### new features++- `render` renders SchemaDefinition e.g++  ```graphql+  schema {+    query: MyQuery+  }+  ```++- query validator automatically adds `__typename` to interface types++- type : `App`++  ```hs+  api :: a -> m b+  api = runApp (mkApp schema resolvers)+  ```++- `App` supports semigroup(`schema Stitching`):++  if whe have two apps `app1` and `app2` with type `Api EVENT IO` we can merge it as.++  ```hs+  mergedApi :: a -> m b+  mergedApi = runApp (app1 <> app2)+  ```++- `runApp` changed signature to:++  ```hs+  runApp :: Api e m -> a -> m b+  ```++### Breaking Changes++- removed `runApi`.++### Minor Changes++- internal refactoring+ ## 0.14.1 - 16.08.2020  ## 0.14.0 - 15.08.2020@@ -14,12 +58,12 @@   - `defaultConfig`   - `debugConfig` -- for better debuging, internal errors messages will display resolving state:+- for better debugging, internal errors messages will display resolving state:   - `current TypeName`   - `current Selection`   - `OperationDefinition`   - `SchemaDefinition`-- rendering graphql "AST". e.g `render ( slection :: Selection VALID)` will render+- rendering graphql "AST". e.g `render (selection :: Selection VALID)` will render  ```graphql {@@ -29,7 +73,7 @@ } ``` -- quasiqouter `[dsl| <type definitions> |]` generates `Schema VALID`.+- quasiquoter `[dsl| <type definitions> |]` generates `Schema VALID`. - parser supports custom directive definition. e.g  ```graphql@@ -43,9 +87,9 @@   query {     createDeity(       name: """-      powerqwe+      power       bla \n sd-      blu \\ dete+      blu \\ date       """     ) {       name@@ -72,6 +116,7 @@   - `FieldDefinition IN VALID`   - ... - runApi requires argument config+   ```hs     runApi ::       Schema s ->@@ -100,7 +145,7 @@  ## New features -- parser supports implemnets interfaces seperated with empty spaces+- parser supports implements interfaces separated with empty spaces    ```gql   type T implements A , B C & D {

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: db805940089c68c82bd542e86200950c50069afe4b4d412a9bca5a4ee8f6f8ce+-- hash: 7aaaf3d4b4dab94a5938e6284d262fadabee300b225a623e93fa0d703192a48f  name:           morpheus-graphql-core-version:        0.14.1+version:        0.15.0 synopsis:       Morpheus GraphQL Core description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -35,6 +35,15 @@     test/api/validation/fragment/on-type/query.gql     test/api/validation/fragment/on-union-type/query.gql     test/api/validation/fragment/schema.gql+    test/merge/schema/query-subscription-mutation/api/app.gql+    test/merge/schema/query-subscription-mutation/api/ext.gql+    test/merge/schema/query-subscription-mutation/expected/ok.gql+    test/merge/schema/query-subscription-mutation/request/mutation/query.gql+    test/merge/schema/query-subscription-mutation/request/query/query.gql+    test/merge/schema/simple-query/api/app.gql+    test/merge/schema/simple-query/api/ext.gql+    test/merge/schema/simple-query/expected/ok.gql+    test/merge/schema/simple-query/request/query/query.gql     test/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@@ -84,6 +93,13 @@     test/api/validation/fragment/on-type/response.json     test/api/validation/fragment/on-union-type/response.json     test/api/validation/fragment/resolvers.json+    test/merge/schema/query-subscription-mutation/api/app.json+    test/merge/schema/query-subscription-mutation/api/ext.json+    test/merge/schema/query-subscription-mutation/request/mutation/response.json+    test/merge/schema/query-subscription-mutation/request/query/response.json+    test/merge/schema/simple-query/api/app.json+    test/merge/schema/simple-query/api/ext.json+    test/merge/schema/simple-query/request/query/response.json     test/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@@ -166,6 +182,7 @@       Data.Morpheus.Schema.DSL       Data.Morpheus.Schema.Schema       Data.Morpheus.Schema.SchemaAPI+      Data.Morpheus.Types.App       Data.Morpheus.Types.Internal.AST.Base       Data.Morpheus.Types.Internal.AST.DirectiveLocation       Data.Morpheus.Types.Internal.AST.Fields@@ -183,6 +200,7 @@       Data.Morpheus.Types.Internal.Resolving.Event       Data.Morpheus.Types.Internal.Resolving.Resolver       Data.Morpheus.Types.Internal.Resolving.ResolverState+      Data.Morpheus.Types.Internal.Stitching       Data.Morpheus.Types.Internal.Validation       Data.Morpheus.Types.Internal.Validation.Error       Data.Morpheus.Types.Internal.Validation.Internal@@ -222,9 +240,10 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:-      Lib       Utils.Api+      Utils.MergeSchema       Utils.Schema+      Utils.Utils       Paths_morpheus_graphql_core   hs-source-dirs:       test

@@ -2,14 +2,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}  module Data.Morpheus.Core-  ( runApi,-    parseDSL,+  ( parseDSL,     parseFullGQLDocument,     parseGQLDocument,     parseTypeSystemDefinition,@@ -24,6 +22,12 @@     VALIDATION_MODE (..),     defaultConfig,     debugConfig,+    App (..),+    AppData (..),+    runApp,+    withDebugger,+    mkApp,+    runAppStream,   ) where @@ -34,7 +38,6 @@   ) import Data.Morpheus.Internal.Utils   ( (<:>),-    empty,   ) import Data.Morpheus.Parser   ( parseRequest,@@ -46,17 +49,17 @@   ( RenderGQL (..),   ) import Data.Morpheus.Schema.Schema (internalSchema)-import Data.Morpheus.Schema.SchemaAPI (withSystemFields)-import Data.Morpheus.Types.IO-  ( GQLRequest (..),+import Data.Morpheus.Types.App+  ( App (..),+    AppData (..),+    mkApp,+    runApp,+    runAppStream,+    withDebugger,   ) import Data.Morpheus.Types.Internal.AST-  ( Operation (..),-    Schema (..),-    Selection (..),-    SelectionContent (..),+  ( Schema,     VALID,-    Value,   ) import Data.Morpheus.Types.Internal.Config   ( Config (..),@@ -66,13 +69,7 @@   ) import Data.Morpheus.Types.Internal.Resolving   ( Eventless,-    ResolverContext (..),-    ResponseStream,-    ResultT (..),-    RootResModel,-    cleanEvents,     resultOr,-    runRootResModel,   ) import Data.Morpheus.Types.SelectionTree (SelectionTree (..)) import Data.Morpheus.Validation.Document.Validation (ValidateSchema (..))@@ -83,48 +80,6 @@   ( toStrict,   ) import Data.Text.Lazy.Encoding (decodeUtf8)--runApi ::-  forall event m s.-  (Monad m, ValidateSchema s) =>-  Schema s ->-  RootResModel event m ->-  Config ->-  GQLRequest ->-  ResponseStream event m (Value VALID)-runApi inputSchema resModel config request = do-  validRequest <- validateReq inputSchema config request-  resovers <- withSystemFields (schema validRequest) resModel-  runRootResModel resovers validRequest--validateReq ::-  ( Monad m,-    ValidateSchema s-  ) =>-  Schema s ->-  Config ->-  GQLRequest ->-  ResponseStream event m ResolverContext-validateReq inputSchema config request = cleanEvents $ ResultT $ pure $ do-  validSchema <- validateSchema True config inputSchema-  schema <- internalSchema <:> validSchema-  operation <- parseRequestWith config schema request-  pure $-    ResolverContext-      { schema,-        config,-        operation,-        currentTypeName = "Root",-        currentSelection =-          Selection-            { selectionName = "Root",-              selectionArguments = empty,-              selectionPosition = operationPosition operation,-              selectionAlias = Nothing,-              selectionContent = SelectionSet (operationSelection operation),-              selectionDirectives = []-            }-      }  parseDSL :: ByteString -> Either String (Schema VALID) parseDSL = resultOr (Left . show) pure . parseGQLDocument

@@ -4,9 +4,11 @@     gqlWarnings,     renderGQLErrors,     deprecatedField,+    nameCollisionError,   ) where +import Data.Morpheus.Error.Schema import Data.Morpheus.Error.Utils import Data.Morpheus.Error.Warning   ( deprecatedField,

@@ -25,7 +25,6 @@     infoTyVars,     isEnum,     m',-    m_,     mkFieldsE,     nameSpaceField,     nameSpaceType,@@ -55,7 +54,8 @@ import Data.Functor ((<$>)) import Data.Maybe (Maybe (..)) import Data.Morpheus.Internal.Utils-  ( nameSpaceField,+  ( capitalize,+    nameSpaceField,     nameSpaceType,   ) import Data.Morpheus.Types.Internal.AST@@ -79,6 +79,7 @@     (.),     (==),     Bool (..),+    String,     id,     map,     otherwise,@@ -86,9 +87,6 @@     (||),   ) -m_ :: TypeName-m_ = "m"- m' :: Type m' = VarT (mkName "m") @@ -120,12 +118,13 @@     wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs     wrappedT [] = decType typeArgs     ---------------------------------------------    decType (Just par) = apply typeConName [toVar par]-    decType _ = toCon typeConName+    decType :: Maybe String -> Type+    decType (Just par) = apply (capitalize typeConName) [toVar par]+    decType _ = toCon (capitalize typeConName) -tyConArgs :: TypeKind -> [TypeName]+tyConArgs :: TypeKind -> [String] tyConArgs kindD-  | isOutputObject kindD || kindD == KindUnion = [m_]+  | isOutputObject kindD || kindD == KindUnion = ["m"]   | otherwise = []  cons :: ToCon a b => [a] -> [b]@@ -137,11 +136,14 @@ 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 . readTypeName+  toName = mkName . unpack . capitalize . readTypeName  instance ToName FieldName where   toName = mkName . unpack . readName . convertToHaskellName

@@ -1,12 +1,16 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Internal.Utils-  ( capital,-    nonCapital,+  ( capitalize,     nameSpaceField,     nameSpaceType,     capitalTypeName,@@ -34,12 +38,21 @@     traverseCollection,     (<.>),     SemigroupM (..),+    fromListT,+    mergeT,+    runResolutionT,+    ResolutionT,+    prop,+    resolveWith,+    stripFieldNamespace,+    stripConstructorNamespace,   ) where  import Control.Applicative (Applicative (..))-import Control.Monad ((=<<), foldM)-import Control.Monad.Trans.Class (lift)+import Control.Monad ((=<<), (>=>), (>>=), foldM)+import Control.Monad.Reader (MonadReader (..), asks)+import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Reader   ( ReaderT (..),   )@@ -47,35 +60,28 @@   ( toLower,     toUpper,   )-import Data.Foldable (null, traverse_)+import Data.Foldable (foldlM, null, traverse_) import Data.Function ((&)) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HM import Data.Hashable (Hashable)-import Data.List (find)-import Data.Maybe (isJust, maybe)+import Data.List (drop, find)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (maybe) import Data.Morpheus.Error.NameCollision (NameCollision (..)) import Data.Morpheus.Types.Internal.AST.Base   ( FieldName,     FieldName (..),-    GQLErrors,     Ref (..),     Token,     TypeName (..),     TypeNameRef (..),     ValidationErrors,-    toGQLError,   ) import Data.Semigroup (Semigroup (..)) import qualified Data.Text as T-  ( concat,-    pack,-    unpack,-  ) import Data.Traversable (traverse) import Instances.TH.Lift ()-import Text.Megaparsec.Internal (ParsecT (..))-import Text.Megaparsec.Stream (Stream) import Prelude   ( ($),     (.),@@ -85,7 +91,6 @@     Functor (..),     Int,     Monad,-    Ord,     String,     const,     fst,@@ -94,29 +99,50 @@     snd,   ) -mapText :: (String -> String) -> Token -> Token-mapText f = T.pack . f . T.unpack+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 capital (fmap readName list <> [name])+nameSpaceType list (TypeName name) = TypeName . T.concat $ fmap capitalize (fmap readName list <> [name])  nameSpaceField :: TypeName -> FieldName -> FieldName-nameSpaceField nSpace (FieldName name) = FieldName (nonCapital nSpace <> capital name)+nameSpaceField nSpace (FieldName name) = FieldName (nonCapital nSpace <> capitalize name) +dropPrefix :: TypeName -> String -> String+dropPrefix (TypeName name) = drop (length (T.unpack name))++stripConstructorNamespace :: TypeName -> String -> String+stripConstructorNamespace = dropPrefix++stripFieldNamespace :: TypeName -> String -> String+stripFieldNamespace prefix = uncapitalize . dropPrefix prefix++mapText :: (String -> String) -> Token -> Token+mapText f = T.pack . f . T.unpack+ nonCapital :: TypeName -> Token-nonCapital = mapText __nonCapital . readTypeName-  where-    __nonCapital [] = []-    __nonCapital (x : xs) = toLower x : xs+nonCapital = uncapitalize . readTypeName -capital :: Token -> Token-capital = mapText __capital-  where-    __capital [] = []-    __capital (x : xs) = toUpper x : xs+class Capitalize a where+  capitalize :: a -> a+  uncapitalize :: a -> a +instance Capitalize String where+  capitalize [] = []+  capitalize (x : xs) = toUpper x : xs+  uncapitalize [] = []+  uncapitalize (x : xs) = toLower x : xs++instance Capitalize Token where+  capitalize = mapText capitalize+  uncapitalize = mapText uncapitalize++instance Capitalize TypeName where+  capitalize = TypeName . capitalize . readTypeName+  uncapitalize = TypeName . uncapitalize . readTypeName+ capitalTypeName :: FieldName -> TypeName-capitalTypeName = TypeName . capital . readName+capitalTypeName = TypeName . capitalize . readName  --(KEY v ~ k) => class Collection a coll | coll -> a where@@ -203,7 +229,7 @@   fromElems :: (Monad m, Failure ValidationErrors m) => [a] -> m coll  instance (NameCollision a, KeyOf k a) => Listable a (HashMap k a) where-  fromElems = safeFromList+  fromElems xs = runResolutionT (fromListT xs) hmUnsafeFromValues failOnDuplicates   elems = HM.elems  keys :: (KeyOf k a, Listable a coll) => coll -> [k]@@ -217,7 +243,7 @@   merge :: (Monad m, Failure ValidationErrors m) => [Ref] -> a -> a -> m a  instance (NameCollision a, KeyOf k a) => Merge (HashMap k a) where-  merge _ = safeJoin+  merge _ x y = runResolutionT (fromListT $ HM.elems x <> HM.elems y) hmUnsafeFromValues failOnDuplicates  (<:>) :: (Monad m, Merge a, Failure ValidationErrors m) => a -> a -> m a (<:>) = merge []@@ -232,7 +258,7 @@   m a (<.>) = mergeM [] --- Failure: for custome Morpheus GrapHQL errors+-- Failure: for custom Morpheus GrapHQL errors class Applicative f => Failure error (f :: * -> *) where   failure :: error -> f v @@ -242,9 +268,6 @@ instance (Monad m, Failure errors m) => Failure errors (ReaderT ctx m) where   failure = lift . failure -instance (Stream s, Ord e, Failure GQLErrors m) => Failure ValidationErrors (ParsecT e s m) where-  failure x = ParsecT $ \_ _ _ _ _ -> failure (fmap toGQLError x)- mapFst :: (a -> a') -> (a, b) -> (a', b) mapFst f (a, b) = (f a, b) @@ -266,40 +289,87 @@ resolveUpdates :: Monad m => a -> [UpdateT m a] -> m a resolveUpdates a = foldM (&) a . fmap updateTState -safeFromList ::-  ( Failure ValidationErrors m,-    Applicative m,-    NameCollision a,-    Eq k,-    Hashable k,-    KeyOf k a+type RESOLUTION k a coll m =+  ( Monad m,+    KeyOf k a,+    Listable a coll+  )++data Resolution a coll m = Resolution+  { resolveDuplicates :: NonEmpty a -> m a,+    fromNoDuplicates :: [a] -> coll+  }++runResolutionT ::+  ResolutionT a coll m b ->+  ([a] -> coll) ->+  (NonEmpty a -> m a) ->+  m b+runResolutionT (ResolutionT x) fromNoDuplicates resolveDuplicates = runReaderT x Resolution {..}++newtype ResolutionT a coll m x = ResolutionT+  { _runResolutionT :: ReaderT (Resolution a coll m) m x+  }+  deriving+    ( Functor,+      Monad,+      Applicative,+      MonadReader (Resolution a coll m)+    )++instance MonadTrans (ResolutionT e coll) where+  lift = ResolutionT . lift++instance+  ( Monad m,+    Failure ValidationErrors m   ) =>+  Failure ValidationErrors (ResolutionT a coll m)+  where+  failure = lift . failure++resolveDuplicatesM :: Monad m => NonEmpty a -> ResolutionT a coll m a+resolveDuplicatesM xs = asks resolveDuplicates >>= lift . (xs &)++fromNoDuplicatesM :: Monad m => [a] -> ResolutionT a coll m coll+fromNoDuplicatesM xs = asks ((xs &) . fromNoDuplicates)++insertWithList :: (Eq k, Hashable k) => (k, NonEmpty a) -> [(k, NonEmpty a)] -> [(k, NonEmpty a)]+insertWithList (key, value) values+  | key `member` values = fmap replaceBy values+  | otherwise = values <> [(key, value)]+  where+    replaceBy (entryKey, entryValue)+      | key == entryKey = (key, entryValue <> value)+      | otherwise = (entryKey, entryValue)++clusterDuplicates :: (Eq k, Hashable k) => [(k, NonEmpty a)] -> [(k, a)] -> [(k, NonEmpty a)]+clusterDuplicates collected [] = collected+clusterDuplicates coll ((key, value) : xs) = clusterDuplicates (insertWithList (key, value :| []) coll) xs++fromListDuplicates :: (KeyOf k a) => [a] -> [(k, NonEmpty a)]+fromListDuplicates xs = clusterDuplicates [] (fmap toPair xs)++fromListT ::+  RESOLUTION k a coll m =>   [a] ->-  m (HashMap k a)-safeFromList values = safeUnionWith HM.empty (fmap toPair values)+  ResolutionT a coll m coll+fromListT = traverse (resolveDuplicatesM . snd) . fromListDuplicates >=> fromNoDuplicatesM -safeJoin :: (Failure ValidationErrors m, Eq k, Hashable k, Applicative m, NameCollision a) => HashMap k a -> HashMap k a -> m (HashMap k a)-safeJoin hm newls = safeUnionWith hm (HM.toList newls)+mergeT :: RESOLUTION k a coll m => coll -> coll -> ResolutionT a coll m coll+mergeT c1 c2 = traverse (resolveDuplicatesM . snd) (fromListDuplicates (elems c1 <> elems c2)) >>= fromNoDuplicatesM -safeUnionWith ::-  ( Failure ValidationErrors m,-    Applicative m,-    Eq k,-    Hashable k,-    NameCollision a-  ) =>-  HashMap k a ->-  [(k, a)] ->-  m (HashMap k a)-safeUnionWith hm names = case insertNoDups (hm, []) names of-  (res, dupps)-    | null dupps -> pure res-    | otherwise -> failure $ fmap (nameCollision . snd) dupps+resolveWith ::+  Monad m =>+  (a -> a -> m a) ->+  NonEmpty a ->+  m a+resolveWith f (x :| xs) = foldlM f x xs -type NoDupHashMap k a = (HashMap k a, [(k, a)])+hmUnsafeFromValues :: (Eq k, KeyOf k a) => [a] -> HashMap k a+hmUnsafeFromValues = HM.fromList . fmap toPair -insertNoDups :: (Eq k, Hashable k) => NoDupHashMap k a -> [(k, a)] -> NoDupHashMap k a-insertNoDups collected [] = collected-insertNoDups (coll, errors) (pair@(name, value) : xs)-  | isJust (name `HM.lookup` coll) = insertNoDups (coll, errors <> [pair]) xs-  | otherwise = insertNoDups (HM.insert name value coll, errors) xs+failOnDuplicates :: (Failure ValidationErrors m, NameCollision a) => NonEmpty a -> m a+failOnDuplicates (x :| xs)+  | null xs = pure x+  | otherwise = failure $ fmap nameCollision (x : xs)

@@ -270,7 +270,7 @@ -- 3.2 Schema -- SchemaDefinition: --    schema Directives[Const,opt]---      { RootOperationTypeDefinitionlist }+--      { RootOperationTypeDefinition(list) } -- --  RootOperationTypeDefinition: --    OperationType: NamedType

@@ -32,9 +32,9 @@ where  import Control.Monad ((>=>))-import Data.Functor (($>)) -- MORPHEUS-+import Control.Monad.Trans (lift)+import Data.Functor (($>)) import Data.Morpheus.Internal.Utils   ( Collection,     KeyOf,@@ -241,7 +241,7 @@ collection entry = braces (entry `sepEndBy` ignoredTokens)  setOf :: (Listable a coll, KeyOf k a) => Parser a -> Parser coll-setOf = collection >=> fromElems+setOf = collection >=> lift . fromElems  optionalCollection :: Collection a c => Parser c -> Parser c optionalCollection x = x <|> pure empty@@ -259,7 +259,7 @@       (char '(' *> ignoredTokens)       (char ')' *> ignoredTokens)       (parser `sepBy` ignoredTokens <?> "empty Tuple value!")-      >>= fromElems+      >>= lift . fromElems  uniqTupleOpt :: (Listable a coll, Collection a coll, KeyOf k a) => Parser a -> Parser coll uniqTupleOpt x = uniqTuple x <|> pure empty@@ -319,7 +319,7 @@         (char '[' *> ignoredTokens)         (char ']' *> ignoredTokens)         ( do-            (wrappers, tname) <- unwrapped <|> wrapped+            (wrappers, tName) <- unwrapped <|> wrapped             nonNull' <- parseNonNull-            return ((ListType : nonNull') ++ wrappers, tname)+            return ((ListType : nonNull') ++ wrappers, tName)         )

@@ -3,13 +3,13 @@  module Data.Morpheus.Parsing.Request.Parser (parseGQL) where +--+-- MORPHEUS+import Control.Monad.Trans (lift) import qualified Data.Aeson as Aeson   ( Value (..),   ) import Data.HashMap.Lazy (toList)------ MORPHEUS- import Data.Morpheus.Internal.Utils   ( fromElems,   )@@ -46,7 +46,7 @@ request = label "GQLQuery" $ do   ignoredTokens   operation <- parseOperation-  fragments <- manyTill parseFragmentDefinition eof >>= fromElems+  fragments <- manyTill parseFragmentDefinition eof >>= lift . fromElems   pure GQLQuery {operation, fragments, inputVariables = []}  parseGQL :: GQLRequest -> Eventless GQLQuery

@@ -16,6 +16,7 @@  -- MORPHEUS +import qualified Data.Aeson as A import Data.Foldable (null) import Data.Functor ((<$>)) import Data.Maybe (Maybe, maybe)@@ -25,8 +26,11 @@     intercalate,     pack,   )+import Data.Text.Encoding (decodeUtf8)+import Data.ByteString.Lazy (toStrict) import Prelude   ( (.),+    ($),     Bool (..),     Float,     Int,@@ -58,6 +62,9 @@ instance RenderGQL Bool where   render True = "true"   render False = "false"++instance RenderGQL A.Value where+  render x = decodeUtf8 $ toStrict $ A.encode x  indent :: Rendering indent = "  "

@@ -0,0 +1,170 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.App+  ( App (..),+    AppData (..),+    withDebugger,+    mkApp,+    runApp,+    runAppStream,+  )+where++import Control.Applicative (Applicative (..))+import Control.Monad (Monad)+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Functor ((<$>), Functor (..))+import Data.Morpheus.Internal.Utils+  ( (<:>),+    empty,+    failure,+    prop,+  )+import Data.Morpheus.Parser+  ( parseRequestWith,+  )+import Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+  )+import Data.Morpheus.Schema.Schema (internalSchema)+import Data.Morpheus.Schema.SchemaAPI (withSystemFields)+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+    GQLResponse,+    MapAPI (..),+    renderResponse,+  )+import Data.Morpheus.Types.Internal.AST+  ( GQLErrors,+    Operation (..),+    Schema (..),+    Schema (..),+    Selection (..),+    SelectionContent (..),+    VALID,+    Value,+  )+import Data.Morpheus.Types.Internal.Config+  ( Config (..),+    defaultConfig,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( ResolverContext (..),+    ResponseStream,+    ResultT (..),+    RootResModel,+    cleanEvents,+    resultOr,+    runRootResModel,+  )+import Data.Morpheus.Types.Internal.Stitching (Stitching (..))+import Data.Morpheus.Validation.Document.Validation (ValidateSchema (..))+import Data.Semigroup (Semigroup (..))+import Data.Text (pack)+import Prelude+  ( ($),+    (.),+    Bool (..),+    Maybe (..),+    const,+  )++mkApp :: ValidateSchema s => Schema s -> RootResModel e m -> App e m+mkApp appSchema appResolvers =+  resultOr+    FailApp+    (App . AppData defaultConfig appResolvers)+    (validateSchema True defaultConfig appSchema)++data App event (m :: * -> *)+  = App {app :: AppData event m VALID}+  | FailApp {appErrors :: GQLErrors}++instance RenderGQL (App e m) where+  render App {app} = render app+  render FailApp {appErrors} = pack $ LBS.unpack (A.encode appErrors)++instance Monad m => Semigroup (App e m) where+  (FailApp err1) <> (FailApp err2) = FailApp (err1 <> err2)+  FailApp {appErrors} <> App {} = FailApp appErrors+  App {} <> FailApp {appErrors} = FailApp appErrors+  (App x) <> (App y) = resultOr FailApp App (stitch x y)++data AppData event (m :: * -> *) s = AppData+  { appConfig :: Config,+    appResolvers :: RootResModel event m,+    appSchema :: Schema s+  }++instance RenderGQL (AppData e m s) where+  render = render . appSchema++instance Monad m => Stitching (AppData e m s) where+  stitch x y =+    AppData (appConfig y)+      <$> prop stitch appResolvers x y+      <*> prop stitch appSchema x y++runAppData ::+  (Monad m, ValidateSchema s) =>+  AppData event m s ->+  GQLRequest ->+  ResponseStream event m (Value VALID)+runAppData AppData {appConfig, appSchema, appResolvers} request = do+  validRequest <- validateReq appSchema appConfig request+  resovers <- withSystemFields (schema validRequest) appResolvers+  runRootResModel resovers validRequest++validateReq ::+  ( Monad m,+    ValidateSchema s+  ) =>+  Schema s ->+  Config ->+  GQLRequest ->+  ResponseStream event m ResolverContext+validateReq inputSchema config request = cleanEvents $ ResultT $ pure $ do+  validSchema <- validateSchema True config inputSchema+  schema <- internalSchema <:> validSchema+  operation <- parseRequestWith config schema request+  pure $+    ResolverContext+      { schema,+        config,+        operation,+        currentTypeName = "Root",+        currentSelection =+          Selection+            { selectionName = "Root",+              selectionArguments = empty,+              selectionPosition = operationPosition operation,+              selectionAlias = Nothing,+              selectionContent = SelectionSet (operationSelection operation),+              selectionDirectives = []+            }+      }++stateless ::+  Functor m =>+  ResponseStream event m (Value VALID) ->+  m GQLResponse+stateless = fmap renderResponse . runResultT++runAppStream :: Monad m => App event m -> GQLRequest -> ResponseStream event m (Value VALID)+runAppStream App {app} = runAppData app+runAppStream FailApp {appErrors} = const $ failure appErrors++runApp :: (MapAPI a b, Monad m) => App e m -> a -> m b+runApp app = mapAPI (stateless . runAppStream app)++withDebugger :: App e m -> App e m+withDebugger App {app = AppData {appConfig = Config {..}, ..}} =+  App {app = AppData {appConfig = Config {debug = True, ..}, ..}, ..}+withDebugger x = x

@@ -22,7 +22,6 @@     Value (..),     replaceValue,   )-import Data.Proxy (Proxy (..)) import Data.Text (Text, unpack) import Prelude   ( ($),@@ -60,7 +59,7 @@   -- | serialization of haskell type into scalar value   serialize :: a -> ScalarValue -  scalarValidator :: Proxy a -> ScalarDefinition+  scalarValidator :: f a -> ScalarDefinition   scalarValidator _ = ScalarDefinition {validateValue = validator}     where       validator value = do

@@ -78,9 +78,7 @@     initTypeLib,     kindOf,     toNullable,-    toListField,     isObject,-    isInput,     toHSWrappers,     isNullable,     toGQLWrapper,@@ -95,23 +93,21 @@     mkTypeRef,     mkInputUnionFields,     fieldVisibility,-    insertType,     lookupDeprecated,     lookupDeprecatedReason,     lookupWith,-    -- Temaplate Haskell+    -- Template Haskell     hsTypeName,     -- LOCAL     GQLQuery (..),     Variables,     unsafeFromFields,-    OrdMap,+    OrdMap (..),     GQLError (..),     GQLErrors,     ObjectEntry (..),     UnionTag (..),     __inputname,-    updateSchema,     internalFingerprint,     ANY,     IN,@@ -164,11 +160,14 @@     toGQLError,     ELEM,     LEAF,-    REQURE_IMPLEMENTABLE,+    REQUIRE_IMPLEMENTABLE,     ToCategory (..),     FromCategory (..),     possibleTypes,     possibleInterfaceTypes,+    mkField,+    isTypeDefined,+    safeDefineType,   ) where 

@@ -37,7 +37,6 @@     isOutputObject,     isNotSystemTypeName,     isObject,-    isInput,     sysFields,     hsTypeName,     toOperationType,@@ -233,7 +232,15 @@   deriving     (Generic)   deriving newtype-    (Show, Ord, Eq, IsString, Hashable, Semigroup, FromJSON, ToJSON)+    ( Show,+      Ord,+      Eq,+      IsString,+      Hashable,+      Semigroup,+      FromJSON,+      ToJSON+    )  instance Lift TypeName where   lift = liftString . readTypeName@@ -327,7 +334,7 @@ ------------------------------------------------------------------- data TypeRef = TypeRef   { typeConName :: TypeName,-    typeArgs :: Maybe TypeName,+    typeArgs :: Maybe String,     typeWrappers :: [TypeWrapper]   }   deriving (Show, Eq, Lift)@@ -391,10 +398,6 @@ isObject KindInputObject = True isObject KindInterface = True isObject _ = False--isInput :: TypeKind -> Bool-isInput KindInputObject = True-isInput _ = False  -- TypeWrappers -----------------------------------------------------------------------------------

@@ -31,7 +31,6 @@     Directives,     Directive (..),     fieldVisibility,-    toListField,     lookupDeprecated,     lookupDeprecatedReason,     unsafeFromFields,@@ -39,6 +38,7 @@     fieldContentArgs,     mkInputValue,     mkObjectField,+    mkField,   ) where @@ -252,7 +252,7 @@     fieldDirectives :: [Directive s],     fieldContent :: Maybe (FieldContent TRUE cat s)   }-  deriving (Show, Lift)+  deriving (Show, Lift, Eq)  data FieldContent (bool :: Bool) (cat :: TypeCategory) (s :: Stage) where   DefaultInputValue ::@@ -268,6 +268,8 @@ fieldContentArgs (FieldArgs args) = args fieldContentArgs _ = empty +deriving instance Eq (FieldContent bool cat s)+ deriving instance Show (FieldContent bool cat s)  deriving instance Lift (FieldContent bool cat s)@@ -299,23 +301,26 @@ fieldVisibility :: FieldDefinition cat s -> Bool fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields -createField ::+mkField ::   Maybe (FieldContent TRUE cat s) ->   FieldName ->-  [TypeWrapper] ->-  TypeName ->+  TypeRef ->   FieldDefinition cat s-createField fieldContent fieldName typeWrappers typeConName =+mkField fieldContent fieldName fieldType =   FieldDefinition     { fieldName,       fieldContent,       fieldDescription = Nothing,-      fieldType = TypeRef {typeConName, typeWrappers, typeArgs = Nothing},+      fieldType,       fieldDirectives = []     }  mkInputValue :: FieldName -> [TypeWrapper] -> TypeName -> FieldDefinition cat s-mkInputValue = createField Nothing+mkInputValue fieldName typeWrappers typeConName =+  mkField+    Nothing+    fieldName+    TypeRef {typeWrappers, typeConName, typeArgs = Nothing}  mkObjectField ::   ArgumentsDefinition s ->@@ -323,13 +328,11 @@   [TypeWrapper] ->   TypeName ->   FieldDefinition OUT s-mkObjectField args = createField (Just $ FieldArgs args)--toListField :: FieldDefinition cat s -> FieldDefinition cat s-toListField dataField = dataField {fieldType = listW (fieldType dataField)}-  where-    listW alias@TypeRef {typeWrappers} =-      alias {typeWrappers = TypeList : typeWrappers}+mkObjectField args fieldName typeWrappers typeConName =+  mkField+    (Just $ FieldArgs args)+    fieldName+    TypeRef {typeWrappers, typeConName, typeArgs = Nothing}  -- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects ---------------------------------------------------------------------------@@ -349,7 +352,7 @@   { argumentsTypename :: Maybe TypeName,     arguments :: OrdMap FieldName (ArgumentDefinition s)   }-  deriving (Show, Lift)+  deriving (Show, Lift, Eq)  instance RenderGQL (ArgumentsDefinition s) where   render ArgumentsDefinition {arguments} = renderArguments (elems arguments)

@@ -23,8 +23,8 @@ import Control.Applicative (Applicative (..)) import Control.Monad (Monad (..)) import Data.Foldable (Foldable (..))-import Data.Functor ((<$>), Functor (..))-import Data.List ((\\), find)+import Data.Functor (Functor (..))+import Data.List (find) import Data.Maybe (maybe) import Data.Morpheus.Internal.Utils   ( (<:>),@@ -35,6 +35,10 @@     Merge (..),     Selectable (..),     elems,+    fromListT,+    mergeT,+    resolveWith,+    runResolutionT,   ) import Data.Morpheus.Types.Internal.AST.Base   ( Ref,@@ -57,7 +61,6 @@     (.),     Eq (..),     Show,-    flip,     otherwise,   ) @@ -123,7 +126,7 @@   ) =>   Merge (MergeSet VALID a)   where-  merge = safeJoin+  merge path x y = runResolutionT (mergeT x y) MergeSet (resolveWith (resolveConflict path))  instance   ( Listable a (MergeSet VALID a),@@ -133,7 +136,7 @@   ) =>   Listable a (MergeSet VALID a)   where-  fromElems = safeFromList+  fromElems xs = runResolutionT (fromListT xs) MergeSet (resolveWith (resolveConflict []))   elems = unpack  instance Merge (MergeSet RAW a) where@@ -143,28 +146,7 @@   fromElems = pure . MergeSet   elems = unpack -safeFromList :: (Monad m, Eq a, KeyOf k a, Merge a, Failure ValidationErrors m) => [a] -> m (MergeSet opt a)-safeFromList = insertList [] empty--safeJoin :: (Monad m, KeyOf k a, Eq a, Listable a (MergeSet opt a), Merge a, Failure ValidationErrors m) => [Ref] -> MergeSet opt a -> MergeSet opt a -> m (MergeSet opt a)-safeJoin path hm1 hm2 = insertList path hm1 (elems hm2)--insertList :: (Monad m, Eq a, KeyOf k a, Merge a, Failure ValidationErrors m) => [Ref] -> MergeSet opt a -> [a] -> m (MergeSet opt a)-insertList _ smap [] = pure smap-insertList path smap (x : xs) = insert path smap x >>= flip (insertList path) xs--insert :: (Monad m, Eq a, KeyOf k a, Merge a, Failure ValidationErrors m) => [Ref] -> MergeSet opt a -> a -> m (MergeSet opt a)-insert path mSet@(MergeSet ls) currentValue = MergeSet <$> __insert-  where-    __insert =-      selectOr-        (pure $ ls <> [currentValue])-        mergeWith-        (keyOf currentValue)-        mSet-    -------------------    mergeWith oldValue-      | oldValue == currentValue = pure ls-      | otherwise = do-        mergedValue <- merge path oldValue currentValue-        pure $ (ls \\ [oldValue]) <> [mergedValue]+resolveConflict :: (Monad m, Eq a, KeyOf k a, Merge a, Failure ValidationErrors m) => [Ref] -> a -> a -> m a+resolveConflict path oldValue newValue+  | oldValue == newValue = pure oldValue+  | otherwise = merge path oldValue newValue

@@ -15,6 +15,7 @@  module Data.Morpheus.Types.Internal.AST.SafeHashMap   ( SafeHashMap,+    unsafeFromValues,     insert,   ) where@@ -35,6 +36,7 @@     Listable (..),     Merge (..),     Selectable (..),+    toPair,   ) import Data.Morpheus.Types.Internal.AST.Base (ValidationErrors) import Data.Traversable (Traversable (..))@@ -73,6 +75,9 @@ instance (NameCollision a, KeyOf k a, Hashable k) => Listable a (SafeHashMap k a) where   fromElems = fmap SafeHashMap . fromElems   elems = elems . unpackSafeHashMap++unsafeFromValues :: (Eq k, KeyOf k a) => [a] -> SafeHashMap k a+unsafeFromValues = SafeHashMap . HM.fromList . fmap toPair  insert ::   ( NameCollision a,

@@ -145,8 +145,8 @@   where   merge path (SelectionSet s1) (SelectionSet s2) = SelectionSet <$> merge path s1 s2   merge path (UnionSelection u1) (UnionSelection u2) = UnionSelection <$> merge path u1 u2-  merge path oldC currC-    | oldC == currC = pure oldC+  merge path oldC currentC+    | oldC == currentC = pure oldC     | otherwise =       failure         [ ValidationError@@ -233,8 +233,8 @@       } = fromMaybe selectionName selectionAlias   keyOf _ = "" -useDufferentAliases :: Message-useDufferentAliases =+useDifferentAliases :: Message+useDifferentAliases =   "Use different aliases on the "     <> "fields to fetch both if this was intentional." @@ -275,11 +275,11 @@                 { validationMessage =                     "" <> msg (selectionName old) <> " and " <> msg (selectionName current)                       <> " are different fields. "-                      <> useDufferentAliases,+                      <> useDifferentAliases,                   validationLocations = [pos1, pos2]                 }         ----------------------        -- allias name is relevant only if they collide by allias like:+        -- alias name is relevant only if they collide by allies like:         --   { user1: user         --     user1: user         --   }@@ -292,14 +292,14 @@           | otherwise =             failure $ mergeConflict currentPath $               ValidationError-                { validationMessage = "they have differing arguments. " <> useDufferentAliases,+                { validationMessage = "they have differing arguments. " <> useDifferentAliases,                   validationLocations = [pos1, pos2]                 }   merge path _ _ =     failure $       mergeConflict         path-        ("INTERNAL: can't merge. " <> msgValidation useDufferentAliases :: ValidationError)+        ("INTERNAL: can't merge. " <> msgValidation useDifferentAliases :: ValidationError)  deriving instance Show (Selection a) 

@@ -16,7 +16,7 @@     IMPLEMENTABLE,     fromAny,     toAny,-    REQURE_IMPLEMENTABLE,+    REQUIRE_IMPLEMENTABLE,     ToCategory (..),     FromCategory (..),   )@@ -74,7 +74,7 @@     (setOfKind :: TypeCategory) ::     Bool -type REQURE_IMPLEMENTABLE cat = ELEM cat IMPLEMENTABLE ~ TRUE+type REQUIRE_IMPLEMENTABLE cat = ELEM cat IMPLEMENTABLE ~ TRUE  -- ANY type instance ELEM ANY a = TRUE

@@ -36,12 +36,10 @@     createScalarType,     mkInputUnionFields,     initTypeLib,-    insertType,     kindOf,     isEntNode,     lookupWith,     __inputname,-    updateSchema,     UnionMember (..),     mkUnionMember,     RawTypeDefinition (..),@@ -53,6 +51,8 @@     typed,     possibleTypes,     possibleInterfaceTypes,+    isTypeDefined,+    safeDefineType,   ) where @@ -68,7 +68,6 @@ import Data.Morpheus.Error.NameCollision   ( NameCollision (..),   )-import Data.Morpheus.Error.Schema (nameCollisionError) import Data.Morpheus.Internal.Utils   ( (<:>),     Collection (..),@@ -77,14 +76,13 @@     Listable (..),     Merge (..),     Selectable (..),-    UpdateT (..),-    concatUpdates,     elems,-    resolveUpdates,   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),+    Rendering,     newline,+    renderEntry,     renderMembers,     renderObject,   )@@ -157,14 +155,13 @@     Bool (..),     Eq (..),     Show (..),-    const,     flip,     otherwise,   )  type DataEnum s = [DataEnumValue s] --- used for perserving type information from untyped values+-- used for preserving type information from untyped values -- e.g -- unionType :: UnionMember IN VALID -> Typed IN VALID TypeName -- unionType = typed memberName@@ -174,7 +171,7 @@ untyped :: (a -> b) -> Typed c s a -> b untyped f = f . _untyped --- | used for perserving type information from untyped values+-- | used for preserving type information from untyped values -- see function typed newtype Typed (cat :: TypeCategory) (s :: Stage) a = Typed   { _untyped :: a@@ -281,6 +278,12 @@   }   deriving (Show) +instance RenderGQL SchemaDefinition where+  render = renderSchemaDefinition . elems . unSchemaDefinition++renderSchemaDefinition :: RenderGQL a => [a] -> Rendering+renderSchemaDefinition entries = "schema" <> renderObject entries <> newline+ instance Selectable OperationType RootOperationTypeDefinition SchemaDefinition where   selectOr fallback f key SchemaDefinition {unSchemaDefinition} =     selectOr fallback f key unSchemaDefinition@@ -310,6 +313,13 @@ instance KeyOf OperationType RootOperationTypeDefinition where   keyOf = rootOperationType +instance RenderGQL RootOperationTypeDefinition where+  render+    RootOperationTypeDefinition+      { rootOperationType,+        rootOperationTypeDefinitionName+      } = renderEntry rootOperationType rootOperationTypeDefinitionName+ type TypeLib s = SafeHashMap TypeName (TypeDefinition ANY s)  instance Selectable TypeName (TypeDefinition ANY s) (Schema s) where@@ -338,17 +348,17 @@     Maybe (TypeDefinition OBJECT s)   ) ->   f (Schema s)-buildWith otypes (Just query, mutation, subscription) = do-  let types = excludeTypes [Just query, mutation, subscription] otypes+buildWith oTypes (Just query, mutation, subscription) = do+  let types = excludeTypes [Just query, mutation, subscription] oTypes   let schema = (initTypeLib query) {mutation, subscription}   foldM (flip safeDefineType) schema types buildWith _ (Nothing, _, _) = failure ["Query root type must be provided." :: ValidationError]  excludeTypes :: [Maybe (TypeDefinition c1 s)] -> [TypeDefinition c2 s] -> [TypeDefinition c2 s]-excludeTypes excusionTypes = filter ((`notElem` blacklist) . typeName)+excludeTypes exclusionTypes = filter ((`notElem` blacklist) . typeName)   where     blacklist :: [TypeName]-    blacklist = fmap typeName (catMaybes excusionTypes)+    blacklist = fmap typeName (catMaybes exclusionTypes)  withDirectives ::   [DirectiveDefinition s] ->@@ -477,15 +487,15 @@   TypeName ->   Schema s ->   [TypeDefinition ANY s]-possibleInterfaceTypes name schema = mapMaybe (isPosibleInterfaceType name) (elems schema)+possibleInterfaceTypes name schema = mapMaybe (isPossibleInterfaceType name) (elems schema) -isPosibleInterfaceType ::+isPossibleInterfaceType ::   TypeName ->   TypeDefinition c s ->   Maybe (TypeDefinition c s)-isPosibleInterfaceType name typeDef@TypeDefinition {typeName, typeContent = DataObject {objectImplements}}+isPossibleInterfaceType name typeDef@TypeDefinition {typeName, typeContent = DataObject {objectImplements}}   | name `elem` (typeName : objectImplements) = Just typeDef-isPosibleInterfaceType _ _ = Nothing+isPossibleInterfaceType _ _ = Nothing  instance   (FromCategory (TypeContent TRUE) cat cat') =>@@ -641,32 +651,6 @@   types <- insert (toAny datatype) (types lib)   pure lib {types} -insertType ::-  (Monad m, Failure ValidationErrors m) =>-  TypeDefinition cat s ->-  UpdateT m (Schema s)-insertType datatype@TypeDefinition {typeName, typeFingerprint} =-  updateSchema typeName typeFingerprint [] (const datatype) ()--updateSchema ::-  (Monad m, Failure ValidationErrors m) =>-  TypeName ->-  DataFingerprint ->-  [UpdateT m (Schema s)] ->-  (a -> TypeDefinition cat s) ->-  a ->-  UpdateT m (Schema s)-updateSchema name fingerprint stack f x-  | isNotSystemTypeName name = UpdateT $ \lib ->-    case isTypeDefined name lib of-      Nothing -> do-        t <- safeDefineType (f x) lib-        resolveUpdates t stack-      Just fingerprint' | fingerprint' == fingerprint -> pure lib-      -- throw error if 2 different types has same name-      Just _ -> failure [nameCollisionError name]-  | otherwise = concatUpdates stack- lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a lookupWith f key = find ((== key) . f) @@ -721,8 +705,15 @@ --------------------------------------------------------------------------------------------------  instance RenderGQL (Schema s) where-  render schema = intercalate newline (fmap render visibleTypes)+  render schema =+    intercalate newline (fmap render visibleTypes <> [renderSchemaDefinition entries])     where+      entries =+        RootOperationTypeDefinition Query (typeName $ query schema)+          : catMaybes+            [ RootOperationTypeDefinition Mutation . typeName <$> mutation schema,+              RootOperationTypeDefinition Subscription . typeName <$> subscription schema+            ]       visibleTypes = filter (isNotSystemTypeName . typeName) (elems schema)  instance RenderGQL (TypeDefinition a s) where

@@ -48,7 +48,7 @@ import Data.Either (Either (..)) import Data.Foldable (foldl, foldl1, null) import Data.Functor (fmap)-import qualified Data.HashMap.Strict as M+import qualified Data.HashMap.Lazy as M   ( toList,   ) import Data.Maybe (Maybe (..))@@ -115,6 +115,7 @@   | Float Float   | String Text   | Boolean Bool+  | Value A.Value   deriving (Show, Eq, Generic, Lift)  instance RenderGQL ScalarValue where@@ -122,12 +123,14 @@   render (Float x) = render x   render (String x) = render x   render (Boolean x) = render x+  render (Value x) = render x  instance A.ToJSON ScalarValue where   toJSON (Float x) = A.toJSON x   toJSON (Int x) = A.toJSON x   toJSON (Boolean x) = A.toJSON x   toJSON (String x) = A.toJSON x+  toJSON (Value x) = A.toJSON x  instance A.FromJSON ScalarValue where   parseJSON (A.Bool v) = pure $ Boolean v

@@ -20,7 +20,6 @@     unpackEvents,     ObjectResModel (..),     ResModel (..),-    FieldResModel,     WithOperation,     PushEvents (..),     subscribe,@@ -45,6 +44,7 @@     ResolverState,     liftResolverState,     mkValue,+    FieldResModel,   ) where @@ -52,10 +52,7 @@ import Control.Monad (Monad) import qualified Data.Aeson as A import Data.Functor (fmap)-import qualified Data.HashMap.Strict as HM-  ( lookup,-    toList,-  )+import qualified Data.HashMap.Lazy as HM import Data.Maybe (maybe) import Data.Morpheus.Internal.Utils   ( mapTuple,@@ -126,14 +123,16 @@ mkValue (A.String x) = ResScalar (String x) mkValue (A.Bool x) = ResScalar (Boolean x) +type FieldResModel o e m = (FieldName, Resolver o e m (ResModel o e m))+ mkObject ::   TypeName ->   [(FieldName, Resolver o e m (ResModel o e m))] ->   ResModel o e m-mkObject __typename objectFields =+mkObject __typename fields =   ResObject     ( ObjectResModel         { __typename,-          objectFields+          objectFields = HM.fromList fields         }     )

@@ -28,7 +28,6 @@     ResponseStream,     ObjectResModel (..),     ResModel (..),-    FieldResModel,     WithOperation,     ResolverContext (..),     unsafeInternalContext,@@ -52,6 +51,8 @@     mapReaderT,   ) import Data.Functor ((<$>), Functor (..))+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HM import Data.Maybe (Maybe (..), maybe) import Data.Morpheus.Error.Selection (subfieldsNotSelected) import Data.Morpheus.Internal.Utils@@ -77,6 +78,7 @@     OperationType,     OperationType (..),     QUERY,+    Ref,     SUBSCRIPTION,     ScalarValue (..),     Selection (..),@@ -127,7 +129,6 @@     (.),     Eq (..),     Show (..),-    lookup,     otherwise,   ) @@ -259,7 +260,7 @@     $ fromSub <$> runResolverQ res   where     fromSub :: (e -> Resolver SUBSCRIPTION e m a) -> ReaderT e (ResolverStateT () m) a-    fromSub f = join (ReaderT $ \e -> runResolverS (f e))+    fromSub f = join (ReaderT (runResolverS . f))  withArguments ::   (LiftOperation o, Monad m) =>@@ -300,7 +301,7 @@     maybe       (pure gqlNull)       (>>= runDataResolver)-      . lookup selectionName+      . HM.lookup selectionName       . objectFields  resolveObject ::@@ -336,9 +337,9 @@               ResUnion name                 $ pure                 $ ResObject-                $ ObjectResModel name [("enum", pure $ ResScalar $ String $ readTypeName enum)]-        encodeNode ResEnum {} _ =-          failure ("wrong selection on enum value" :: Message)+                $ ObjectResModel name+                $ HM.singleton "enum" (pure $ ResScalar $ String $ readTypeName enum)+        encodeNode ResEnum {} _ = failure ("wrong selection on enum value" :: Message)         -- UNION         encodeNode (ResUnion typename unionRef) (UnionSelection selections) =           unionRef >>= resolveObject currentSelection@@ -388,32 +389,54 @@ subscriptionEvents ctx Nothing _ = failure [resolverFailureMessage ctx "channel Resolver is not defined"]  -- Resolver Models --------------------------------------------------------------------type FieldResModel o e m =-  (FieldName, Resolver o e m (ResModel o e m))  data ObjectResModel o e m = ObjectResModel   { __typename :: TypeName,-    objectFields ::-      [FieldResModel o e m]+    objectFields :: HashMap FieldName (Resolver o e m (ResModel o e m))   }   deriving (Show) -instance Applicative f => SemigroupM f (ObjectResModel o e m) where-  mergeM _ (ObjectResModel tyname x) (ObjectResModel _ y) =-    pure $ ObjectResModel tyname (x <> y)+instance+  ( Monad m,+    Applicative f,+    LiftOperation o+  ) =>+  SemigroupM f (ObjectResModel o e m)+  where+  mergeM path (ObjectResModel tyname x) (ObjectResModel _ y) =+    pure $ ObjectResModel tyname (HM.unionWith (mergeResolver path) x y) +mergeResolver ::+  (Monad m, SemigroupM (ResolverStateT e m) a, LiftOperation o) =>+  [Ref] ->+  Resolver o e m a ->+  Resolver o e m a ->+  Resolver o e m a+mergeResolver path a b = do+  a' <- a+  b >>= packResolver . mergeM path a'+ data ResModel (o :: OperationType) e (m :: * -> *)   = ResNull   | ResScalar ScalarValue   | ResEnum TypeName TypeName-  | ResList [ResModel o e m]   | ResObject (ObjectResModel o e m)+  | ResList [ResModel o e m]   | ResUnion TypeName (Resolver o e m (ResModel o e m))   deriving (Show) -instance (Monad f, Failure InternalError f) => SemigroupM f (ResModel o e m) where-  mergeM p (ResObject x) (ResObject y) =-    ResObject <$> mergeM p x y+instance+  ( Monad f,+    Monad m,+    LiftOperation o,+    Failure InternalError f+  ) =>+  SemigroupM f (ResModel o e m)+  where+  mergeM _ ResNull ResNull = pure ResNull+  mergeM _ ResScalar {} x@ResScalar {} = pure x+  mergeM _ ResEnum {} x@ResEnum {} = pure x+  mergeM p (ResObject x) (ResObject y) = ResObject <$> mergeM p x y   mergeM _ _ _ = failure ("can't merge: incompatible resolvers" :: InternalError)  data RootResModel e m = RootResModel

@@ -0,0 +1,147 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.Internal.Stitching+  ( Stitching (..),+  )+where++import Control.Applicative (Applicative (..))+import Control.Monad (Monad (..))+import Data.Functor ((<$>))+import Data.Maybe (Maybe (..))+import Data.Morpheus.Error.NameCollision (NameCollision (..))+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    SemigroupM (..),+    mergeT,+    prop,+    resolveWith,+    runResolutionT,+  )+import Data.Morpheus.Types.Internal.AST+  ( Directive,+    DirectiveDefinition,+    FieldDefinition,+    Fields (..),+    FieldsDefinition,+    Schema (..),+    TRUE,+    TypeContent (..),+    TypeDefinition (..),+    TypeLib,+    ValidationErrors,+  )+import qualified Data.Morpheus.Types.Internal.AST.OrdMap as OM (unsafeFromValues)+import qualified Data.Morpheus.Types.Internal.AST.SafeHashMap as SHM (unsafeFromValues)+import Data.Morpheus.Types.Internal.Resolving (RootResModel)+import qualified Data.Morpheus.Types.Internal.Resolving as R (RootResModel (..))+import Data.Semigroup (Semigroup (..))+import Prelude+  ( ($),+    (.),+    Eq (..),+    otherwise,+  )++equal :: (Eq a, Applicative m, Failure ValidationErrors m) => ValidationErrors -> a -> a -> m a+equal err p1 p2+  | p1 == p2 = pure p2+  | otherwise = failure err++fstM :: Applicative m => a -> a -> m a+fstM x _ = pure x++concatM :: (Applicative m, Semigroup a) => a -> a -> m a+concatM x = pure . (x <>)++class Stitching a where+  stitch :: (Monad m, Failure ValidationErrors m) => a -> a -> m a++instance Stitching a => Stitching (Maybe a) where+  stitch = optional stitch++instance Stitching (Schema s) where+  stitch s1 s2 =+    Schema+      <$> prop stitch types s1 s2+      <*> prop stitchOperation query s1 s2+      <*> prop (optional stitchOperation) mutation s1 s2+      <*> prop (optional stitchOperation) subscription s1 s2+      <*> prop stitch directiveDefinitions s1 s2++instance Stitching (TypeLib s) where+  stitch x y = runResolutionT (mergeT x y) SHM.unsafeFromValues (resolveWith stitch)++instance Stitching [DirectiveDefinition s] where+  stitch = concatM++instance Stitching [Directive s] where+  stitch = concatM++optional :: Applicative f => (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t)+optional _ Nothing y = pure y+optional _ (Just x) Nothing = pure (Just x)+optional f (Just x) (Just y) = Just <$> f x y++stitchOperation ::+  (Monad m, Failure ValidationErrors m) =>+  TypeDefinition c s ->+  TypeDefinition c s ->+  m (TypeDefinition c s)+stitchOperation x y =+  TypeDefinition+    <$> prop fstM typeName x y+    <*> prop fstM typeFingerprint x y+    <*> prop concatM typeDescription x y+    <*> prop stitch typeDirectives x y+    <*> prop stitch typeContent x y++instance Stitching (TypeDefinition cat s) where+  stitch x y =+    TypeDefinition+      <$> prop (equal [nameCollision y]) typeName x y+      <*> prop (equal [nameCollision y]) typeFingerprint x y+      <*> prop concatM typeDescription x y+      <*> prop stitch typeDirectives x y+      <*> prop stitch typeContent x y++instance Stitching (TypeContent TRUE cat s) where+  stitch (DataObject i1 fields1) (DataObject i2 fields2) =+    DataObject (i1 <> i2) <$> stitch fields1 fields2+  stitch _ _ = failure (["Schema Stitching works only for objects"] :: ValidationErrors)++instance Stitching (FieldsDefinition cat s) where+  stitch (Fields x) (Fields y) = Fields <$> runResolutionT (mergeT x y) OM.unsafeFromValues (resolveWith stitch)++instance Stitching (FieldDefinition cat s) where+  stitch old new+    | old == new = pure old+    | otherwise = failure [nameCollision new]++rootProp :: (Monad m, SemigroupM m b) => (a -> m b) -> a -> a -> m b+rootProp f x y = do+  x' <- f x+  y' <- f y+  mergeM [] x' y'++stitchSubscriptions :: Failure ValidationErrors m => Maybe a -> Maybe a -> m (Maybe a)+stitchSubscriptions Just {} Just {} = failure (["can't merge  subscription applications"] :: ValidationErrors)+stitchSubscriptions x Nothing = pure x+stitchSubscriptions Nothing x = pure x++instance Monad m => Stitching (RootResModel e m) where+  stitch x y = do+    channelMap <- stitchSubscriptions (R.channelMap x) (R.channelMap y)+    pure $+      R.RootResModel+        { R.query = rootProp R.query x y,+          R.mutation = rootProp R.mutation x y,+          R.subscription = rootProp R.subscription x y,+          R.channelMap+        }

@@ -230,17 +230,17 @@     }   values =     selectOr-      (handeNull fieldContent)+      (handleNull fieldContent)       validateF       fieldName       values     where       -------------------      handeNull ::+      handleNull ::         Maybe (FieldContent TRUE IN s) ->         Validator s ctx validValue-      handeNull (Just (DefaultInputValue value)) = f value-      handeNull Nothing+      handleNull (Just (DefaultInputValue value)) = f value+      handleNull Nothing         | isNullable field = f Null         | otherwise = failSelection       -----------------@@ -288,7 +288,7 @@         )         __inputname         hm-  unionMember <- isPosibeInputUnion tags enum+  unionMember <- isPossibleInputUnion tags enum   case size hm of     1 -> pure (unionMember, Nothing)     2 -> do@@ -304,10 +304,10 @@       pure (unionMember, Just value)     _ -> failure ("input union can have only one variant." :: Message) -isPosibeInputUnion :: [UnionMember IN s] -> Value stage -> Either Message (UnionMember IN s)-isPosibeInputUnion tags (Enum name) =+isPossibleInputUnion :: [UnionMember IN s] -> Value stage -> Either Message (UnionMember IN s)+isPossibleInputUnion tags (Enum name) =   selectBy-    (msg name <> " is not posible union type")+    (msg name <> " is not possible union type")     name     tags-isPosibeInputUnion _ _ = failure $ "\"" <> msg __inputname <> "\" must be Enum"+isPossibleInputUnion _ _ = failure $ "\"" <> msg __inputname <> "\" must be Enum"

@@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -13,17 +14,20 @@ where  import Control.Monad ((>=>))-import Data.Maybe (isJust)+import Data.Maybe (fromMaybe, isJust) -- MORPHEUS import Data.Morpheus.Internal.Utils-  ( elems,+  ( (<:>),+    elems,     empty,     fromElems,+    singleton,   ) import Data.Morpheus.Types.Internal.AST   ( DataUnion,     Fragment (..),     IMPLEMENTABLE,+    Position (..),     RAW,     Selection (..),     SelectionContent (..),@@ -138,6 +142,23 @@   where     joinCluster (typeName, fragmets) = UnionTag typeName <$> MS.join (selSet : fragmets) +withTypename ::+  SelectionSet VALID ->+  FragmentValidator s (SelectionSet VALID)+withTypename sel = do+  selectionPosition <- fromMaybe (Position 0 0) <$> asksScope position+  sel+    <:> singleton+      ( Selection+          { selectionName = "__typename",+            selectionAlias = Nothing,+            selectionPosition,+            selectionArguments = empty,+            selectionContent = SelectionField,+            selectionDirectives = empty+          }+      )+ validateInterfaceSelection ::   ResolveFragment s =>   (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->@@ -156,7 +177,9 @@     let categories = tagUnionFragments possibleTypes spreads     if null categories       then pure (SelectionSet validSelectionSet)-      else joinClusters validSelectionSet (insertDefault (typeName typeDef) categories)+      else do+        validSelectionSetWithTypename <- withTypename validSelectionSet+        joinClusters validSelectionSetWithTypename (insertDefault (typeName typeDef) categories)  insertDefault :: TypeName -> [(TypeName, [a])] -> [(TypeName, [a])] insertDefault interfaceName categories

@@ -1,177 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Lib-  ( getGQLBody,-    expectedResponse,-    getCases,-    maybeVariables,-    readSource,-    scanSchemaTests,-    FileUrl (..),-    CaseTree (..),-    toString,-    getRequest,-    assertValidSchema,-    getSchema,-    getResolvers,-  )-where--import Control.Applicative ((<|>), pure)-import Control.Monad ((>=>), Monad)-import Data.Aeson (FromJSON, Value (..), decode)-import qualified Data.ByteString.Lazy as L (readFile)-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Either (Either (..))-import Data.Foldable (foldl)-import Data.Functor ((<$>))-import Data.HashMap.Lazy (lookup)-import Data.Maybe (Maybe (..), fromMaybe, maybe)-import Data.Morpheus.Core (parseGQLDocument)-import Data.Morpheus.Types.IO-  ( GQLRequest (..),-  )-import Data.Morpheus.Types.Internal.AST (FieldName (..), Schema (..), VALID)-import Data.Morpheus.Types.Internal.Resolving-  ( Eventless,-    ResModel,-    RootResModel (..),-    WithOperation,-    mkNull,-    mkValue,-    resultOr,-  )-import Data.Semigroup ((<>))-import Data.Text (Text, unpack)-import qualified Data.Text.Lazy as LT (toStrict)-import Data.Text.Lazy.Encoding (decodeUtf8)-import Data.Traversable (traverse)-import System.Directory (doesDirectoryExist, listDirectory)-import Test.Tasty.HUnit-  ( assertFailure,-  )-import Prelude-  ( ($),-    (.),-    Bool,-    FilePath,-    IO,-    Show,-    and,-    map,-    show,-  )--readSource :: FieldName -> IO ByteString-readSource = L.readFile . path . readName--path :: Text -> FilePath-path name = "test/" <> unpack name--gqlLib :: Text -> FilePath-gqlLib x = path x <> "/query.gql"--resLib :: Text -> FilePath-resLib x = path x <> "/response.json"--data FileUrl = FileUrl-  { filePath :: [FilePath],-    fileName :: FilePath-  }-  deriving (Show)--data CaseTree = CaseTree-  { caseUrl :: FileUrl,-    children :: Either [FilePath] [CaseTree]-  }-  deriving (Show)--prefix :: FileUrl -> FilePath -> FileUrl-prefix FileUrl {..} x =-  FileUrl-    { filePath = fileName : filePath,-      fileName = x-    }--toString :: FileUrl -> FilePath-toString FileUrl {..} = foldl (\y x -> x <> "/" <> y) fileName filePath--scanSchemaTests :: FilePath -> IO CaseTree-scanSchemaTests = deepScan--deepScan :: FilePath -> IO CaseTree-deepScan = shouldScan . FileUrl []-  where-    shouldScan :: FileUrl -> IO CaseTree-    shouldScan caseUrl = do-      children <- prefixed caseUrl-      pure CaseTree {..}-    isDirectory :: FileUrl -> IO Bool-    isDirectory = doesDirectoryExist . toString-    prefixed :: FileUrl -> IO (Either [FilePath] [CaseTree])-    prefixed p = do-      dir <- isDirectory p-      if dir-        then do-          list <- map (prefix p) <$> listDirectory (toString p)-          areDirectories <- traverse isDirectory list-          if and areDirectories-            then Right <$> traverse shouldScan list-            else pure $ Left []-        else pure $ Left []--maybeVariables :: FieldName -> IO (Maybe Value)-maybeVariables (FieldName x) = decode <$> (L.readFile (path x <> "/variables.json") <|> pure "{}")--getGQLBody :: FieldName -> IO ByteString-getGQLBody (FieldName p) = L.readFile (gqlLib p)--getCases :: FromJSON a => FilePath -> IO [a]-getCases dir = fromMaybe [] . decode <$> L.readFile ("test/" <> dir <> "/cases.json")--getSchema :: FieldName -> IO (Eventless (Schema VALID))-getSchema (FieldName x) = parseGQLDocument <$> L.readFile (path x <> "/schema.gql")--assertValidSchema :: FieldName -> IO (Schema VALID)-assertValidSchema = getSchema >=> resultOr failedSchema pure-  where-    failedSchema err = assertFailure ("unexpected schema validation error: \n " <> show err)--expectedResponse :: FieldName -> IO Value-expectedResponse (FieldName p) = fromMaybe Null . decode <$> L.readFile (resLib p)--getRequest :: FieldName -> IO GQLRequest-getRequest p = do-  queryBS <- LT.toStrict . decodeUtf8 <$> getGQLBody p-  variables <- maybeVariables p-  pure $-    GQLRequest-      { operationName = Nothing,-        query = queryBS,-        variables-      }--getResolvers :: Monad m => FieldName -> IO (RootResModel e m)-getResolvers (FieldName p) = do-  res <- fromMaybe Null . decode <$> L.readFile (path p <> "/resolvers.json")-  pure-    RootResModel-      { query = pure (lookupRes "query" res),-        mutation = pure (lookupRes "mutation" res),-        subscription = pure (lookupRes "subscription" res),-        channelMap = Nothing-      }--lookupRes ::-  ( WithOperation o,-    Monad m-  ) =>-  Text ->-  Value ->-  ResModel o e m-lookupRes name (Object fields) = maybe mkNull mkValue (lookup name fields)-lookupRes _ _ = mkNull

@@ -13,6 +13,7 @@ import Utils.Api   ( apiTest,   )+import qualified Utils.MergeSchema as MergeSchema import Utils.Schema   ( testSchema,   )@@ -24,10 +25,12 @@ main :: IO () main = do   schema <- testSchema+  mergeSchema <- MergeSchema.test   defaultMain $     testGroup       "core tests"       [ schema,+        mergeSchema,         apiTest "api/deity" ["simple", "interface"],         apiTest           "api/validation/fragment"

@@ -15,7 +15,7 @@ import Data.Functor ((<$>), fmap) import Data.Functor.Identity (Identity (..)) import Data.Maybe (Maybe (..))-import Data.Morpheus.Core (defaultConfig, runApi)+import Data.Morpheus.Core (mkApp, runAppStream) import Data.Morpheus.Types.IO import Data.Morpheus.Types.Internal.AST   ( FieldName (..),@@ -28,12 +28,6 @@   ) import Data.Semigroup ((<>)) import Data.Text (unpack)-import Lib-  ( assertValidSchema,-    expectedResponse,-    getRequest,-    getResolvers,-  ) import Test.Tasty   ( TestTree,     testGroup,@@ -42,6 +36,12 @@   ( assertFailure,     testCase,   )+import Utils.Utils+  ( assertValidSchema,+    expectedResponse,+    getRequest,+    getResolvers,+  ) import Prelude   ( ($),     (==),@@ -72,6 +72,7 @@   schema <- assertValidSchema apiPath   resolvers <- getResolvers apiPath   let fullPath = apiPath <> "/" <> path-  actual <- runApi schema resolvers defaultConfig <$> getRequest fullPath+  let api = mkApp schema resolvers+  actual <- runAppStream api <$> getRequest fullPath   expected <- expectedResponse fullPath   assertion expected actual

@@ -0,0 +1,130 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Utils.MergeSchema+  ( test,+  )+where++import Control.Applicative (pure)+import Control.Monad ((>>=))+import Control.Monad.Fail (fail)+import Data.Aeson (decode, encode)+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as L (readFile)+import qualified Data.ByteString.Lazy.Char8 as LB (unpack)+import Data.Functor ((<$>), fmap)+import Data.Functor.Identity (Identity (..))+import Data.Morpheus.Core+  ( App (..),+    AppData (..),+    mkApp,+    mkApp,+    parseGQLDocument,+    render,+    runAppStream,+  )+import Data.Morpheus.Types.IO+import Data.Morpheus.Types.Internal.AST+  ( FieldName (..),+    Schema,+    VALID,+    Value,+  )+import Data.Morpheus.Types.Internal.Resolving+  ( ResponseStream,+    ResultT (..),+    resultOr,+  )+import Data.Semigroup ((<>))+import Data.Text (unpack)+import Data.Traversable (traverse)+import Test.Tasty+  ( TestTree,+    testGroup,+  )+import Test.Tasty.HUnit+  ( assertFailure,+    testCase,+  )+import Utils.Utils+  ( expectedResponse,+    getRequest,+    getResolver,+  )+import Prelude+  ( ($),+    (.),+    Eq (..),+    IO,+    Maybe (..),+    otherwise,+    show,+  )++readSchema :: FieldName -> IO (Schema VALID)+readSchema (FieldName p) = L.readFile (unpack p) >>= (resultOr (fail . show) pure . parseGQLDocument)++loadApi :: FieldName -> IO (App () Identity)+loadApi url = do+  schema <- readSchema ("test/" <> url <> ".gql")+  resolvers <- getResolver ("test/" <> url <> ".json")+  pure $ mkApp schema resolvers++schemaAssertion :: App () Identity -> Schema VALID -> IO ()+schemaAssertion (App AppData {appSchema}) expectedSchema+  | render expectedSchema == render appSchema = pure ()+  | otherwise =+    assertFailure+      $ unpack+      $ "expected: \n " <> render expectedSchema <> " \n but got: \n " <> render appSchema+schemaAssertion (FailApp gqlerror) _ = assertFailure $ " error: " <> show gqlerror++schemaCase :: (FieldName, [FieldName]) -> IO TestTree+schemaCase (url, files) = do+  schema <- loadApi (url <> "/api/app")+  extension <- loadApi (url <> "/api/ext")+  let api = schema <> extension+  pure $+    testGroup+      (show url)+      [ testCase+          "Schema"+          (readSchema ("test/" <> url <> "/expected/ok.gql") >>= schemaAssertion api),+        testGroup+          "Requests"+          (fmap (testApiRequest api url) files)+      ]++test :: IO TestTree+test =+  testGroup+    "merge schema"+    <$> traverse+      schemaCase+      [ ("merge/schema/simple-query", ["query"]),+        ("merge/schema/query-subscription-mutation", ["query", "mutation"])+      ]++assertion :: A.Value -> ResponseStream e Identity (Value VALID) -> IO ()+assertion expected (ResultT (Identity actual))+  | Just expected == decode actualValue = pure ()+  | otherwise =+    assertFailure $+      LB.unpack+        ("expected: \n\n " <> encode expected <> " \n\n but got: \n\n " <> actualValue)+  where+    actualValue = encode (renderResponse actual)++testApiRequest ::+  App () Identity ->+  FieldName ->+  FieldName ->+  TestTree+testApiRequest api base path = testCase (unpack $ readName path) $ do+  let fullPath = base <> "/request/" <> path+  actual <- runAppStream api <$> getRequest fullPath+  expected <- expectedResponse fullPath+  assertion expected actual

@@ -29,14 +29,14 @@ import Data.Semigroup ((<>)) import Data.Text (pack) import GHC.Generics (Generic)-import Lib+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase)+import Utils.Utils   ( CaseTree (..),     FileUrl (..),     scanSchemaTests,     toString,   )-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertFailure, testCase) import Prelude   ( ($),     (.),

@@ -0,0 +1,181 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Utils.Utils+  ( getGQLBody,+    expectedResponse,+    getCases,+    maybeVariables,+    readSource,+    scanSchemaTests,+    FileUrl (..),+    CaseTree (..),+    toString,+    getRequest,+    assertValidSchema,+    getSchema,+    getResolvers,+    getResolver,+  )+where++import Control.Applicative ((<|>), pure)+import Control.Monad ((>=>), Monad)+import Data.Aeson (FromJSON, Value (..), decode)+import qualified Data.ByteString.Lazy as L (readFile)+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Either (Either (..))+import Data.Foldable (foldl)+import Data.Functor ((<$>))+import Data.HashMap.Lazy (lookup)+import Data.Maybe (Maybe (..), fromMaybe, maybe)+import Data.Morpheus.Core (parseGQLDocument)+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+  )+import Data.Morpheus.Types.Internal.AST (FieldName (..), Schema (..), VALID)+import Data.Morpheus.Types.Internal.Resolving+  ( Eventless,+    ResModel,+    RootResModel (..),+    WithOperation,+    mkNull,+    mkValue,+    resultOr,+  )+import Data.Semigroup ((<>))+import Data.Text (Text, unpack)+import qualified Data.Text.Lazy as LT (toStrict)+import Data.Text.Lazy.Encoding (decodeUtf8)+import Data.Traversable (traverse)+import System.Directory (doesDirectoryExist, listDirectory)+import Test.Tasty.HUnit+  ( assertFailure,+  )+import Prelude+  ( ($),+    (.),+    Bool,+    FilePath,+    IO,+    Show,+    and,+    map,+    show,+  )++readSource :: FieldName -> IO ByteString+readSource = L.readFile . path . readName++path :: Text -> FilePath+path name = "test/" <> unpack name++gqlLib :: Text -> FilePath+gqlLib x = path x <> "/query.gql"++resLib :: Text -> FilePath+resLib x = path x <> "/response.json"++data FileUrl = FileUrl+  { filePath :: [FilePath],+    fileName :: FilePath+  }+  deriving (Show)++data CaseTree = CaseTree+  { caseUrl :: FileUrl,+    children :: Either [FilePath] [CaseTree]+  }+  deriving (Show)++prefix :: FileUrl -> FilePath -> FileUrl+prefix FileUrl {..} x =+  FileUrl+    { filePath = fileName : filePath,+      fileName = x+    }++toString :: FileUrl -> FilePath+toString FileUrl {..} = foldl (\y x -> x <> "/" <> y) fileName filePath++scanSchemaTests :: FilePath -> IO CaseTree+scanSchemaTests = deepScan++deepScan :: FilePath -> IO CaseTree+deepScan = shouldScan . FileUrl []+  where+    shouldScan :: FileUrl -> IO CaseTree+    shouldScan caseUrl = do+      children <- prefixed caseUrl+      pure CaseTree {..}+    isDirectory :: FileUrl -> IO Bool+    isDirectory = doesDirectoryExist . toString+    prefixed :: FileUrl -> IO (Either [FilePath] [CaseTree])+    prefixed p = do+      dir <- isDirectory p+      if dir+        then do+          list <- map (prefix p) <$> listDirectory (toString p)+          areDirectories <- traverse isDirectory list+          if and areDirectories+            then Right <$> traverse shouldScan list+            else pure $ Left []+        else pure $ Left []++maybeVariables :: FieldName -> IO (Maybe Value)+maybeVariables (FieldName x) = decode <$> (L.readFile (path x <> "/variables.json") <|> pure "{}")++getGQLBody :: FieldName -> IO ByteString+getGQLBody (FieldName p) = L.readFile (gqlLib p)++getCases :: FromJSON a => FilePath -> IO [a]+getCases dir = fromMaybe [] . decode <$> L.readFile ("test/" <> dir <> "/cases.json")++getSchema :: FieldName -> IO (Eventless (Schema VALID))+getSchema (FieldName x) = parseGQLDocument <$> L.readFile (path x <> "/schema.gql")++assertValidSchema :: FieldName -> IO (Schema VALID)+assertValidSchema = getSchema >=> resultOr failedSchema pure+  where+    failedSchema err = assertFailure ("unexpected schema validation error: \n " <> show err)++expectedResponse :: FieldName -> IO Value+expectedResponse (FieldName p) = fromMaybe Null . decode <$> L.readFile (resLib p)++getRequest :: FieldName -> IO GQLRequest+getRequest p = do+  queryBS <- LT.toStrict . decodeUtf8 <$> getGQLBody p+  variables <- maybeVariables p+  pure $+    GQLRequest+      { operationName = Nothing,+        query = queryBS,+        variables+      }++getResolvers :: Monad m => FieldName -> IO (RootResModel e m)+getResolvers p = getResolver ("test/" <> p <> "/resolvers.json")++getResolver :: Monad m => FieldName -> IO (RootResModel e m)+getResolver (FieldName p) = do+  res <- fromMaybe Null . decode <$> L.readFile (unpack p)+  pure+    RootResModel+      { query = pure (lookupRes "query" res),+        mutation = pure (lookupRes "mutation" res),+        subscription = pure (lookupRes "subscription" res),+        channelMap = Nothing+      }++lookupRes ::+  ( WithOperation o,+    Monad m+  ) =>+  Text ->+  Value ->+  ResModel o e m+lookupRes name (Object fields) = maybe mkNull mkValue (lookup name fields)+lookupRes _ _ = mkNull

@@ -2,9 +2,18 @@   "data": {     "deity": { "power": ["Shapeshifting"] },     "character": [-      { "name": "Test Deity" },-      { "name": "Test Hero" },-      { "name": "Test Character" }+      {+        "__typename": "Deity",+        "name": "Test Deity"+      },+      {+        "__typename": "Hero",+        "name": "Test Hero"+      },+      {+        "__typename": "Character",+        "name": "Test Character"+      }     ]   } }

@@ -2,14 +2,17 @@   "data": {     "character": [       {+        "__typename": "Deity",         "name": "Test Deity",         "power": ["Show Only on Deity"]       },       {+        "__typename": "Hero",         "name": "Test Hero",         "nickname": "tets Hero NickName"       },       {+        "__typename": "Character",         "name": "Test Character"       }     ]

@@ -2,14 +2,17 @@   "data": {     "character": [       {+        "__typename": "Deity",         "name": "Test Deity",         "power": ["Show Only on Deity"]       },       {+        "__typename": "Hero",         "name": "Test Hero",         "nickname": "tets Hero NickName"       },       {+        "__typename": "Character",         "name": "Test Character"       }     ]

@@ -2,9 +2,18 @@   "data": {     "deity": { "power": ["Shapeshifting"] },     "character": [-      { "name": "Test Deity" },-      { "name": "Test Hero" },-      { "name": "Test Character" }+      {+        "__typename": "Deity",+        "name": "Test Deity"+      },+      {+        "__typename": "Hero",+        "name": "Test Hero"+      },+      {+        "__typename": "Character",+        "name": "Test Character"+      }     ]   } }

@@ -0,0 +1,7 @@+type Query {+  name: String+}++type Mutation {+  name(i: Int): String+}

@@ -0,0 +1,8 @@+{+  "query": {+    "name": "query name from app"+  },+  "mutation": {+    "name": "mutation name from app"+  }+}

@@ -0,0 +1,12 @@+type Query {+  id: ID+  name: String+}++type Mutation {+  id: ID+}++type Subscription {+  name: String+}

@@ -0,0 +1,9 @@+{+  "query": {+    "name": "query name from ext",+    "id": "query id from ext"+  },+  "mutation": {+    "id": "mutation id from ext"+  }+}

@@ -0,0 +1,13 @@+type Query {+  name: String+  id: ID+}++type Mutation {+  name(i: Int): String+  id: ID+}++type Subscription {+  name: String+}

@@ -0,0 +1,4 @@+mutation {+  name+  id+}

@@ -0,0 +1,6 @@+{+  "data": {+    "name": "mutation name from app",+    "id": "mutation id from ext"+  }+}

@@ -0,0 +1,4 @@+query {+  name+  id+}

@@ -0,0 +1,6 @@+{+  "data": {+    "name": "query name from ext",+    "id": "query id from ext"+  }+}

@@ -0,0 +1,12 @@+type Type1 {+  name: String+}++type Type2 {+  name: String+  age: Int+}++type Query {+  type: Type2+}

@@ -0,0 +1,8 @@+{+  "query": {+    "type": {+      "name": "name from app",+      "age": 23+    }+  }+}

@@ -0,0 +1,9 @@+type Type2 {+  name: String+  id: ID+}++type Query {+  id: ID+  type: Type2+}

@@ -0,0 +1,9 @@+{+  "query": {+    "type": {+      "name": "name from ext",+      "id": "id from ext"+    },+    "id": "id from ext"+  }+}

@@ -0,0 +1,14 @@+type Type2 {+  name: String+  age: Int+  id: ID+}++type Type1 {+  name: String+}++type Query {+  type: Type2+  id: ID+}

@@ -0,0 +1,8 @@+query {+  id+  type {+    id+    name+    age+  }+}

@@ -0,0 +1,10 @@+{+  "data": {+    "id": "id from ext",+    "type": {+      "id": "id from ext",+      "name": "name from ext",+      "age": 23+    }+  }+}

@@ -5,7 +5,19 @@       "locations": []     },     {+      "message": "There can Be only One TypeDefinition for schema.\"query\"",+      "locations": []+    },+    {       "message": "There can Be only One TypeDefinition for schema.\"mutation\"",+      "locations": []+    },+    {+      "message": "There can Be only One TypeDefinition for schema.\"mutation\"",+      "locations": []+    },+    {+      "message": "There can Be only One TypeDefinition for schema.\"subscription\"",       "locations": []     },     {

@@ -7,6 +7,10 @@     {       "message": "There can Be only One TypeDefinition for schema.\"query\"",       "locations": []+    },+    {+      "message": "There can Be only One TypeDefinition for schema.\"query\"",+      "locations": []     }   ] }