morpheus-graphql-app 0.27.0 → 0.27.1

raw patch · 25 files changed

+774/−561 lines, 25 filesdep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• morpheus-graphql-app.cabal +12/−3
• src/Data/Morpheus/App/Internal/Resolving.hs +3/−5
• src/Data/Morpheus/App/Internal/Resolving/Batching.hs +112/−86
• src/Data/Morpheus/App/Internal/Resolving/Cache.hs +114/−0
• src/Data/Morpheus/App/Internal/Resolving/Event.hs +1/−2
• src/Data/Morpheus/App/Internal/Resolving/MonadResolver.hs +85/−0
• src/Data/Morpheus/App/Internal/Resolving/Refs.hs +48/−0
• src/Data/Morpheus/App/Internal/Resolving/ResolveValue.hs +51/−221
• src/Data/Morpheus/App/Internal/Resolving/Resolver.hs +30/−74
• src/Data/Morpheus/App/Internal/Resolving/ResolverState.hs +13/−1
• src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs +37/−54
• src/Data/Morpheus/App/Internal/Resolving/SchemaAPI.hs +16/−8
• src/Data/Morpheus/App/Internal/Resolving/Types.hs +4/−2
• src/Data/Morpheus/App/Internal/Resolving/Utils.hs +52/−19
• src/Data/Morpheus/App/NamedResolvers.hs +19/−10
• src/Data/Morpheus/App/RenderIntrospection.hs +21/−61
• src/Data/Morpheus/Types/GQLWrapper.hs +18/−13
• test/Batching.hs +3/−1
• test/Execution.hs +95/−0
• test/Spec.hs +3/−1
• test/execution/many/query.gql +5/−0
• test/execution/many/response.json +12/−0
• test/execution/schema.gql +8/−0
• test/execution/single/query.gql +5/−0
• test/execution/single/response.json +7/−0

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-app-version:        0.27.0+version:        0.27.1 synopsis:       Morpheus GraphQL App description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -46,6 +46,9 @@     test/batching/objects-fields/query.gql     test/batching/objects-lists-fields/query.gql     test/batching/schema.gql+    test/execution/many/query.gql+    test/execution/schema.gql+    test/execution/single/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@@ -96,6 +99,8 @@     test/batching/objects-fields/response.json     test/batching/objects-lists-fields/batching.json     test/batching/objects-lists-fields/response.json+    test/execution/many/response.json+    test/execution/single/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@@ -128,7 +133,10 @@       Data.Morpheus.Types.GQLWrapper   other-modules:       Data.Morpheus.App.Internal.Resolving.Batching+      Data.Morpheus.App.Internal.Resolving.Cache       Data.Morpheus.App.Internal.Resolving.Event+      Data.Morpheus.App.Internal.Resolving.MonadResolver+      Data.Morpheus.App.Internal.Resolving.Refs       Data.Morpheus.App.Internal.Resolving.Resolver       Data.Morpheus.App.Internal.Resolving.ResolverState       Data.Morpheus.App.Internal.Resolving.ResolveValue@@ -155,7 +163,7 @@     , relude >=0.3.0 && <2.0.0     , scientific >=0.3.6.2 && <0.4.0     , template-haskell >=2.0.0 && <3.0.0-    , text >=1.2.3 && <1.3.0+    , text >=1.2.3 && <2.1.0     , th-lift-instances >=0.1.1 && <0.3.0     , transformers >=0.3.0 && <0.6.0     , unordered-containers >=0.2.8 && <0.3.0@@ -168,6 +176,7 @@   other-modules:       APIConstraints       Batching+      Execution       NamedResolvers       Paths_morpheus_graphql_app   hs-source-dirs:@@ -190,7 +199,7 @@     , tasty >=0.1.0 && <1.5.0     , tasty-hunit >=0.1.0 && <1.0.0     , template-haskell >=2.0.0 && <3.0.0-    , text >=1.2.3 && <1.3.0+    , text >=1.2.3 && <2.1.0     , th-lift-instances >=0.1.1 && <0.3.0     , transformers >=0.3.0 && <0.6.0     , unordered-containers >=0.2.8 && <0.3.0

