morpheus-graphql-app 0.24.3 → 0.25.0

raw patch · 16 files changed

+516/−184 lines, 16 filesdep ~morpheus-graphql-coredep ~morpheus-graphql-testsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: morpheus-graphql-core, morpheus-graphql-tests

API changes (from Hackage documentation)

Files

• morpheus-graphql-app.cabal +8/−5
• src/Data/Morpheus/App/Internal/Resolving.hs +0/−2
• src/Data/Morpheus/App/Internal/Resolving/NamedResolver.hs +0/−44
• src/Data/Morpheus/App/Internal/Resolving/ResolveValue.hs +142/−27
• src/Data/Morpheus/App/Internal/Resolving/Resolver.hs +1/−10
• src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs +13/−18
• src/Data/Morpheus/App/Internal/Resolving/Types.hs +94/−3
• src/Data/Morpheus/App/Internal/Stitching.hs +7/−4
• src/Data/Morpheus/App/NamedResolvers.hs +5/−12
• test/APIConstraints.hs +8/−6
• test/Batching.hs +93/−0
• test/NamedResolvers.hs +66/−52
• test/Spec.hs +3/−1
• test/batching/deities.gql +14/−0
• test/batching/deities/query.gql +26/−0
• test/batching/deities/response.json +36/−0

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-app-version:        0.24.3+version:        0.25.0 synopsis:       Morpheus GraphQL App description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -42,6 +42,8 @@     test/api/validation/input-coercion/list/list-single/query.gql     test/api/validation/input-coercion/list/schema.gql     test/api/validation/input-coercion/list/signle-value/query.gql+    test/batching/deities.gql+    test/batching/deities/query.gql     test/merge/schema/query-subscription-mutation/app-1.gql     test/merge/schema/query-subscription-mutation/app-2.gql     test/merge/schema/query-subscription-mutation/mutation/query.gql@@ -86,6 +88,7 @@     test/api/validation/input-coercion/list/list-single/response.json     test/api/validation/input-coercion/list/resolvers.json     test/api/validation/input-coercion/list/signle-value/response.json+    test/batching/deities/response.json     test/merge/schema/query-subscription-mutation/app-1.json     test/merge/schema/query-subscription-mutation/app-2.json     test/merge/schema/query-subscription-mutation/mutation/response.json@@ -118,7 +121,6 @@       Data.Morpheus.Types.GQLWrapper   other-modules:       Data.Morpheus.App.Internal.Resolving.Event-      Data.Morpheus.App.Internal.Resolving.NamedResolver       Data.Morpheus.App.Internal.Resolving.Resolver       Data.Morpheus.App.Internal.Resolving.ResolverState       Data.Morpheus.App.Internal.Resolving.ResolveValue@@ -140,7 +142,7 @@     , containers >=0.4.2.1 && <0.7.0     , hashable >=1.0.0 && <2.0.0     , megaparsec >=7.0.0 && <10.0.0-    , morpheus-graphql-core >=0.24.0 && <0.25.0+    , morpheus-graphql-core >=0.25.0 && <0.26.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , scientific >=0.3.6.2 && <0.4.0@@ -157,6 +159,7 @@   main-is: Spec.hs   other-modules:       APIConstraints+      Batching       NamedResolvers       Paths_morpheus_graphql_app   hs-source-dirs:@@ -171,8 +174,8 @@     , hashable >=1.0.0 && <2.0.0     , megaparsec >=7.0.0 && <10.0.0     , morpheus-graphql-app-    , morpheus-graphql-core >=0.24.0 && <0.25.0-    , morpheus-graphql-tests >=0.24.0 && <0.25.0+    , morpheus-graphql-core >=0.25.0 && <0.26.0+    , morpheus-graphql-tests >=0.25.0 && <0.26.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , scientific >=0.3.6.2 && <0.4.0

@@ -5,7 +5,6 @@     LiftOperation,     runRootResolverValue,     lift,-    Failure,     ResponseEvent (..),     ResponseStream,     cleanEvents,@@ -16,7 +15,6 @@     PushEvents (..),     subscribe,     ResolverContext (..),-    unsafeInternalContext,     RootResolverValue (..),     resultOr,     withArguments,

@@ -1,44 +0,0 @@-module Data.Morpheus.App.Internal.Resolving.NamedResolver-  ( runResolverMap,-  )-where--import Data.Morpheus.App.Internal.Resolving.Event (EventHandler (Channel))-import Data.Morpheus.App.Internal.Resolving.ResolveValue-  ( resolveRef,-  )-import Data.Morpheus.App.Internal.Resolving.Resolver (LiftOperation, Resolver, ResponseStream, runResolver)-import Data.Morpheus.App.Internal.Resolving.ResolverState-  ( ResolverContext (..),-    ResolverState,-  )-import Data.Morpheus.App.Internal.Resolving.Types-  ( NamedResolverRef (..),-    ResolverMap,-  )-import Data.Morpheus.Types.Internal.AST-  ( Selection (..),-    SelectionContent (..),-    SelectionSet,-    TypeName,-    VALID,-    ValidValue,-    Value (..),-  )--runResolverMap ::-  (Monad m, LiftOperation o) =>-  Maybe (Selection VALID -> ResolverState (Channel e)) ->-  TypeName ->-  ResolverMap (Resolver o e m) ->-  ResolverContext ->-  SelectionSet VALID ->-  ResponseStream e m ValidValue-runResolverMap-  channels-  name-  res-  ctx-  selection = runResolver channels resolvedValue ctx-    where-      resolvedValue = resolveRef res (NamedResolverRef name Null) (SelectionSet selection)

@@ -2,6 +2,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.App.Internal.Resolving.ResolveValue@@ -18,14 +20,20 @@     updateCurrentType,   ) import Data.Morpheus.App.Internal.Resolving.Types-  ( NamedResolver (..),+  ( BatchEntry (..),+    CacheKey (..),+    LocalCache,+    NamedResolver (..),     NamedResolverRef (..),     NamedResolverResult (..),     ObjectTypeResolver (..),     ResolverMap,     ResolverValue (..),+    buildBatches,+    dumpCache,     mkEnum,     mkUnion,+    useCached,   ) import Data.Morpheus.Error (subfieldsNotSelected) import Data.Morpheus.Internal.Utils@@ -56,32 +64,93 @@   ) import Relude hiding (empty) +type ResolverMapContext m = (LocalCache, ResolverMap m)++scanRefs :: (MonadError GQLError m, MonadReader ResolverContext m) => SelectionContent VALID -> ResolverValue m -> m [(SelectionContent VALID, NamedResolverRef)]+scanRefs sel (ResList xs) = concat <$> traverse (scanRefs sel) xs+scanRefs sel (ResLazy x) = x >>= scanRefs sel+scanRefs sel (ResObject tyName obj) = withObject tyName (objectRefs obj) sel+scanRefs sel (ResRef ref) = pure . (sel,) <$> ref+scanRefs _ ResEnum {} = pure []+scanRefs _ ResNull = pure []+scanRefs _ ResScalar {} = pure []++objectRefs ::+  ( MonadError GQLError m,+    MonadReader ResolverContext m+  ) =>+  ObjectTypeResolver m ->+  Maybe (SelectionSet VALID) ->+  m [(SelectionContent VALID, NamedResolverRef)]+objectRefs _ Nothing = pure []+objectRefs dr (Just sel) = concat <$> traverse (fieldRefs dr) (toList sel)++fieldRefs ::+  (MonadError GQLError m, MonadReader ResolverContext m) =>+  ObjectTypeResolver m ->+  Selection VALID ->+  m [(SelectionContent VALID, NamedResolverRef)]+fieldRefs ObjectTypeResolver {..} currentSelection@Selection {..}+  | selectionName == "__typename" = pure []+  | otherwise = do+      t <- askFieldTypeName selectionName+      updateCurrentType t $+        local (\ctx -> ctx {currentSelection}) $ do+          x <- maybe (pure []) (fmap pure) (HM.lookup selectionName objectFields)+          concat <$> traverse (scanRefs selectionContent) x+ resolveSelection ::   ( Monad m,     MonadReader ResolverContext m,     MonadError GQLError m   ) =>-  ResolverMap m ->+  ResolverMapContext m ->   ResolverValue m ->   SelectionContent VALID ->   m ValidValue-resolveSelection rmap (ResLazy x) selection =+resolveSelection rmap res selection = do+  newRmap <- scanRefs selection res >>= buildCache rmap . buildBatches+  __resolveSelection newRmap res selection++buildCache :: (MonadError GQLError m, MonadReader ResolverContext m) => ResolverMapContext m -> [BatchEntry] -> m (LocalCache, ResolverMap m)+buildCache (cache, rmap) entries = do+  caches <- traverse (resolveCacheEntry (cache, rmap)) entries+  let newCache = foldr (<>) cache caches+  pure $ dumpCache False (newCache, rmap)++resolveCacheEntry :: (MonadError GQLError m, MonadReader ResolverContext m) => ResolverMapContext m -> BatchEntry -> m LocalCache+resolveCacheEntry rmap (BatchEntry sel name deps) = do+  res <- resolveRefsCached rmap (NamedResolverRef name deps) sel+  let keys = map (CacheKey sel name) deps+  let entries = zip keys res+  pure $ HM.fromList entries++__resolveSelection ::+  ( Monad m,+    MonadReader ResolverContext m,+    MonadError GQLError m+  ) =>+  ResolverMapContext m ->+  ResolverValue m ->+  SelectionContent VALID ->+  m ValidValue+__resolveSelection rmap (ResLazy x) selection =   x >>= flip (resolveSelection rmap) selection-resolveSelection rmap (ResList xs) selection =+__resolveSelection rmap (ResList xs) selection =   List <$> traverse (flip (resolveSelection rmap) selection) xs -- Object ------------------resolveSelection rmap (ResObject tyName obj) sel = withObject tyName (resolveObject rmap obj) sel+__resolveSelection rmap (ResObject tyName obj) sel = withObject tyName (resolveObject rmap obj) sel -- ENUM-resolveSelection _ (ResEnum name) SelectionField = pure $ Scalar $ String $ unpackName name-resolveSelection rmap (ResEnum name) unionSel@UnionSelection {} =+__resolveSelection _ (ResEnum name) SelectionField = pure $ Scalar $ String $ unpackName name+__resolveSelection rmap (ResEnum name) unionSel@UnionSelection {} =   resolveSelection rmap (mkUnion name [(unitFieldName, pure $ mkEnum unitTypeName)]) unionSel-resolveSelection _ ResEnum {} _ = throwError (internal "wrong selection on enum value")+__resolveSelection _ ResEnum {} _ = throwError (internal "wrong selection on enum value") -- SCALARS-resolveSelection _ ResNull _ = pure Null-resolveSelection _ (ResScalar x) SelectionField = pure $ Scalar x-resolveSelection _ ResScalar {} _ =+__resolveSelection _rmap ResNull _ = pure Null+__resolveSelection _rmap (ResScalar x) SelectionField = pure $ Scalar x+__resolveSelection _rmap ResScalar {} _ =   throwError (internal "scalar Resolver should only receive SelectionField")-resolveSelection rmap (ResRef ref) sel = ref >>= flip (resolveRef rmap) sel+__resolveSelection rmap (ResRef ref) sel = ref >>= flip (resolveRef rmap) sel  withObject ::   ( MonadError GQLError m,@@ -112,49 +181,95 @@   ( MonadError GQLError m,     MonadReader ResolverContext m   ) =>-  ResolverMap m ->+  (LocalCache, ResolverMap m) ->   NamedResolverRef ->   SelectionContent VALID ->   m ValidValue-resolveRef rmap ref selection = do-  namedResolver <- getNamedResolverBy ref rmap-  case namedResolver of-    NamedObjectResolver res -> withObject (Just (resolverTypeName ref)) (resolveObject rmap res) selection-    NamedUnionResolver unionRef -> resolveSelection rmap (ResRef $ pure unionRef) selection-    NamedEnumResolver value -> resolveSelection rmap (ResEnum value) selection+resolveRef rmap ref selection = resolveRefsCached rmap ref selection >>= toOne +toOne :: (MonadError GQLError f) => [a] -> f a+toOne [x] = pure x+toOne _ = throwError (internal "TODO:")++resolveRefsCached ::+  ( MonadError GQLError m,+    MonadReader ResolverContext m+  ) =>+  ResolverMapContext m ->+  NamedResolverRef ->+  SelectionContent VALID ->+  m [ValidValue]+resolveRefsCached (cache, rmap) (NamedResolverRef name args) selection = do+  let keys = map (CacheKey selection name) args+  let cached = map resolveCached keys+  let cachedMap = HM.fromList (mapMaybe unp cached)+  notCachedMap <- resolveUncached (cache, rmap) name selection $ map fst $ filter (isNothing . snd) cached+  traverse (useCached (cachedMap <> notCachedMap)) args+  where+    unp (_, Nothing) = Nothing+    unp (x, Just y) = Just (x, y)+    resolveCached key = (cachedArg key, HM.lookup key cache)++processResult ::+  (MonadError GQLError m, MonadReader ResolverContext m) =>+  ResolverMapContext m ->+  TypeName ->+  SelectionContent VALID ->+  NamedResolverResult m ->+  m ValidValue+processResult rmap typename selection (NamedObjectResolver res) = withObject (Just typename) (resolveObject rmap res) selection+processResult rmap _ selection (NamedUnionResolver unionRef) = resolveSelection rmap (ResRef $ pure unionRef) selection+processResult rmap _ selection (NamedEnumResolver value) = resolveSelection rmap (ResEnum value) selection+processResult rmap _ selection NamedNullResolver = resolveSelection rmap ResNull selection++resolveUncached ::+  ( MonadError GQLError m,+    MonadReader ResolverContext m+  ) =>+  (LocalCache, ResolverMap m) ->+  TypeName ->+  SelectionContent VALID ->+  [ValidValue] ->+  m (HashMap ValidValue ValidValue)+resolveUncached _ _ _ [] = pure empty+resolveUncached rmap typename selection xs = do+  vs <- getNamedResolverBy (NamedResolverRef typename xs) (snd rmap) >>= traverse (processResult rmap typename selection)+  pure $ HM.fromList (zip xs vs)+ getNamedResolverBy ::   (MonadError GQLError m) =>   NamedResolverRef ->   ResolverMap m ->-  m (NamedResolverResult m)-getNamedResolverBy ref = selectOr cantFoundError ((resolverArgument ref &) . resolver) (resolverTypeName ref)+  m [NamedResolverResult m]+getNamedResolverBy NamedResolverRef {..} = selectOr cantFoundError ((resolverArgument &) . resolverFun) resolverTypeName   where-    cantFoundError = throwError ("Resolver Type " <> msg (resolverTypeName ref) <> "can't found")+    cantFoundError = throwError ("Resolver Type " <> msg resolverTypeName <> "can't found")  resolveObject ::   ( MonadReader ResolverContext m,     MonadError GQLError m   ) =>-  ResolverMap m ->+  (LocalCache, ResolverMap m) ->   ObjectTypeResolver m ->   Maybe (SelectionSet VALID) ->   m ValidValue-resolveObject rmap drv = fmap Object . maybe (pure empty) (traverseCollection resolver)+resolveObject rmap drv sel = do+  newCache <- objectRefs drv sel >>= buildCache rmap . buildBatches+  Object <$> maybe (pure empty) (traverseCollection (resolver newCache)) sel   where-    resolver currentSelection = do+    resolver newCache currentSelection = do       t <- askFieldTypeName (selectionName currentSelection)       updateCurrentType t $         local (\ctx -> ctx {currentSelection}) $           ObjectEntry (keyOf currentSelection)-            <$> runFieldResolver rmap currentSelection drv+            <$> runFieldResolver newCache currentSelection drv  runFieldResolver ::   ( Monad m,     MonadReader ResolverContext m,     MonadError GQLError m   ) =>-  ResolverMap m ->+  (LocalCache, ResolverMap m) ->   Selection VALID ->   ObjectTypeResolver m ->   m ValidValue

@@ -25,7 +25,6 @@     ResponseStream,     WithOperation,     ResolverContext (..),-    unsafeInternalContext,     withArguments,     getArguments,     SubscriptionField (..),@@ -171,14 +170,6 @@   local f (ResolverM res) = ResolverM (local f res)   local f (ResolverS resM) = ResolverS $ mapReaderT (local f) <$> resM --- | A function to return the internal 'ResolverContext' within a resolver's monad.--- Using the 'ResolverContext' itself is unsafe because it exposes internal structures--- of the AST, but you can use the "Data.Morpheus.Types.SelectionTree" typeClass to manipulate--- the internal AST with a safe interface.-{-# DEPRECATED unsafeInternalContext "use asks" #-}-unsafeInternalContext :: (Monad m, LiftOperation o) => Resolver o e m ResolverContext-unsafeInternalContext = ask- liftResolverState :: (LiftOperation o, Monad m) => ResolverState a -> Resolver o e m a liftResolverState = packResolver . toResolverStateT @@ -216,7 +207,7 @@ getArguments ::   (LiftOperation o, Monad m) =>   Resolver o e m (Arguments VALID)-getArguments = selectionArguments . currentSelection <$> unsafeInternalContext+getArguments = asks (selectionArguments . currentSelection)  getArgument ::   (LiftOperation o, Monad m) =>

@@ -14,7 +14,6 @@ import Data.Morpheus.App.Internal.Resolving.Event   ( EventHandler (..),   )-import Data.Morpheus.App.Internal.Resolving.NamedResolver (runResolverMap) import Data.Morpheus.App.Internal.Resolving.ResolveValue import Data.Morpheus.App.Internal.Resolving.Resolver   ( LiftOperation,@@ -34,6 +33,9 @@   ( lookupResJSON,   ) import Data.Morpheus.Internal.Ext (merge)+import Data.Morpheus.Internal.Utils+  ( empty,+  ) import Data.Morpheus.Types.Internal.AST   ( GQLError,     MUTATION,@@ -42,6 +44,7 @@     QUERY,     SUBSCRIPTION,     Selection,+    SelectionContent (SelectionSet),     SelectionSet,     VALID,     ValidValue,@@ -103,35 +106,27 @@     selectByOperation operationType     where       selectByOperation Query =-        withIntrospection (runRootDataResolver channelMap queryResolver) ctx+        withIntrospection (runRootDataResolver channelMap queryResolver ctx) ctx       selectByOperation Mutation =         runRootDataResolver channelMap mutationResolver ctx operationSelection       selectByOperation Subscription =         runRootDataResolver channelMap subscriptionResolver ctx operationSelection runRootResolverValue-  NamedResolversValue-    { queryResolverMap-    -- mutationResolverMap,-    -- subscriptionResolverMap,-    -- typeResolverChannels-    }+  NamedResolversValue {queryResolverMap}   ctx@ResolverContext {operation = Operation {operationType}} =     selectByOperation operationType     where-      selectByOperation Query = withIntrospection (runResolverMap Nothing "Query" queryResolverMap) ctx-      -- TODO: support mutation and subscription-      -- selectByOperation Mutation =-      --   runResolverMap typeResolverChannels "Mutation" ctx mutationResolverMap-      -- selectByOperation Subscription =-      --   runResolverMap typeResolverChannels "Subscription" ctx subscriptionResolverMap-      selectByOperation _ = throwError "mutation and subscription is not yet supported"+      selectByOperation Query = withIntrospection (\sel -> runResolver Nothing (resolvedValue sel) ctx) ctx+        where+          resolvedValue selection = resolveRef (empty, queryResolverMap) (NamedResolverRef "Query" ["ROOT"]) (SelectionSet selection)+      selectByOperation _ = throwError "mutation and subscription is not supported for namedResolvers" -withIntrospection :: Monad m => (ResolverContext -> SelectionSet VALID -> ResponseStream event m ValidValue) -> ResolverContext -> ResponseStream event m ValidValue+withIntrospection :: Monad m => (SelectionSet VALID -> ResponseStream event m ValidValue) -> ResolverContext -> ResponseStream event m ValidValue withIntrospection f ctx@ResolverContext {operation} = case splitSystemSelection (operationSelection operation) of-  (Nothing, _) -> f ctx (operationSelection operation)+  (Nothing, _) -> f (operationSelection operation)   (Just intro, Nothing) -> introspection intro ctx   (Just intro, Just selection) -> do-    x <- f ctx selection+    x <- f selection     y <- introspection intro ctx     mergeRoot y x 

@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -8,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -30,29 +32,90 @@     mkObject,     mkObjectMaybe,     mkUnion,+    NamedResolverFun,+    buildBatches,+    Cache,+    CacheKey (..),+    BatchEntry (..),+    LocalCache,+    dumpCache,+    useCached,   ) where  import Control.Monad.Except (MonadError (throwError))+import Data.ByteString.Lazy.Char8 (unpack) import qualified Data.HashMap.Lazy as HM+import Data.Morpheus.Core (RenderGQL, render) import Data.Morpheus.Internal.Ext (Merge (..)) import Data.Morpheus.Internal.Utils (KeyOf (keyOf)) import Data.Morpheus.Types.Internal.AST   ( FieldName,     GQLError,     ScalarValue (..),+    SelectionContent,     TypeName,+    VALID,     ValidValue,     internal,   ) import GHC.Show (Show (show)) import Relude hiding (show) +type LocalCache = HashMap CacheKey ValidValue++useCached :: (Eq k, Hashable k, MonadError GQLError f) => HashMap k a -> k -> f a+useCached mp v = case HM.lookup v mp of+  Just x -> pure x+  Nothing -> throwError (internal "TODO:")++dumpCache :: Bool -> (LocalCache, ResolverMap m) -> (LocalCache, ResolverMap m)+dumpCache enabled xs+  | null (fst xs) || not enabled = xs+  | otherwise = trace ("\nCACHE:\n" <> intercalate "\n" (map printKeyValue $ HM.toList $ fst xs) <> "\n") xs+  where+    printKeyValue (key, v) = " " <> show key <> ": " <> unpack (render v)++printSel :: RenderGQL a => a -> [Char]+printSel sel = map replace $ filter ignoreSpaces $ unpack (render sel)+  where+    ignoreSpaces x = x /= ' '+    replace '\n' = ' '+    replace x = x++data BatchEntry = BatchEntry+  { batchedSelection :: SelectionContent VALID,+    batchedType :: TypeName,+    batchedArguments :: [ValidValue]+  }++instance Show BatchEntry where+  show (BatchEntry sel typename dep) = printSel sel <> ":" <> toString typename <> ":" <> show (map (unpack . render) dep)++data CacheKey = CacheKey+  { cachedSel :: SelectionContent VALID,+    cachedTypeName :: TypeName,+    cachedArg :: ValidValue+  }+  deriving (Eq, Generic)++instance Show CacheKey where+  show (CacheKey sel typename dep) = printSel sel <> ":" <> toString typename <> ":" <> unpack (render dep)++instance Hashable CacheKey where+  hashWithSalt s (CacheKey sel tyName arg) = hashWithSalt s (sel, tyName, render arg)++type Cache m = HashMap CacheKey (NamedResolverResult m)+ type ResolverMap (m :: Type -> Type) = HashMap TypeName (NamedResolver m) +type NamedResolverArg = [ValidValue]++type NamedResolverFun m = NamedResolverArg -> m [NamedResolverResult m]+ data NamedResolver (m :: Type -> Type) = NamedResolver   { resolverName :: TypeName,-    resolver :: ValidValue -> m (NamedResolverResult m)+    resolverFun :: NamedResolverFun m   }  instance Show (NamedResolver m) where@@ -68,18 +131,40 @@  data NamedResolverRef = NamedResolverRef   { resolverTypeName :: TypeName,-    resolverArgument :: ValidValue+    resolverArgument :: NamedResolverArg   }   deriving (Show) +uniq :: (Eq a, Hashable a) => [a] -> [a]+uniq = HM.keys . HM.fromList . map (,True)++buildBatches :: [(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry]+buildBatches inputs =+  let entityTypes = uniq $ map (second resolverTypeName) inputs+   in mapMaybe (selectByEntity inputs) entityTypes++selectByEntity :: [(SelectionContent VALID, NamedResolverRef)] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry+selectByEntity inputs (tSel, tName) = case filter areEq inputs of+  [] -> Nothing+  xs -> Just $ BatchEntry tSel tName (uniq $ concatMap (resolverArgument . snd) xs)+  where+    areEq (sel, v) = sel == tSel && tName == resolverTypeName v+ data NamedResolverResult (m :: Type -> Type)   = NamedObjectResolver (ObjectTypeResolver m)   | NamedUnionResolver NamedResolverRef   | NamedEnumResolver TypeName+  | NamedNullResolver  instance KeyOf TypeName (NamedResolver m) where   keyOf = resolverName +instance Show (NamedResolverResult m) where+  show NamedObjectResolver {} = "NamedObjectResolver"+  show NamedUnionResolver {} = "NamedUnionResolver"+  show NamedEnumResolver {} = "NamedEnumResolver"+  show NamedNullResolver {} = "NamedNullResolver"+ data ResolverValue (m :: Type -> Type)   = ResNull   | ResScalar ScalarValue@@ -102,7 +187,13 @@       mergeFields a b = (,) <$> a <*> b >>= uncurry merge  instance Show (ResolverValue m) where-  show _ = "ResolverValue {}"+  show ResNull = "ResNull"+  show (ResScalar x) = "ResScalar:" <> show x+  show (ResList xs) = "ResList:" <> show xs+  show (ResEnum name) = "ResEnum:" <> show name+  show (ResObject name _) = "ResObject:" <> show name+  show ResRef {} = "ResRef {}"+  show ResLazy {} = "ResLazy {}"  instance IsString (ResolverValue m) where   fromString = ResScalar . fromString

@@ -143,6 +143,8 @@   stitch NamedEnumResolver {} (NamedEnumResolver x) = pure (NamedEnumResolver x)   stitch NamedUnionResolver {} (NamedUnionResolver x) = pure (NamedUnionResolver x)   stitch (NamedObjectResolver t1) (NamedObjectResolver t2) = NamedObjectResolver <$> stitch t1 t2+  stitch NamedNullResolver x = pure x+  stitch x NamedNullResolver = pure x   stitch _ _ = throwError "ResolverMap must have same Kind"  instance (MonadError GQLError m) => Stitching (NamedResolver m) where@@ -151,10 +153,11 @@         pure           NamedResolver             { resolverName = resolverName t1,-              resolver = \arg -> do-                t1' <- resolver t1 arg-                t2' <- resolver t2 arg-                stitch t1' t2'+              resolverFun = \arg -> do+                t1' <- resolverFun t1 arg+                t2' <- resolverFun t2 arg+                let xs = zip t1' t2'+                traverse (uncurry stitch) xs             }     | otherwise = throwError "ResolverMap must have same resolverName" 

@@ -43,12 +43,12 @@ list = mkList  ref :: Applicative m => TypeName -> ValidValue -> ResolverValue m-ref typeName = ResRef . pure . NamedResolverRef typeName+ref typeName = ResRef . pure . NamedResolverRef typeName . pure  refs :: Applicative m => TypeName -> [ValidValue] -> ResolverValue m refs typeName = mkList . map (ref typeName) -type NamedResolverFunction o e m = ValidValue -> Resolver o e m (ResultBuilder o e m)+type NamedResolverFunction o e m = [ValidValue] -> Resolver o e m [ResultBuilder o e m]  -- types object :: (LiftOperation o, Monad m) => [(FieldName, Resolver o e m (ResolverValue (Resolver o e m)))] -> Resolver o e m (ResultBuilder o e m)@@ -68,15 +68,8 @@ mkResolverMap :: (LiftOperation o, Monad m) => [(TypeName, NamedResolverFunction o e m)] -> ResolverMap (Resolver o e m) mkResolverMap = HM.fromList . map packRes   where-    packRes :: (LiftOperation o, Monad m) => (TypeName, ValidValue -> Resolver o e m (ResultBuilder o e m)) -> (TypeName, NamedResolver (Resolver o e m))-    packRes (typeName, value) =-      ( typeName,-        NamedResolver-          typeName-          ( fmap mapValue-              . value-          )-      )+    packRes :: (LiftOperation o, Monad m) => (TypeName, NamedResolverFunction o e m) -> (TypeName, NamedResolver (Resolver o e m))+    packRes (typeName, f) = (typeName, NamedResolver typeName (fmap (map mapValue) . f))       where         mapValue (Object x) = NamedObjectResolver (ObjectTypeResolver $ HM.fromList x)-        mapValue (Union name x) = NamedUnionResolver (NamedResolverRef name x)+        mapValue (Union name x) = NamedUnionResolver (NamedResolverRef name [x])

@@ -48,12 +48,14 @@ resolvers =   queryResolvers     [ ( "Query",-        const $-          object-            [ ("success", pure "success"),-              ("forbidden", pure "forbidden!"),-              ("limited", pure "num <= 5")-            ]+        traverse+          ( const $+              object+                [ ("success", pure "success"),+                  ("forbidden", pure "forbidden!"),+                  ("limited", pure "num <= 5")+                ]+          )       )     ] 

@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Batching+  ( runBatchingTest,+  )+where++import Data.ByteString.Lazy.Char8 (unpack)+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Morpheus.App+  ( App (..),+    mkApp,+    runApp,+  )+import Data.Morpheus.App.Internal.Resolving (resultOr)+import Data.Morpheus.App.NamedResolvers+  ( NamedResolverFunction,+    RootResolverValue,+    enum,+    getArgument,+    list,+    object,+    queryResolvers,+    ref,+    refs,+  )+import Data.Morpheus.Core+  ( parseSchema,+    render,+  )+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+    GQLResponse,+  )+import Data.Morpheus.Types.Internal.AST (QUERY, Schema, VALID)+import Relude hiding (ByteString)+import Test.Morpheus+  ( FileUrl,+    testApi,+  )+import Test.Tasty+  ( TestTree,+  )++-- DEITIES++debugArgs :: String -> NamedResolverFunction QUERY e m -> NamedResolverFunction QUERY e m+debugArgs name f args = trace (name <> ":: " <> intercalate ", " (map (unpack . render) args)) (f args)++deityResolver :: Monad m => NamedResolverFunction QUERY e m+deityResolver = debugArgs "DEITY" (traverse getDeity)+  where+    getDeity "zeus" =+      object+        [ ("name", pure "Zeus"),+          ("power", pure $ list [])+        ]+    getDeity _ =+      object+        [ ("name", pure "Morpheus"),+          ("power", pure $ list [enum "Shapeshifting"])+        ]++resolveQuery :: Monad m => NamedResolverFunction QUERY e m+resolveQuery = debugArgs "QUERY" (traverse _resolveQuery)+  where+    _resolveQuery _ =+      object+        [ ("deity", ref "Deity" <$> getArgument "id"),+          ("deities", pure $ refs "Deity" ["zeus", "morpheus"])+        ]++resolvers :: Monad m => RootResolverValue e m+resolvers =+  queryResolvers+    [ ("Query", resolveQuery),+      ("Deity", deityResolver)+    ]++getSchema :: String -> IO (Schema VALID)+getSchema url = LBS.readFile url >>= resultOr (fail . show) pure . parseSchema++getApps :: FileUrl -> IO (App e IO)+getApps _ = do+  schemaDeities <- getSchema "test/named-resolvers/deities.gql"+  pure $ mkApp schemaDeities resolvers++runBatchingTest :: FileUrl -> FileUrl -> TestTree+runBatchingTest url = testApi api+  where+    api :: GQLRequest -> IO GQLResponse+    api req = getApps url >>= (`runApp` req)

@@ -51,88 +51,102 @@ resolverDeities =   queryResolvers     [ ( "Query",-        const $-          object-            [ ("deity", ref "Deity" <$> getArgument "id"),-              ("deities", pure $ refs "Deity" ["zeus", "morpheus"])-            ]+        traverse+          ( const $+              object+                [ ("deity", ref "Deity" <$> getArgument "id"),+                  ("deities", pure $ refs "Deity" ["zeus", "morpheus"])+                ]+          )       ),       ("Deity", deityResolver)     ]  deityResolver :: Monad m => NamedResolverFunction QUERY e m-deityResolver "zeus" =-  object-    [ ("name", pure "Zeus"),-      ("power", pure $ list [])-    ]-deityResolver _ =-  object-    [ ("name", pure "Morpheus"),-      ("power", pure $ list [enum "Shapeshifting"])-    ]+deityResolver = traverse deityRes+  where+    deityRes "zeus" =+      object+        [ ("name", pure "Zeus"),+          ("power", pure $ list [])+        ]+    deityRes _ =+      object+        [ ("name", pure "Morpheus"),+          ("power", pure $ list [enum "Shapeshifting"])+        ]  -- REALMS resolverRealms :: Monad m => RootResolverValue e m resolverRealms =   queryResolvers     [ ( "Query",-        const $-          object-            [ ("realm", ref "Realm" <$> getArgument "id"),-              ("realms", pure $ refs "Realm" ["olympus", "dreams"])-            ]+        traverse+          ( const $+              object+                [ ("realm", ref "Realm" <$> getArgument "id"),+                  ("realms", pure $ refs "Realm" ["olympus", "dreams"])+                ]+          )       ),       ("Deity", deityResolverExt),       ("Realm", realmResolver)     ]  deityResolverExt :: Monad m => NamedResolverFunction QUERY e m-deityResolverExt "zeus" = object [("realm", pure $ ref "Realm" "olympus")]-deityResolverExt "morpheus" = object [("realm", pure $ ref "Realm" "dreams")]-deityResolverExt _ = object []+deityResolverExt = traverse deityExt+  where+    deityExt "zeus" = object [("realm", pure $ ref "Realm" "olympus")]+    deityExt "morpheus" = object [("realm", pure $ ref "Realm" "dreams")]+    deityExt _ = object []  realmResolver :: Monad m => NamedResolverFunction QUERY e m-realmResolver "olympus" =-  object-    [ ("name", pure "Mount Olympus"),-      ("owner", pure $ ref "Deity" "zeus")-    ]-realmResolver "dreams" =-  object-    [ ("name", pure "Fictional world of dreams"),-      ("owner", pure $ ref "Deity" "morpheus")-    ]-realmResolver _ =-  object-    [ ("name", pure "None")-    ]+realmResolver = traverse realmResolver'+  where+    realmResolver' "olympus" =+      object+        [ ("name", pure "Mount Olympus"),+          ("owner", pure $ ref "Deity" "zeus")+        ]+    realmResolver' "dreams" =+      object+        [ ("name", pure "Fictional world of dreams"),+          ("owner", pure $ ref "Deity" "morpheus")+        ]+    realmResolver' _ =+      object+        [ ("name", pure "None")+        ]  -- ENTITIES resolverEntities :: Monad m => RootResolverValue e m resolverEntities =   queryResolvers     [ ( "Query",-        const $-          object-            [ ("entity", ref "Entity" <$> getArgument "id"),-              ( "entities",-                pure $-                  refs-                    "Entity"-                    ["zeus", "morpheus", "olympus", "dreams"]-              )-            ]+        traverse+          ( const $+              object+                [ ("entity", ref "Entity" <$> getArgument "id"),+                  ( "entities",+                    pure $+                      refs+                        "Entity"+                        ["zeus", "morpheus", "olympus", "dreams"]+                  )+                ]+          )       ),       ("Entity", resolveEntity)     ]  resolveEntity :: Monad m => NamedResolverFunction QUERY e m-resolveEntity "zeus" = variant "Deity" "zeus"-resolveEntity "morpheus" = variant "Deity" "morpheus"-resolveEntity "olympus" = variant "Realm" "olympus"-resolveEntity "dreams" = variant "Realm" "dreams"-resolveEntity _ = object []+resolveEntity = traverse resEntity+  where+    resEntity "zeus" = variant "Deity" "zeus"+    resEntity "morpheus" = variant "Deity" "morpheus"+    resEntity "olympus" = variant "Realm" "olympus"+    resEntity "dreams" = variant "Realm" "dreams"+    resEntity _ = object []  getSchema :: String -> IO (Schema VALID) getSchema url = LBS.readFile url >>= resultOr (fail . show) pure . parseSchema

@@ -8,6 +8,7 @@ where  import APIConstraints (runAPIConstraints)+import Batching (runBatchingTest) import Data.Morpheus.App   ( App (..),     eitherSchema,@@ -64,5 +65,6 @@     [ deepScan runMergeTest (mkUrl "merge"),       deepScan runApiTest (mkUrl "api"),       deepScan (map . runNamedResolversTest) (mkUrl "named-resolvers"),-      deepScan (map . runAPIConstraints) (mkUrl "api-constraints")+      deepScan (map . runAPIConstraints) (mkUrl "api-constraints"),+      deepScan (map . runBatchingTest) (mkUrl "batching")     ]

@@ -0,0 +1,14 @@+enum Power {+  Shapeshifting+  Thunderbolt+}++type Deity {+  name: String!+  power: [String!]+}++type Query {+  deities: [Deity!]!+  deity(id: ID): Deity+}

@@ -0,0 +1,26 @@+query {+  deities {+    name+    power+  }++  heroes: deities {+    name+    power+  }++  cronos: deity(id: "cronos") {+    name+    power+  }++  poseidon: deity(id: "poseidon") {+    name+    power+  }++  morpheus: deity(id: "morpheus") {+    name+    power+  }+}

@@ -0,0 +1,36 @@+{+  "data": {+    "poseidon": {+      "name": "Morpheus",+      "power": ["Shapeshifting"]+    },+    "morpheus": {+      "name": "Morpheus",+      "power": ["Shapeshifting"]+    },+    "heroes": [+      {+        "name": "Zeus",+        "power": []+      },+      {+        "name": "Morpheus",+        "power": ["Shapeshifting"]+      }+    ],+    "cronos": {+      "name": "Morpheus",+      "power": ["Shapeshifting"]+    },+    "deities": [+      {+        "name": "Zeus",+        "power": []+      },+      {+        "name": "Morpheus",+        "power": ["Shapeshifting"]+      }+    ]+  }+}