@@ -4,7 +4,6 @@   ( Resolver,     LiftOperation,     runRootResolverValue,-    lift,     ResponseEvent (..),     ResponseStream,     cleanEvents,@@ -13,12 +12,10 @@     ObjectTypeResolver (..),     WithOperation,     PushEvents (..),-    subscribe,     ResolverContext (..),     RootResolverValue (..),     resultOr,     withArguments,-    -- Dynamic Resolver     mkBoolean,     mkFloat,     mkInt,@@ -30,9 +27,9 @@     mkUnion,     mkObject,     SubscriptionField (..),-    getArguments,     ResolverState,-    liftResolverState,+    MonadResolver (..),+    MonadIOResolver,     ResolverEntry,     sortErrors,     EventHandler (..),@@ -45,6 +42,7 @@ where  import Data.Morpheus.App.Internal.Resolving.Event+import Data.Morpheus.App.Internal.Resolving.MonadResolver import Data.Morpheus.App.Internal.Resolving.Resolver import Data.Morpheus.App.Internal.Resolving.ResolverState import Data.Morpheus.App.Internal.Resolving.RootResolverValue

@@ -1,11 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -17,23 +17,41 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.App.Internal.Resolving.Batching-  ( CacheKey (..),-    LocalCache,-    useCached,-    buildCacheWith,-    ResolverMapContext (..),-    ResolverMapT (..),-    runResMapT,+  ( ResolverMapT (..),+    SelectionRef,+    runBatchedT,+    MonadBatching (..),   ) where  import Control.Monad.Except (MonadError (throwError)) import Data.ByteString.Lazy.Char8 (unpack)-import qualified Data.HashMap.Lazy as HM-import Data.Morpheus.App.Internal.Resolving.ResolverState (config)-import Data.Morpheus.App.Internal.Resolving.Types (ResolverMap)+import Data.HashMap.Lazy (keys)+import Data.Morpheus.App.Internal.Resolving.Cache+  ( CacheKey (..),+    CacheT,+    CacheValue (..),+    cacheResolverValues,+    cacheValue,+    isCached,+    printSelectionKey,+    useCached,+    withDebug,+  )+import Data.Morpheus.App.Internal.Resolving.Refs (scanRefs)+import Data.Morpheus.App.Internal.Resolving.ResolverState (ResolverContext)+import Data.Morpheus.App.Internal.Resolving.Types+  ( NamedResolver (..),+    NamedResolverResult (..),+    ResolverMap,+  ) import Data.Morpheus.App.Internal.Resolving.Utils-import Data.Morpheus.Core (Config (..), RenderGQL, render)+  ( NamedResolverRef (..),+    ResolverMonad,+    ResolverValue (ResEnum, ResNull, ResObject, ResRef, ResScalar),+  )+import Data.Morpheus.Core (render)+import Data.Morpheus.Internal.Utils (Empty (empty), IsMap (..), selectOr) import Data.Morpheus.Types.Internal.AST   ( GQLError,     Msg (..),@@ -43,33 +61,8 @@     ValidValue,     internal,   )-import Debug.Trace (trace) import GHC.Show (Show (show))-import Relude hiding (show, trace)--type LocalCache = HashMap CacheKey ValidValue--useCached :: (Eq k, Show 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 $ "cache value could not found for key" <> msg (show v :: String))--dumpCache :: Bool -> LocalCache -> LocalCache-dumpCache enabled cache-  | null cache || not enabled = cache-  | otherwise = trace ("\nCACHE:\n" <> printCache cache) cache--printCache :: LocalCache -> [Char]-printCache cache = intercalate "\n" (map printKeyValue $ HM.toList cache) <> "\n"-  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+import Relude hiding (empty, show)  data BatchEntry = BatchEntry   { batchedSelection :: SelectionContent VALID,@@ -78,74 +71,107 @@   }  instance Show BatchEntry where-  show BatchEntry {..} = printSel batchedSelection <> ":" <> toString batchedType <> ":" <> show (map (unpack . render) batchedArguments)--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)+  show BatchEntry {..} =+    "\nBATCH("+      <> toString batchedType+      <> "):"+      <> "\n  sel:"+      <> printSelectionKey batchedSelection+      <> "\n  dep:"+      <> show (map (unpack . render) batchedArguments) -instance Hashable CacheKey where-  hashWithSalt s (CacheKey sel tyName arg) = hashWithSalt s (sel, tyName, render arg)+type SelectionRef = (SelectionContent VALID, NamedResolverRef)  uniq :: (Eq a, Hashable a) => [a] -> [a]-uniq = HM.keys . HM.fromList . map (,True)+uniq = keys . unsafeFromList . map (,True) -buildBatches :: [(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry]+buildBatches :: [SelectionRef] -> [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+selectByEntity :: [SelectionRef] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry+selectByEntity inputs (tSel, tName) = case gerArgs (filter areEq inputs) of   [] -> Nothing-  xs -> Just $ BatchEntry tSel tName (uniq $ concatMap (resolverArgument . snd) xs)+  args -> Just (BatchEntry tSel tName args)+    where+   where+    gerArgs = uniq . concatMap (resolverArgument . snd)     areEq (sel, v) = sel == tSel && tName == resolverTypeName v -type ResolverFun m = NamedResolverRef -> SelectionContent VALID -> m [ValidValue]--resolveBatched :: Monad m => ResolverFun m -> BatchEntry -> m LocalCache-resolveBatched f (BatchEntry sel name deps) = do-  res <- f (NamedResolverRef name deps) sel-  let keys = map (CacheKey sel name) deps-  let entries = zip keys res-  pure $ HM.fromList entries--updateCache :: (ResolverMonad m, Traversable t) => ResolverFun m -> LocalCache -> t BatchEntry -> m LocalCache-updateCache f cache entries = do-  caches <- traverse (resolveBatched f) entries-  let newCache = foldr (<>) cache caches-  enabled <- asks (debug . config)-  pure $ dumpCache enabled newCache--buildCacheWith :: ResolverMonad m => ResolverFun m -> LocalCache -> [(SelectionContent VALID, NamedResolverRef)] -> m LocalCache-buildCacheWith f cache entries = updateCache f cache (buildBatches entries)--data ResolverMapContext m = ResolverMapContext-  { localCache :: LocalCache,-    resolverMap :: ResolverMap m-  }- newtype ResolverMapT m a = ResolverMapT-  { _runResMapT :: ReaderT (ResolverMapContext m) m a+  { _runResMapT :: ReaderT (ResolverMap m) (CacheT m) a   }   deriving     ( Functor,       Applicative,-      Monad,-      MonadReader (ResolverMapContext m)+      Monad     ) +instance (MonadReader ResolverContext m) => MonadReader ResolverContext (ResolverMapT m) where+  ask = ResolverMapT (lift ask)+  local f (ResolverMapT m) = ResolverMapT (ReaderT (local f . runReaderT m))+ instance MonadTrans ResolverMapT where-  lift = ResolverMapT . lift+  lift = ResolverMapT . lift . lift  deriving instance MonadError GQLError m => MonadError GQLError (ResolverMapT m) -runResMapT :: ResolverMapT m a -> ResolverMapContext m -> m a-runResMapT (ResolverMapT x) = runReaderT x+runBatchedT :: Monad m => ResolverMapT m a -> ResolverMap m -> m a+runBatchedT (ResolverMapT m) rmap = fst <$> runStateT (runReaderT m rmap) empty++toKeys :: BatchEntry -> [CacheKey]+toKeys (BatchEntry sel name deps) = map (CacheKey sel name) deps++inCache :: Monad m => CacheT m a -> ResolverMapT m a+inCache = ResolverMapT . lift++class MonadTrans t => MonadBatching t where+  resolveRef :: ResolverMonad m => SelectionContent VALID -> NamedResolverRef -> t m (CacheKey, CacheValue m)+  storeValue :: ResolverMonad m => CacheKey -> ValidValue -> t m ValidValue++instance MonadBatching IdentityT where+  resolveRef _ _ = throwError $ internal "batching is only allowed with named resolvers"+  storeValue _ _ = throwError $ internal "batching is only allowed with named resolvers"++instance MonadBatching ResolverMapT where+  resolveRef sel (NamedResolverRef typename [arg]) = do+    let key = CacheKey sel typename arg+    alreadyCached <- inCache (isCached key)+    if alreadyCached+      then pure ()+      else prefetch (BatchEntry sel typename [arg])+    inCache $ do+      value <- useCached key+      pure (key, value)+  resolveRef _ ref = throwError (internal ("expected only one resolved value for " <> msg (show ref :: String)))+  storeValue key = inCache . cacheValue key++prefetch :: ResolverMonad m => BatchEntry -> ResolverMapT m ()+prefetch batch = do+  value <- run batch+  batches <- buildBatches . concat <$> traverse (lift . scanRefs (batchedSelection batch)) value+  resolvedEntries <- traverse (\b -> (b,) <$> run b) batches+  let caches = foldMap zipCaches $ (batch, value) : resolvedEntries+  inCache $ cacheResolverValues caches+  where+    zipCaches (b, res) = zip (toKeys b) res+    run = withDebug >=> runBatch++runBatch :: (MonadError GQLError m, MonadReader ResolverContext m) => BatchEntry -> ResolverMapT m [ResolverValue m]+runBatch (BatchEntry _ name deps)+  | null deps = pure []+  | otherwise = do+      resolvers <- ResolverMapT ask+      NamedResolver {resolverFun} <- lift (selectOr notFound pure name resolvers)+      map (toResolverValue name) <$> lift (resolverFun deps)+  where+    notFound = throwError ("resolver type " <> msg name <> "can't found")++toResolverValue :: (Monad m) => TypeName -> NamedResolverResult m -> ResolverValue m+toResolverValue typeName (NamedObjectResolver res) = ResObject (Just typeName) res+toResolverValue _ (NamedUnionResolver unionRef) = ResRef $ pure unionRef+toResolverValue _ (NamedEnumResolver value) = ResEnum value+toResolverValue _ NamedNullResolver = ResNull+toResolverValue _ (NamedScalarResolver v) = ResScalar v

@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving.Cache+  ( CacheKey (..),+    CacheStore (..),+    printSelectionKey,+    useCached,+    isCached,+    withDebug,+    cacheResolverValues,+    cacheValue,+    CacheValue (..),+    CacheT,+  )+where++import Control.Monad.Except+import Data.ByteString.Lazy.Char8 (unpack)+import qualified Data.HashMap.Lazy as HM+import Data.Morpheus.App.Internal.Resolving.ResolverState+import Data.Morpheus.App.Internal.Resolving.Types (ResolverValue)+import Data.Morpheus.App.Internal.Resolving.Utils (ResolverMonad)+import Data.Morpheus.Core (Config (debug), RenderGQL, render)+import Data.Morpheus.Internal.Utils+  ( Empty (..),+    IsMap (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( Msg (msg),+    SelectionContent,+    TypeName,+    VALID,+    ValidValue,+    internal,+  )+import Debug.Trace (trace)+import Relude hiding (Show, empty, show, trace)+import Prelude (Show (show))++type CacheT m = (StateT (CacheStore m) m)++printSelectionKey :: RenderGQL a => a -> String+printSelectionKey sel = map replace $ filter ignoreSpaces $ unpack (render sel)+  where+    ignoreSpaces x = x /= ' '+    replace '\n' = ' '+    replace x = x++data CacheKey = CacheKey+  { cachedSel :: SelectionContent VALID,+    cachedTypeName :: TypeName,+    cachedArg :: ValidValue+  }+  deriving (Eq, Generic)++data CacheValue m+  = CachedValue ValidValue+  | CachedResolver (ResolverValue m)++instance Show (CacheValue m) where+  show (CachedValue v) = unpack (render v)+  show (CachedResolver v) = show v++instance Show CacheKey where+  show (CacheKey sel typename dep) = printSelectionKey sel <> ":" <> toString typename <> ":" <> unpack (render dep)++instance Hashable CacheKey where+  hashWithSalt s (CacheKey sel tyName arg) = hashWithSalt s (sel, tyName, render arg)++newtype CacheStore m = CacheStore {_unpackStore :: HashMap CacheKey (CacheValue m)}++instance Show (CacheStore m) where+  show (CacheStore cache) = "\nCACHE:\n" <> intercalate "\n" (map printKeyValue $ toAssoc cache) <> "\n"+    where+      printKeyValue (key, v) = " " <> show key <> ": " <> show v++instance Empty (CacheStore m) where+  empty = CacheStore empty++cacheResolverValues :: ResolverMonad m => [(CacheKey, ResolverValue m)] -> CacheT m ()+cacheResolverValues pres = do+  CacheStore oldCache <- get+  let updates = unsafeFromList (map (second CachedResolver) pres)+  cache <- labeledDebug "\nUPDATE|>" $ CacheStore $ updates <> oldCache+  modify (const cache)++useCached :: ResolverMonad m => CacheKey -> CacheT m (CacheValue m)+useCached v = do+  cache <- get >>= labeledDebug "\nUSE|>"+  case lookup v (_unpackStore cache) of+    Just x -> pure x+    Nothing -> throwError (internal $ "cache value could not found for key" <> msg (show v :: String))++isCached :: Monad m => CacheKey -> CacheT m Bool+isCached key = isJust . lookup key . _unpackStore <$> get++setValue :: (CacheKey, ValidValue) -> CacheStore m -> CacheStore m+setValue (key, value) = CacheStore . HM.insert key (CachedValue value) . _unpackStore++labeledDebug :: (Show a, MonadReader ResolverContext m) => String -> a -> m a+labeledDebug label v = showValue <$> asks (debug . config)+  where+    showValue enabled+      | enabled = trace (label <> show v) v+      | otherwise = v++withDebug :: (Show a, MonadReader ResolverContext m) => a -> m a+withDebug = labeledDebug ""++cacheValue :: Monad m => CacheKey -> ValidValue -> CacheT m ValidValue+cacheValue key value = modify (setValue (key, value)) $> value

@@ -15,8 +15,7 @@   )  class EventHandler e where-  type Channel e-  getChannels :: e -> [Channel e]+  type Channel e :: Type  data ResponseEvent event (m :: Type -> Type)   = Publish event

@@ -0,0 +1,85 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving.MonadResolver+  ( MonadResolver (..),+    MonadIOResolver,+    SubscriptionField (..),+    ResolverContext (..),+    withArguments,+    getArgument,+  )+where++import Control.Monad.Except (MonadError)+import Data.Morpheus.App.Internal.Resolving.Event+  ( EventHandler (..),+    ResponseEvent,+  )+import Data.Morpheus.App.Internal.Resolving.ResolverState+  ( ResolverContext (..),+    ResolverState,+  )+import Data.Morpheus.Internal.Ext (ResultT)+import Data.Morpheus.Internal.Utils (selectOr)+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    Arguments,+    FieldName,+    GQLError,+    MUTATION,+    OperationType,+    SUBSCRIPTION,+    Selection,+    VALID,+    ValidValue,+    Value (..),+  )+import Relude++class (MonadResolver m, MonadIO m) => MonadIOResolver (m :: Type -> Type)++class+  ( Monad m,+    MonadReader ResolverContext m,+    MonadFail m,+    MonadError GQLError m,+    Monad (MonadParam m)+  ) =>+  MonadResolver (m :: Type -> Type)+  where+  type MonadOperation m :: OperationType+  type MonadEvent m :: Type+  type MonadQuery m :: (Type -> Type)+  type MonadMutation m :: (Type -> Type)+  type MonadSubscription m :: (Type -> Type)+  type MonadParam m :: (Type -> Type)+  liftState :: ResolverState a -> m a+  getArguments :: m (Arguments VALID)+  subscribe :: (MonadOperation m ~ SUBSCRIPTION) => Channel (MonadEvent m) -> MonadQuery m (MonadEvent m -> m a) -> SubscriptionField (m a)+  publish :: (MonadOperation m ~ MUTATION) => [MonadEvent m] -> m ()+  runResolver ::+    Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m))) ->+    m ValidValue ->+    ResolverContext ->+    ResponseStream (MonadEvent m) (MonadParam m) ValidValue++data SubscriptionField (a :: Type) where+  SubscriptionField ::+    { channel :: forall m v. (a ~ m v, MonadResolver m, MonadOperation m ~ SUBSCRIPTION) => Channel (MonadEvent m),+      unSubscribe :: a+    } ->+    SubscriptionField a++withArguments :: (MonadResolver m) => (Arguments VALID -> m a) -> m a+withArguments = (getArguments >>=)++getArgument :: (MonadResolver m) => FieldName -> m (Value VALID)+getArgument name = selectOr Null argumentValue name <$> getArguments++type ResponseStream event (m :: Type -> Type) = ResultT (ResponseEvent event m) m

@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving.Refs+  ( scanRefs,+  )+where++import Data.Morpheus.App.Internal.Resolving.ResolverState+  ( inSelectionField,+  )+import Data.Morpheus.App.Internal.Resolving.Types (NamedResolverRef, ObjectTypeResolver (..), ResolverValue (..))+import Data.Morpheus.App.Internal.Resolving.Utils (ResolverMonad, withField, withObject)+import Data.Morpheus.Types.Internal.AST+  ( Selection (..),+    SelectionContent (..),+    SelectionSet,+    VALID,+  )+import Relude hiding (empty)++type SelectionRef = (SelectionContent VALID, NamedResolverRef)++scanRefs :: (ResolverMonad m) => SelectionContent VALID -> ResolverValue m -> m [SelectionRef]+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 :: (ResolverMonad m) => ObjectTypeResolver m -> Maybe (SelectionSet VALID) -> m [SelectionRef]+objectRefs _ Nothing = pure []+objectRefs obj (Just sel) = concat <$> traverse (fieldRefs obj) (toList sel)++fieldRefs :: (ResolverMonad m) => ObjectTypeResolver m -> Selection VALID -> m [SelectionRef]+fieldRefs obj selection@Selection {..}+  | selectionName == "__typename" = pure []+  | otherwise = inSelectionField selection $ do+      resValue <- withField [] (fmap pure) selectionName obj+      concat <$> traverse (scanRefs selectionContent) resValue

@@ -2,61 +2,48 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.App.Internal.Resolving.ResolveValue-  ( resolveRef,-    resolveObject,-    ResolverMapContext (..),+  ( resolvePlainRoot,+    resolveNamedRoot,   ) where  import Control.Monad.Except (MonadError (throwError))-import qualified Data.HashMap.Lazy as HM import Data.Morpheus.App.Internal.Resolving.Batching-  ( CacheKey (..),-    ResolverMapContext (..),-    ResolverMapT,-    buildCacheWith,-    runResMapT,-    useCached,+  ( MonadBatching (..),+    runBatchedT,   )+import Data.Morpheus.App.Internal.Resolving.Cache (CacheValue (..))+import Data.Morpheus.App.Internal.Resolving.MonadResolver (MonadResolver) import Data.Morpheus.App.Internal.Resolving.ResolverState   ( ResolverContext (..),-    askFieldTypeName,-    updateCurrentType,+    inSelectionField,   ) import Data.Morpheus.App.Internal.Resolving.Types-  ( NamedResolver (..),-    NamedResolverRef (..),-    NamedResolverResult (..),-    ObjectTypeResolver (..),-    ResolverMap,-    ResolverValue (..),+  ( ResolverMap,     mkEnum,+    mkNull,+    mkString,     mkUnion,   )-import Data.Morpheus.Error (subfieldsNotSelected)+import Data.Morpheus.App.Internal.Resolving.Utils import Data.Morpheus.Internal.Utils   ( KeyOf (keyOf),     empty,-    selectOr,     traverseCollection,-    (<:>),   ) import Data.Morpheus.Types.Internal.AST-  ( GQLError,-    Msg (msg),-    ObjectEntry (ObjectEntry),+  ( ObjectEntry (ObjectEntry),     ScalarValue (..),     Selection (..),     SelectionContent (..),     SelectionSet,     TypeDefinition (..),     TypeName,-    UnionTag (unionTagSelection),     VALID,     ValidValue,     Value (..),@@ -67,204 +54,47 @@   ) import Relude hiding (empty) -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-  ) =>-  ResolverValue m ->-  SelectionContent VALID ->-  ResolverMapT m ValidValue-resolveSelection res selection = do-  ctx <- ask-  newRmap <- lift (scanRefs selection res >>= buildCache ctx)-  local (const newRmap) (__resolveSelection res selection)--buildCache :: (MonadError GQLError m, MonadReader ResolverContext m) => ResolverMapContext m -> [(SelectionContent VALID, NamedResolverRef)] -> m (ResolverMapContext m)-buildCache ctx@(ResolverMapContext cache rmap) entries = (`ResolverMapContext` rmap) <$> buildCacheWith (resolveRefsCached ctx) cache entries--__resolveSelection ::-  ( Monad m,-    MonadReader ResolverContext m,-    MonadError GQLError m-  ) =>-  ResolverValue m ->-  SelectionContent VALID ->-  ResolverMapT m ValidValue-__resolveSelection (ResLazy x) selection = lift x >>= (`resolveSelection` selection)-__resolveSelection (ResList xs) selection = List <$> traverse (`resolveSelection` selection) xs-__resolveSelection (ResObject tyName obj) sel = do-  ctx <- ask-  lift $ withObject tyName (resolveObject ctx obj) sel-__resolveSelection (ResEnum name) SelectionField = pure $ Scalar $ String $ unpackName name-__resolveSelection (ResEnum name) unionSel@UnionSelection {} = resolveSelection (mkUnion name [(unitFieldName, pure $ mkEnum unitTypeName)]) unionSel-__resolveSelection ResEnum {} _ = throwError (internal "wrong selection on enum value")-__resolveSelection ResNull _ = pure Null-__resolveSelection (ResScalar x) SelectionField = pure $ Scalar x-__resolveSelection ResScalar {} _ = throwError (internal "scalar Resolver should only receive SelectionField")-__resolveSelection (ResRef ref) sel = do-  ctx <- ask-  lift (ref >>= flip (resolveRef ctx) sel)--withObject ::-  ( MonadError GQLError m,-    MonadReader ResolverContext m-  ) =>-  Maybe TypeName ->-  (Maybe (SelectionSet VALID) -> m value) ->-  SelectionContent VALID ->-  m value-withObject __typename f = updateCurrentType __typename . checkContent-  where-    checkContent (SelectionSet selection) = f (Just selection)-    checkContent (UnionSelection interface unionSel) = do-      typename <- asks (typeName . currentType)-      selection <- selectOr (pure interface) (fx interface) typename unionSel-      f selection-      where-        fx (Just x) y = Just <$> (x <:> unionTagSelection y)-        fx Nothing y = pure $ Just $ unionTagSelection y-    checkContent SelectionField = noEmptySelection--noEmptySelection :: (MonadError GQLError m, MonadReader ResolverContext m) => m value-noEmptySelection = do-  sel <- asks currentSelection-  throwError $ subfieldsNotSelected (selectionName sel) "" (selectionPosition sel)--resolveRef ::-  ( MonadError GQLError m,-    MonadReader ResolverContext m-  ) =>-  ResolverMapContext m ->-  NamedResolverRef ->-  SelectionContent VALID ->-  m ValidValue-resolveRef rmap ref selection = resolveRefsCached rmap ref selection >>= toOne--toOne :: (MonadError GQLError f, Show a) => [a] -> f a-toOne [x] = pure x-toOne x = throwError (internal ("expected only one resolved value for " <> msg (show x :: String)))--resolveRefsCached ::-  ( MonadError GQLError m,-    MonadReader ResolverContext m-  ) =>-  ResolverMapContext m ->-  NamedResolverRef ->-  SelectionContent VALID ->-  m [ValidValue]-resolveRefsCached ctx (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 <- runResMapT (resolveUncached name selection $ map fst $ filter (isNothing . snd) cached) ctx-  traverse (useCached (cachedMap <> notCachedMap)) args-  where-    unp (_, Nothing) = Nothing-    unp (x, Just y) = Just (x, y)-    resolveCached key = (cachedArg key, HM.lookup key $ localCache ctx)+-- UNCACHED+resolvePlainRoot :: MonadResolver m => ObjectTypeResolver m -> SelectionSet VALID -> m ValidValue+resolvePlainRoot resolver selection = do+  name <- asks (typeName . currentType)+  runIdentityT (resolveSelection (SelectionSet selection) (ResObject (Just name) resolver)) -processResult ::-  (MonadError GQLError m, MonadReader ResolverContext m) =>-  TypeName ->-  SelectionContent VALID ->-  NamedResolverResult m ->-  ResolverMapT m ValidValue-processResult typename selection (NamedObjectResolver res) = do-  ctx <- ask-  lift $ withObject (Just typename) (resolveObject ctx res) selection-processResult _ selection (NamedUnionResolver unionRef) = resolveSelection (ResRef $ pure unionRef) selection-processResult _ selection (NamedEnumResolver value) = resolveSelection (ResEnum value) selection-processResult _ selection NamedNullResolver = resolveSelection ResNull selection-processResult _ selection (NamedScalarResolver v) = resolveSelection (ResScalar v) selection+-- CACHED+resolveNamedRoot :: MonadResolver m => TypeName -> ResolverMap m -> SelectionSet VALID -> m ValidValue+resolveNamedRoot typeName resolvers selection =+  runBatchedT+    (resolveSelection (SelectionSet selection) (ResRef $ pure (NamedResolverRef typeName ["ROOT"])))+    resolvers -resolveUncached ::-  ( MonadError GQLError m,-    MonadReader ResolverContext m-  ) =>-  TypeName ->-  SelectionContent VALID ->-  [ValidValue] ->-  ResolverMapT m (HashMap ValidValue ValidValue)-resolveUncached _ _ [] = pure empty-resolveUncached typename selection xs = do-  rmap <- asks resolverMap-  vs <- lift (getNamedResolverBy (NamedResolverRef typename xs) rmap) >>= traverse (processResult typename selection)-  pure $ HM.fromList (zip xs vs)+-- RESOLVING -getNamedResolverBy ::-  (MonadError GQLError m) =>-  NamedResolverRef ->-  ResolverMap m ->-  m [NamedResolverResult m]-getNamedResolverBy NamedResolverRef {..} = selectOr cantFoundError ((resolverArgument &) . resolverFun) resolverTypeName+resolveSelection :: (ResolverMonad (t m), MonadBatching t, MonadResolver m) => SelectionContent VALID -> ResolverValue m -> t m ValidValue+resolveSelection selection (ResLazy x) = lift x >>= resolveSelection selection+resolveSelection selection (ResList xs) = List <$> traverse (resolveSelection selection) xs+resolveSelection SelectionField (ResEnum name) = pure $ Scalar $ String $ unpackName name+resolveSelection selection@UnionSelection {} (ResEnum name) = resolveSelection selection (mkUnion name [(unitFieldName, pure $ mkEnum unitTypeName)])+resolveSelection _ ResEnum {} = throwError (internal "wrong selection on enum value")+resolveSelection _ ResNull = pure Null+resolveSelection SelectionField (ResScalar x) = pure $ Scalar x+resolveSelection _ ResScalar {} = throwError (internal "scalar resolver should only receive SelectionField")+resolveSelection selection (ResObject typeName obj) = withObject typeName (mapSelectionSet resolveField) selection   where-    cantFoundError = throwError ("Resolver Type " <> msg resolverTypeName <> "can't found")+    resolveField s = lift (toResolverValue obj s) >>= resolveSelection (selectionContent s)+resolveSelection selection (ResRef mRef) = do+  (key, value) <- resolveRef selection =<< lift mRef+  case value of+    (CachedValue v) -> pure v+    (CachedResolver v) -> resolveSelection selection v >>= storeValue key -resolveObject ::-  ( MonadReader ResolverContext m,-    MonadError GQLError m-  ) =>-  ResolverMapContext m ->+toResolverValue ::+  (MonadResolver m) =>   ObjectTypeResolver m ->-  Maybe (SelectionSet VALID) ->-  m ValidValue-resolveObject rmap drv sel = do-  newCache <- objectRefs drv sel >>= buildCache rmap-  Object <$> maybe (pure empty) (traverseCollection (resolver newCache)) sel-  where-    resolver cacheCTX currentSelection = do-      t <- askFieldTypeName (selectionName currentSelection)-      updateCurrentType t $-        local (\ctx -> ctx {currentSelection}) $-          ObjectEntry (keyOf currentSelection)-            <$> runResMapT (runFieldResolver currentSelection drv) cacheCTX--runFieldResolver ::-  ( Monad m,-    MonadReader ResolverContext m,-    MonadError GQLError m-  ) =>   Selection VALID ->-  ObjectTypeResolver m ->-  ResolverMapT m ValidValue-runFieldResolver Selection {selectionName, selectionContent}-  | selectionName == "__typename" =-      const (Scalar . String . unpackName <$> lift (asks (typeName . currentType)))-  | otherwise =-      maybe (pure Null) (lift >=> (`resolveSelection` selectionContent))-        . HM.lookup selectionName-        . objectFields+  m (ResolverValue m)+toResolverValue obj Selection {selectionName}+  | selectionName == "__typename" = mkString . unpackName <$> asks (typeName . currentType)+  | otherwise = withField mkNull id selectionName obj++mapSelectionSet :: (ResolverMonad m) => (Selection VALID -> m ValidValue) -> Maybe (SelectionSet VALID) -> m ValidValue+mapSelectionSet f = fmap Object . maybe (pure empty) (traverseCollection (\sel -> ObjectEntry (keyOf sel) <$> inSelectionField sel (f sel)))

@@ -19,18 +19,10 @@ module Data.Morpheus.App.Internal.Resolving.Resolver   ( Resolver,     LiftOperation,-    lift,-    subscribe,     ResponseEvent (..),     ResponseStream,     WithOperation,-    ResolverContext (..),-    withArguments,-    getArguments,     SubscriptionField (..),-    liftResolverState,-    runResolver,-    getArgument,   ) where @@ -40,6 +32,11 @@   ( EventHandler (..),     ResponseEvent (..),   )+import Data.Morpheus.App.Internal.Resolving.MonadResolver+  ( MonadIOResolver,+    MonadResolver (..),+    SubscriptionField (..),+  ) import Data.Morpheus.App.Internal.Resolving.ResolverState   ( ResolverContext (..),     ResolverState,@@ -59,16 +56,12 @@     cleanEvents,     mapEvent,   )-import Data.Morpheus.Internal.Utils (selectOr) import Data.Morpheus.Types.IO   ( GQLResponse,     renderResponse,   ) import Data.Morpheus.Types.Internal.AST-  ( Argument (argumentValue),-    Arguments,-    FieldName,-    GQLError,+  ( GQLError,     MUTATION,     OperationType (..),     QUERY,@@ -90,22 +83,36 @@  type ResponseStream event (m :: Type -> Type) = ResultT (ResponseEvent event m) m -data SubscriptionField (a :: Type) where-  SubscriptionField ::-    { channel :: forall e m v. a ~ Resolver SUBSCRIPTION e m v => Channel e,-      unSubscribe :: a-    } ->-    SubscriptionField a------- GraphQL Field Resolver---+-- GraphQL resolver --------------------------------------------------------------- data Resolver (o :: OperationType) event (m :: Type -> Type) value where   ResolverQ :: {runResolverQ :: ResolverStateT () m value} -> Resolver QUERY event m value   ResolverM :: {runResolverM :: ResolverStateT event m value} -> Resolver MUTATION event m value   ResolverS :: {runResolverS :: ResolverStateT () m (SubEventRes event m value)} -> Resolver SUBSCRIPTION event m value +instance (LiftOperation o, Monad m, MonadIO m) => MonadIOResolver (Resolver o e m)++instance (LiftOperation o, Monad m) => MonadResolver (Resolver o e m) where+  type MonadOperation (Resolver o e m) = o+  type MonadEvent (Resolver o e m) = e+  type MonadQuery (Resolver o e m) = (Resolver QUERY e m)+  type MonadMutation (Resolver o e m) = (Resolver MUTATION e m)+  type MonadSubscription (Resolver o e m) = (Resolver SUBSCRIPTION e m)+  type MonadParam (Resolver o e m) = m+  getArguments = asks (selectionArguments . currentSelection)+  liftState = packResolver . toResolverStateT+  subscribe ch res = SubscriptionField ch (ResolverS (runSubscription <$> runResolverQ res))+    where+      runSubscription f = join (ReaderT (runResolverS . f))+  publish = pushEvents+  runResolver _ (ResolverQ resT) sel = cleanEvents $ runResolverStateT resT sel+  runResolver _ (ResolverM resT) sel = mapEvent Publish $ runResolverStateT resT sel+  runResolver toChannel (ResolverS resT) ctx = ResultT $ do+    readResValue <- runResolverStateValueM resT ctx+    pure $ case readResValue >>= subscriptionEvents ctx toChannel . toEventResolver ctx of+      Failure x -> Failure x+      Success {warnings, result} -> Success {warnings, result = ([result], Null)}+ type SubEventRes event m value = ReaderT event (ResolverStateT () m) value  instance Show (Resolver o e m value) where@@ -170,9 +177,6 @@   local f (ResolverM res) = ResolverM (local f res)   local f (ResolverS resM) = ResolverS $ mapReaderT (local f) <$> resM -liftResolverState :: (LiftOperation o, Monad m) => ResolverState a -> Resolver o e m a-liftResolverState = packResolver . toResolverStateT- class LiftOperation (o :: OperationType) where   packResolver :: Monad m => ResolverStateT e m a -> Resolver o e m a @@ -184,54 +188,6 @@  instance LiftOperation SUBSCRIPTION where   packResolver = ResolverS . pure . lift . clearStateResolverEvents--subscribe ::-  (Monad m) =>-  Channel e ->-  Resolver QUERY e m (e -> Resolver SUBSCRIPTION e m a) ->-  SubscriptionField (Resolver SUBSCRIPTION e m a)-subscribe ch res =-  SubscriptionField ch $-    ResolverS $-      fromSub <$> runResolverQ res-  where-    fromSub :: Monad m => (e -> Resolver SUBSCRIPTION e m a) -> ReaderT e (ResolverStateT () m) a-    fromSub f = join (ReaderT (runResolverS . f))--withArguments ::-  (LiftOperation o, Monad m) =>-  (Arguments VALID -> Resolver o e m a) ->-  Resolver o e m a-withArguments = (getArguments >>=)--getArguments ::-  (LiftOperation o, Monad m) =>-  Resolver o e m (Arguments VALID)-getArguments = asks (selectionArguments . currentSelection)--getArgument ::-  (LiftOperation o, Monad m) =>-  FieldName ->-  Resolver o e m (Value VALID)-getArgument name = selectOr Null argumentValue name <$> getArguments--runResolver ::-  Monad m =>-  Maybe (Selection VALID -> ResolverState (Channel event)) ->-  Resolver o event m ValidValue ->-  ResolverContext ->-  ResponseStream event m ValidValue-runResolver _ (ResolverQ resT) sel = cleanEvents $ runResolverStateT resT sel-runResolver _ (ResolverM resT) sel = mapEvent Publish $ runResolverStateT resT sel-runResolver toChannel (ResolverS resT) ctx = ResultT $ do-  readResValue <- runResolverStateValueM resT ctx-  pure $ case readResValue >>= subscriptionEvents ctx toChannel . toEventResolver ctx of-    Failure x -> Failure x-    Success {warnings, result} ->-      Success-        { warnings,-          result = ([result], Null)-        }  toEventResolver :: Monad m => ResolverContext -> SubEventRes event m ValidValue -> (event -> m GQLResponse) toEventResolver sel (ReaderT subRes) event = renderResponse <$> runResolverStateValueM (subRes event) sel

@@ -28,6 +28,8 @@     runResolverStateValueM,     updateCurrentType,     askFieldTypeName,+    inField,+    inSelectionField,   ) where @@ -106,6 +108,16 @@   (DataInterface fs) -> selectOr Nothing (Just . typeConName . fieldType) name fs   _ -> Nothing +inSelectionField :: (MonadReader ResolverContext m, MonadError GQLError m) => Selection VALID -> m b -> m b+inSelectionField selection m = do+  inField (selectionName selection) $+    local (\ctx -> ctx {currentSelection = selection}) m++inField :: (MonadReader ResolverContext m, MonadError GQLError m) => FieldName -> m b -> m b+inField fieldName m = do+  fieldType <- askFieldTypeName fieldName+  updateCurrentType fieldType m+ askFieldTypeName :: MonadReader ResolverContext m => FieldName -> m (Maybe TypeName) askFieldTypeName name = asks (fieldTypeName name . currentType) @@ -123,7 +135,7 @@ runResolverState :: ResolverState a -> ResolverContext -> GQLResult a runResolverState res = fmap snd . runIdentity . runResolverStateM res --- Resolver Internal State+-- internal resolver state newtype ResolverStateT event m a = ResolverStateT   { _runResolverStateT :: ReaderT ResolverContext (ResultT event m) a   }

@@ -1,6 +1,10 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.App.Internal.Resolving.RootResolverValue@@ -9,22 +13,20 @@   ) where -import Control.Monad.Except (MonadError, throwError)-import qualified Data.Aeson as A+import Control.Monad.Except (throwError)+import Data.Aeson (FromJSON (..))+import Data.HashMap.Strict (adjust) import Data.Morpheus.App.Internal.Resolving.Event   ( EventHandler (..),   )+import Data.Morpheus.App.Internal.Resolving.MonadResolver import Data.Morpheus.App.Internal.Resolving.ResolveValue import Data.Morpheus.App.Internal.Resolving.Resolver-  ( LiftOperation,-    Resolver,+  ( Resolver,     ResponseStream,-    runResolver,   ) import Data.Morpheus.App.Internal.Resolving.ResolverState-  ( ResolverContext (..),-    ResolverState,-    runResolverStateT,+  ( ResolverState,     toResolverStateT,   ) import Data.Morpheus.App.Internal.Resolving.SchemaAPI (schemaAPI)@@ -32,25 +34,20 @@ import Data.Morpheus.App.Internal.Resolving.Utils   ( lookupResJSON,   )-import Data.Morpheus.Internal.Ext (merge)-import Data.Morpheus.Internal.Utils-  ( empty,-  ) import Data.Morpheus.Types.Internal.AST-  ( GQLError,-    MUTATION,+  ( MUTATION,     Operation (..),     OperationType (..),     QUERY,     SUBSCRIPTION,+    Schema (..),     Selection,-    SelectionContent (SelectionSet),     SelectionSet,+    TypeDefinition (typeName),+    TypeName,     VALID,     ValidValue,     Value (..),-    internal,-    splitSystemSelection,   ) import Relude hiding   ( Show,@@ -68,7 +65,7 @@   | NamedResolversValue       {queryResolverMap :: ResolverMap (Resolver QUERY e m)} -instance Monad m => A.FromJSON (RootResolverValue e m) where+instance Monad m => FromJSON (RootResolverValue e m) where   parseJSON res =     pure       RootResolverValue@@ -78,21 +75,10 @@           channelMap = Nothing         } -runRootDataResolver ::-  (Monad m, LiftOperation o) =>-  Maybe (Selection VALID -> ResolverState (Channel e)) ->-  ResolverState (ObjectTypeResolver (Resolver o e m)) ->-  ResolverContext ->-  SelectionSet VALID ->-  ResponseStream e m (Value VALID)-runRootDataResolver-  channels-  res-  ctx-  selection =-    do-      root <- runResolverStateT (toResolverStateT res) ctx-      runResolver channels (resolveObject (ResolverMapContext mempty mempty) root (Just selection)) ctx+rootResolver :: (MonadResolver m) => ResolverState (ObjectTypeResolver m) -> SelectionSet VALID -> m ValidValue+rootResolver res selection = do+  root <- liftState (toResolverStateT res)+  resolvePlainRoot root selection  runRootResolverValue :: Monad m => RootResolverValue e m -> ResolverContext -> ResponseStream e m (Value VALID) runRootResolverValue@@ -102,37 +88,34 @@       subscriptionResolver,       channelMap     }-  ctx@ResolverContext {operation = Operation {operationType, operationSelection}} =+  ctx@ResolverContext {operation = Operation {..}, ..} =     selectByOperation operationType     where       selectByOperation OPERATION_QUERY =-        withIntrospection (runRootDataResolver channelMap queryResolver ctx) ctx+        runResolver channelMap (rootResolver (withIntroFields schema <$> queryResolver) operationSelection) ctx       selectByOperation OPERATION_MUTATION =-        runRootDataResolver channelMap mutationResolver ctx operationSelection+        runResolver channelMap (rootResolver mutationResolver operationSelection) ctx       selectByOperation OPERATION_SUBSCRIPTION =-        runRootDataResolver channelMap subscriptionResolver ctx operationSelection+        runResolver channelMap (rootResolver subscriptionResolver operationSelection) ctx runRootResolverValue   NamedResolversValue {queryResolverMap}-  ctx@ResolverContext {operation = Operation {operationType}} =+  ctx@ResolverContext {operation = Operation {..}} =     selectByOperation operationType     where-      selectByOperation OPERATION_QUERY = withIntrospection (\sel -> runResolver Nothing (resolvedValue sel) ctx) ctx+      selectByOperation OPERATION_QUERY = runResolver Nothing queryResolver ctx         where-          resolvedValue selection = resolveRef (ResolverMapContext empty queryResolverMap) (NamedResolverRef "Query" ["ROOT"]) (SelectionSet selection)+          queryResolver = do+            name <- asks (typeName . query . schema)+            resolveNamedRoot name (withNamedIntroFields name ctx queryResolverMap) operationSelection       selectByOperation _ = throwError "mutation and subscription is not supported for namedResolvers" -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 (operationSelection operation)-  (Just intro, Nothing) -> introspection intro ctx-  (Just intro, Just selection) -> do-    x <- f selection-    y <- introspection intro ctx-    mergeRoot y x--introspection :: Monad m => SelectionSet VALID -> ResolverContext -> ResponseStream event m ValidValue-introspection selection ctx@ResolverContext {schema} = runResolver Nothing (resolveObject (ResolverMapContext mempty mempty) (schemaAPI schema) (Just selection)) ctx+withNamedIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => TypeName -> ResolverContext -> ResolverMap m -> ResolverMap m+withNamedIntroFields queryName ResolverContext {..} = adjust updateNamed queryName+  where+    updateNamed NamedResolver {..} = NamedResolver {resolverFun = const (updateResult <$> resolverFun ["ROOT"]), ..}+      where+        updateResult [NamedObjectResolver obj] = [NamedObjectResolver (withIntroFields schema obj)]+        updateResult value = value -mergeRoot :: MonadError GQLError m => ValidValue -> ValidValue -> m ValidValue-mergeRoot (Object x) (Object y) = Object <$> merge x y-mergeRoot _ _ = throwError (internal "can't merge non object types")+withIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => Schema VALID -> ObjectTypeResolver m -> ObjectTypeResolver m+withIntroFields schema (ObjectTypeResolver fields) = ObjectTypeResolver (fields <> objectFields (schemaAPI schema))

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.App.Internal.Resolving.SchemaAPI@@ -9,7 +10,10 @@   ) where -import Data.Morpheus.App.Internal.Resolving.Resolver (Resolver, withArguments)+import Data.Morpheus.App.Internal.Resolving.MonadResolver+  ( MonadResolver (..),+    withArguments,+  ) import Data.Morpheus.App.Internal.Resolving.Types   ( ObjectTypeResolver (..),     ResolverValue,@@ -18,8 +22,7 @@     mkObject,   ) import Data.Morpheus.App.RenderIntrospection-  ( WithSchema,-    createObjectType,+  ( createObjectType,     render,   ) import Data.Morpheus.Internal.Utils@@ -44,25 +47,25 @@ import Relude hiding (empty) import qualified Relude as HM -resolveTypes :: (Monad m, WithSchema m) => Schema VALID -> m (ResolverValue m)+resolveTypes :: MonadResolver m => Schema VALID -> m (ResolverValue m) resolveTypes schema = mkList <$> traverse render (toList $ typeDefinitions schema)  renderOperation ::-  (Monad m, WithSchema m) =>+  MonadResolver m =>   Maybe (TypeDefinition OBJECT VALID) ->   m (ResolverValue m) renderOperation (Just TypeDefinition {typeName}) = pure $ createObjectType typeName Nothing [] empty renderOperation Nothing = pure mkNull  findType ::-  (Monad m, WithSchema m) =>+  MonadResolver m =>   TypeName ->   Schema VALID ->   m (ResolverValue m) findType name = selectOr (pure mkNull) render name . typeDefinitions  schemaResolver ::-  (Monad m, WithSchema m) =>+  MonadResolver m =>   Schema VALID ->   m (ResolverValue m) schemaResolver schema@Schema {query, mutation, subscription, directiveDefinitions} =@@ -76,7 +79,12 @@         ("directives", render $ sortWith directiveDefinitionName $ toList directiveDefinitions)       ] -schemaAPI :: Monad m => Schema VALID -> ObjectTypeResolver (Resolver QUERY e m)+schemaAPI ::+  ( MonadOperation m ~ QUERY,+    MonadResolver m+  ) =>+  Schema VALID ->+  ObjectTypeResolver m schemaAPI schema =   ObjectTypeResolver     ( HM.fromList

@@ -37,7 +37,7 @@ import Control.Monad.Except (MonadError (throwError)) import qualified Data.HashMap.Lazy as HM import Data.Morpheus.Internal.Ext (Merge (..))-import Data.Morpheus.Internal.Utils (KeyOf (keyOf))+import Data.Morpheus.Internal.Utils (IsMap (toAssoc), KeyOf (keyOf)) import Data.Morpheus.Types.Internal.AST   ( FieldName,     GQLError,@@ -69,7 +69,9 @@   }  instance Show (ObjectTypeResolver m) where-  show _ = "ObjectTypeResolver {}"+  show ObjectTypeResolver {..} = "ObjectTypeResolver { " <> intercalate "," (map showField (toAssoc objectFields)) <> " }"+    where+      showField (name, _) = show name <> " = " <> "ResolverValue m"  data NamedResolverRef = NamedResolverRef   { resolverTypeName :: TypeName,

@@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -18,29 +19,39 @@     lookupResJSON,     mkValue,     ResolverMonad,+    withField,+    withObject,   ) where  import Control.Monad.Except (MonadError (throwError))-import qualified Data.Aeson as A+import Data.Aeson (Value (..)) import Data.Morpheus.App.Internal.Resolving.ResolverState   ( ResolverContext (..),+    updateCurrentType,   ) import Data.Morpheus.App.Internal.Resolving.Types   ( NamedResolverRef (..),     ObjectTypeResolver (..),     ResolverValue (..),+    mkBoolean,     mkList,     mkNull,     mkObjectMaybe,+    mkString,   )-import Data.Morpheus.Internal.Utils (selectOr, toAssoc)-import qualified Data.Morpheus.Internal.Utils as U+import Data.Morpheus.Error (subfieldsNotSelected)+import Data.Morpheus.Internal.Utils (IsMap (..), selectOr, toAssoc, (<:>)) import Data.Morpheus.Types.Internal.AST   ( FieldName,     GQLError,-    ScalarValue (..),+    Selection (..),+    SelectionContent (..),+    SelectionSet,+    TypeDefinition (..),     TypeName,+    UnionTag (..),+    VALID,     decodeScientific,     internal,     packName,@@ -48,7 +59,6 @@   ) import Data.Morpheus.Types.SelectionTree (SelectionTree (..)) import Data.Text (breakOnEnd, splitOn)-import qualified Data.Vector as V import Relude hiding (break)  type ResolverMonad m = (MonadError GQLError m, MonadReader ResolverContext m)@@ -56,9 +66,9 @@ lookupResJSON ::   (ResolverMonad f, MonadReader ResolverContext m) =>   FieldName ->-  A.Value ->+  Value ->   f (ObjectTypeResolver m)-lookupResJSON name (A.Object fields) =+lookupResJSON name (Object fields) =   selectOr     mkEmptyObject     (requireObject <=< mkValue)@@ -73,21 +83,21 @@   ( MonadReader ResolverContext f,     MonadReader ResolverContext m   ) =>-  A.Value ->+  Value ->   f (ResolverValue m)-mkValue (A.Object v) = pure $ mkObjectMaybe typename fields+mkValue (Object v) = pure $ mkObjectMaybe typename fields   where-    typename = U.lookup "__typename" v >>= unpackJSONName+    typename = lookup "__typename" v >>= unpackJSONName     fields = map (bimap packName mkValue) (toAssoc v)-mkValue (A.Array ls) = mkList <$> traverse mkValue (V.toList ls)-mkValue A.Null = pure mkNull-mkValue (A.Number x) = pure $ ResScalar (decodeScientific x)-mkValue (A.String txt) = case withSelf txt of+mkValue (Array ls) = mkList <$> traverse mkValue (toList ls)+mkValue Null = pure mkNull+mkValue (Number x) = pure $ ResScalar (decodeScientific x)+mkValue (String txt) = case withSelf txt of   ARG name -> do     sel <- asks currentSelection-    mkValue (fromMaybe A.Null (getArgument name sel))-  NoAPI v -> pure $ ResScalar (String v)-mkValue (A.Bool x) = pure $ ResScalar (Boolean x)+    mkValue (fromMaybe Null (getArgument name sel))+  NoAPI v -> pure $ mkString v+mkValue (Bool x) = pure $ mkBoolean x  data SelfAPI   = ARG Text@@ -104,6 +114,29 @@ requireObject (ResObject _ x) = pure x requireObject _ = throwError (internal "resolver must be an object") -unpackJSONName :: A.Value -> Maybe TypeName-unpackJSONName (A.String x) = Just (packName x)+unpackJSONName :: Value -> Maybe TypeName+unpackJSONName (String x) = Just (packName x) unpackJSONName _ = Nothing++withField :: Monad m' => a -> (m (ResolverValue m) -> m' a) -> FieldName -> ObjectTypeResolver m -> m' a+withField fb suc selectionName ObjectTypeResolver {..} = maybe (pure fb) suc (lookup selectionName objectFields)++withObject ::+  (ResolverMonad m) =>+  Maybe TypeName ->+  (Maybe (SelectionSet VALID) -> m value) ->+  SelectionContent VALID ->+  m value+withObject __typename f = updateCurrentType __typename . checkContent+  where+    checkContent (SelectionSet selection) = f (Just selection)+    checkContent (UnionSelection interface unionSel) = do+      typename <- asks (typeName . currentType)+      selection <- selectOr (pure interface) (fx interface) typename unionSel+      f selection+      where+        fx (Just x) y = Just <$> (x <:> unionTagSelection y)+        fx Nothing y = pure $ Just $ unionTagSelection y+    checkContent SelectionField = do+      sel <- asks currentSelection+      throwError $ subfieldsNotSelected (selectionName sel) "" (selectionPosition sel)

@@ -1,3 +1,6 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+ module Data.Morpheus.App.NamedResolvers   ( ref,     object,@@ -15,7 +18,11 @@ where  import qualified Data.HashMap.Lazy as HM-import Data.Morpheus.App.Internal.Resolving.Resolver (LiftOperation, Resolver, getArgument)+import Data.Morpheus.App.Internal.Resolving.MonadResolver+  ( MonadResolver,+    getArgument,+  )+import Data.Morpheus.App.Internal.Resolving.Resolver (Resolver) import Data.Morpheus.App.Internal.Resolving.RootResolverValue (RootResolverValue (..)) import Data.Morpheus.App.Internal.Resolving.Types   ( NamedResolver (..),@@ -49,31 +56,33 @@ 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 = NamedFunction (Resolver o e m) +type NamedFunction m = [ValidValue] -> m [ResultBuilder 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)+object :: (MonadResolver m) => [(FieldName, m (ResolverValue m))] -> m (ResultBuilder m) object = pure . Object -variant :: (LiftOperation o, Monad m) => TypeName -> ValidValue -> Resolver o e m (ResultBuilder o e m)+variant :: (MonadResolver m) => TypeName -> ValidValue -> m (ResultBuilder m) variant tName = pure . Union tName -nullRes :: (LiftOperation o, Monad m) => Resolver o e m (ResultBuilder o e m)+nullRes :: (MonadResolver m) => m (ResultBuilder m) nullRes = pure Null -queryResolvers :: Monad m => [(TypeName, NamedResolverFunction QUERY e m)] -> RootResolverValue e m+queryResolvers :: Monad m => [(TypeName, NamedFunction (Resolver QUERY e m))] -> RootResolverValue e m queryResolvers = NamedResolversValue . mkResolverMap  -- INTERNAL-data ResultBuilder o e m-  = Object [(FieldName, Resolver o e m (ResolverValue (Resolver o e m)))]+data ResultBuilder m+  = Object [(FieldName, m (ResolverValue m))]   | Union TypeName ValidValue   | Null -mkResolverMap :: (LiftOperation o, Monad m) => [(TypeName, NamedResolverFunction o e m)] -> ResolverMap (Resolver o e m)+mkResolverMap :: MonadResolver m => [(TypeName, NamedFunction m)] -> ResolverMap m mkResolverMap = HM.fromList . map packRes   where-    packRes :: (LiftOperation o, Monad m) => (TypeName, NamedResolverFunction o e m) -> (TypeName, NamedResolver (Resolver o e m))+    packRes :: MonadResolver m => (TypeName, NamedFunction m) -> (TypeName, NamedResolver m)     packRes (typeName, f) = (typeName, NamedResolver typeName (fmap (map mapValue) . f))       where         mapValue (Object x) = NamedObjectResolver (ObjectTypeResolver $ HM.fromList x)

@@ -11,13 +11,12 @@ module Data.Morpheus.App.RenderIntrospection   ( render,     createObjectType,-    WithSchema,   ) where  import Control.Monad.Except (MonadError (throwError))-import Data.Morpheus.App.Internal.Resolving.Resolver-  ( Resolver,+import Data.Morpheus.App.Internal.Resolving.MonadResolver+  ( MonadResolver,     ResolverContext (..),   ) import Data.Morpheus.App.Internal.Resolving.Types@@ -46,12 +45,9 @@     FieldDefinition (..),     FieldName,     FieldsDefinition,-    GQLError,     IN,     Msg (msg),     OUT,-    QUERY,-    Schema,     TRUE,     TypeContent (..),     TypeDefinition (..),@@ -76,28 +72,14 @@ import Data.Text (pack) import Relude -class-  ( Monad m,-    MonadError GQLError m-  ) =>-  WithSchema m-  where-  getSchema :: m (Schema VALID)--instance Monad m => WithSchema (Resolver QUERY e m) where-  getSchema = schema <$> ask--selectType ::-  WithSchema m =>-  TypeName ->-  m (TypeDefinition ANY VALID)+selectType :: MonadResolver m => TypeName -> m (TypeDefinition ANY VALID) selectType name =-  getSchema+  asks schema     >>= selectBy (internal $ "INTROSPECTION Type not Found: \"" <> msg name <> "\"") name       . typeDefinitions  class RenderIntrospection a where-  render :: (Monad m, WithSchema m) => a -> m (ResolverValue m)+  render :: (MonadResolver m) => a -> m (ResolverValue m)  instance RenderIntrospection TypeName where   render = pure . mkString . unpackName@@ -150,19 +132,12 @@       } = pure $ renderContent typeContent       where         __type ::-          ( Monad m,-            WithSchema m-          ) =>+          MonadResolver m =>           TypeKind ->           [(FieldName, m (ResolverValue m))] ->           ResolverValue m         __type kind = mkType kind typeName typeDescription-        renderContent ::-          ( Monad m,-            WithSchema m-          ) =>-          TypeContent bool a VALID ->-          ResolverValue m+        renderContent :: MonadResolver m => TypeContent bool a VALID -> ResolverValue m         renderContent DataScalar {} = __type KIND_SCALAR []         renderContent (DataEnum enums) = __type KIND_ENUM [("enumValues", render enums)]         renderContent (DataInputObject inputFields) =@@ -212,10 +187,7 @@   render Null = pure mkNull   render x = pure $ mkString $ fromLBS $ GQL.render x -instance-  RenderIntrospection-    (FieldDefinition OUT VALID)-  where+instance RenderIntrospection (FieldDefinition OUT VALID) where   render FieldDefinition {..} =     pure $       mkObject "__Field" $@@ -255,7 +227,7 @@ instance RenderIntrospection TypeRef where   render TypeRef {typeConName, typeWrappers} = renderWrapper typeWrappers     where-      renderWrapper :: (Monad m, WithSchema m) => TypeWrapper -> m (ResolverValue m)+      renderWrapper :: (Monad m, MonadResolver m) => TypeWrapper -> m (ResolverValue m)       renderWrapper (TypeList nextWrapper isNonNull) =         pure $           withNonNull isNonNull $@@ -270,9 +242,7 @@           pure $ mkType kind typeConName Nothing []  withNonNull ::-  ( Monad m,-    WithSchema m-  ) =>+  MonadResolver m =>   Bool ->   ResolverValue m ->   ResolverValue m@@ -285,19 +255,13 @@ withNonNull False contentType = contentType  renderPossibleTypes ::-  (Monad m, WithSchema m) =>+  MonadResolver m =>   TypeName ->   m (ResolverValue m)-renderPossibleTypes name =-  mkList-    <$> ( getSchema-            >>= traverse render . possibleInterfaceTypes name-        )+renderPossibleTypes name = mkList <$> (asks schema >>= traverse render . possibleInterfaceTypes name)  renderDeprecated ::-  ( Monad m,-    WithSchema m-  ) =>+  MonadResolver m =>   Directives s ->   [(FieldName, m (ResolverValue m))] renderDeprecated dirs =@@ -306,17 +270,14 @@   ]  description ::-  ( Monad m,-    WithSchema m-  ) =>+  MonadResolver m =>   Maybe Description ->   (FieldName, m (ResolverValue m)) description = ("description",) . render  mkType ::   ( RenderIntrospection name,-    Monad m,-    WithSchema m+    MonadResolver m   ) =>   TypeKind ->   name ->@@ -334,7 +295,7 @@     )  createObjectType ::-  (Monad m, WithSchema m) =>+  (MonadResolver m) =>   TypeName ->   Maybe Description ->   [TypeName] ->@@ -344,7 +305,7 @@   mkType (KIND_OBJECT Nothing) name desc [("fields", render fields), ("interfaces", mkList <$> traverse implementedInterface interfaces)]  implementedInterface ::-  (Monad m, WithSchema m) =>+  (MonadResolver m) =>   TypeName ->   m (ResolverValue m) implementedInterface name =@@ -356,27 +317,26 @@  renderName ::   ( RenderIntrospection name,-    Monad m,-    WithSchema m+    MonadResolver m   ) =>   name ->   (FieldName, m (ResolverValue m)) renderName = ("name",) . render  renderKind ::-  (Monad m, WithSchema m) =>+  MonadResolver m =>   TypeKind ->   (FieldName, m (ResolverValue m)) renderKind = ("kind",) . render  type' ::-  (Monad m, WithSchema m) =>+  MonadResolver m =>   TypeRef ->   (FieldName, m (ResolverValue m)) type' = ("type",) . render  defaultValue ::-  (Monad m, WithSchema m) =>+  MonadResolver m =>   Maybe (FieldContent TRUE IN VALID) ->   ( FieldName,     m (ResolverValue m)

@@ -38,15 +38,8 @@     wrapper a ->     m (ResolverValue m) -withList ::-  ( EncodeWrapper f,-    Monad m-  ) =>-  (a -> f b) ->-  (b -> m (ResolverValue m)) ->-  a ->-  m (ResolverValue m)-withList f encodeValue = encodeWrapper encodeValue . f+withList :: (Monad m, Foldable f) => (a -> m (ResolverValue m)) -> f a -> m (ResolverValue m)+withList encodeValue = encodeWrapper encodeValue . toList  instance EncodeWrapper Maybe where   encodeWrapper = maybe (pure mkNull)@@ -55,16 +48,16 @@   encodeWrapper encodeValue = fmap mkList . traverse encodeValue  instance EncodeWrapper NonEmpty where-  encodeWrapper = withList toList+  encodeWrapper = withList  instance EncodeWrapper Seq where-  encodeWrapper = withList toList+  encodeWrapper = withList  instance EncodeWrapper Vector where-  encodeWrapper = withList toList+  encodeWrapper = withList  instance EncodeWrapper Set where-  encodeWrapper = withList toList+  encodeWrapper = withList  instance EncodeWrapper SubscriptionField where   encodeWrapper encode (SubscriptionField _ res) = encode res@@ -143,3 +136,15 @@  instance EncodeWrapperValue [] where   encodeWrapperValue f xs = List <$> traverse f xs++instance EncodeWrapperValue Set where+  encodeWrapperValue f = encodeWrapperValue f . toList++instance EncodeWrapperValue NonEmpty where+  encodeWrapperValue f = encodeWrapperValue f . toList++instance EncodeWrapperValue Seq where+  encodeWrapperValue f = encodeWrapperValue f . toList++instance EncodeWrapperValue Vector where+  encodeWrapperValue f = encodeWrapperValue f . toList

@@ -43,6 +43,8 @@     TypeName,     VALID,     ValidValue,+    Value (..),+    msg,     unpackName,   ) import Relude hiding (ByteString, fromList)@@ -65,7 +67,7 @@ require :: Monad m => NamedResolverFunction QUERY e m -> BatchedValues -> NamedResolverFunction QUERY e m require f req args   | fromList args == req = f args-  | otherwise = throwError ("was not batched! expected: " <> show req <> "got: " <> show args)+  | otherwise = throwError ("was not batched! expected: " <> msg (List $ toList req) <> "got: " <> msg (List args))  gods :: [ValidValue] gods = ["poseidon", "morpheus", "zeus"]

@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Execution+  ( runExecutionTest,+  )+where++import Control.Monad.Except (MonadError (throwError))+import Data.ByteString.Lazy.Char8 (readFile)+import Data.Morpheus.App (mkApp, runApp)+import Data.Morpheus.App.Internal.Resolving+  ( ObjectTypeResolver (..),+    Resolver,+    ResolverValue,+    RootResolverValue (..),+    mkObject,+    resultOr,+  )+import Data.Morpheus.App.NamedResolvers+  ( getArgument,+    list,+  )+import Data.Morpheus.Core+  ( parseSchema,+  )+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+    GQLResponse,+  )+import Data.Morpheus.Types.Internal.AST+  ( Msg (..),+    QUERY,+    Schema,+    VALID,+    ValidValue,+  )+import Relude hiding (ByteString, readFile)+import Test.Morpheus+  ( FileUrl,+    file,+    testApi,+  )+import Test.Tasty+  ( TestTree,+  )++type ExecState m = (StateT Int m)++type ResQ m = Resolver QUERY () (ExecState m)++getName :: ValidValue -> ResolverValue m+getName "zeus" = "Zeus"+getName "morpheus" = "Morpheus"+getName "poseidon" = "Zeus"+getName "cronos" = "Cronos"+getName _ = ""++restrictExecutions :: Monad m => Int -> ResQ m ()+restrictExecutions expected = do+  count <- lift get+  if expected == count then pure () else throwError ("unexpected execution count. expected " <> msg expected <> " but got " <> msg count <> ".")++deityResolver :: Monad m => ValidValue -> ResQ m (ResolverValue (ResQ m))+deityResolver name = do+  lift (modify (+ 1))+  pure $ mkObject "Deity" [("name", pure $ getName name)]++resolvers :: Monad m => RootResolverValue () (ExecState m)+resolvers =+  RootResolverValue+    { queryResolver =+        pure+          ( ObjectTypeResolver $+              fromList+                [ ("deity", (getArgument "id" >>= deityResolver) <* restrictExecutions 1),+                  ("deities", (list <$> traverse deityResolver ["zeus", "morpheus"]) <* restrictExecutions 2)+                ]+          ),+      mutationResolver = pure (ObjectTypeResolver mempty),+      subscriptionResolver = pure (ObjectTypeResolver mempty),+      channelMap = Nothing+    }++getSchema :: FileUrl -> IO (Schema VALID)+getSchema url = readFile (toString url) >>= resultOr (fail . show) pure . parseSchema++runExecutionTest :: FileUrl -> FileUrl -> TestTree+runExecutionTest url = testApi api+  where+    api :: GQLRequest -> IO GQLResponse+    api req = do+      schemaDeities <- getSchema (file url "schema.gql")+      (response, _) <- runStateT (runApp (mkApp schemaDeities resolvers) req) 0+      pure response

@@ -25,6 +25,7 @@   ( GQLRequest (..),     GQLResponse,   )+import Execution (runExecutionTest) import NamedResolvers (runNamedResolversTest) import Relude hiding (ByteString) import Test.Morpheus@@ -66,5 +67,6 @@       deepScan runApiTest (mkUrl "api"),       deepScan (map . runNamedResolversTest) (mkUrl "named-resolvers"),       deepScan (map . runAPIConstraints) (mkUrl "api-constraints"),-      deepScan (map . runBatchingTest) (mkUrl "batching")+      deepScan (map . runBatchingTest) (mkUrl "batching"),+      deepScan (map . runExecutionTest) (mkUrl "execution")     ]

@@ -0,0 +1,5 @@+query {+  deities {+    name+  }+}

@@ -0,0 +1,12 @@+{+  "data": {+    "deities": [+      {+        "name": "Zeus"+      },+      {+        "name": "Morpheus"+      }+    ]+  }+}

@@ -0,0 +1,8 @@+type Deity {+  name: String!+}++type Query {+  deities: [Deity!]!+  deity(id: ID): Deity+}

@@ -0,0 +1,5 @@+query {+  deity(id:"morpheus") {+    name+  }+}

@@ -0,0 +1,7 @@+{+  "data": {+    "deity": {+      "name": "Morpheus"+    }+  }+}