Replace ParseT with Parse

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4724
GitOrigin-RevId: d742bc876ca11dbbe7e3f02bbdf9bf9c2440cbe6

server/src-lib/Hasura/GraphQL/Execute.hs

@@ -395,8 +395,10 @@ getResolvedExecPlan
           let parameterizedQueryHash = calculateParameterizedQueryHash normalizedSelectionSet
           -- Process directives on the subscription
           dirMap <-
-            (`onLeft` reportParseErrors)
+            liftEither $
-              =<< runParseT (parseDirectives customDirectives (G.DLExecutable G.EDLSUBSCRIPTION) normalizedDirectives)
+              runParse (parseDirectives customDirectives (G.DLExecutable G.EDLSUBSCRIPTION) normalizedDirectives)
+                `onLeft` reportParseErrors
+
           -- A subscription should have exactly one root field.
           -- However, for testing purposes, we may allow several root fields; we check for this by
           -- looking for directive "_multiple_top_level_fields" on the subscription. THIS IS NOT A

server/src-lib/Hasura/GraphQL/Execute/Mutation.hs

@@ -112,8 +112,9 @@ convertMutationSelectionSet
 
     -- Process directives on the mutation
     _dirMap <-
-      (`onLeft` reportParseErrors)
+      liftEither $
-        =<< runParseT (parseDirectives customDirectives (G.DLExecutable G.EDLMUTATION) resolvedDirectives)
+        runParse (parseDirectives customDirectives (G.DLExecutable G.EDLMUTATION) resolvedDirectives)
+          `onLeft` reportParseErrors
 
     let parameterizedQueryHash = calculateParameterizedQueryHash resolvedSelSet
 

server/src-lib/Hasura/GraphQL/Execute/Query.hs

@@ -96,8 +96,9 @@ convertQuerySelSet
 
     -- 2. Parse directives on the query
     dirMap <-
-      (`onLeft` reportParseErrors)
+      liftEither
-        =<< runParseT (parseDirectives customDirectives (G.DLExecutable G.EDLQUERY) normalizedDirectives)
+        (runParse (parseDirectives customDirectives (G.DLExecutable G.EDLQUERY) normalizedDirectives))
+        `onLeft` reportParseErrors
 
     let parameterizedQueryHash = calculateParameterizedQueryHash normalizedSelectionSet
 

server/src-lib/Hasura/GraphQL/Parser/Monad.hs

@@ -2,13 +2,14 @@
 module Hasura.GraphQL.Parser.Monad
   ( SchemaT,
     runSchemaT,
-    ParseT,
+    Parse,
-    runParseT,
+    runParse,
     ParseError (..),
     reportParseErrors,
   )
 where
 
+import Control.Monad.Except
 import Data.Dependent.Map (DMap)
 import Data.Dependent.Map qualified as DM
 import Data.GADT.Compare.Extended
@@ -160,25 +161,22 @@ newtype instance ParserById m '(p, a) = ParserById (p m a)
 -- -------------------------------------------------------------------------------------------------
 -- query parsing
 
-newtype ParseT m a = ParseT
+newtype Parse a = Parse
-  { unParseT :: ReaderT JSONPath (ExceptT ParseError m) a
+  { unParse :: ReaderT JSONPath (Except ParseError) a
   }
   deriving (Functor, Applicative, Monad)
 
-runParseT ::
+runParse ::
-  ParseT m a ->
+  Parse a ->
-  m (Either ParseError a)
+  Either ParseError a
-runParseT =
+runParse =
-  unParseT
+  unParse
     >>> flip runReaderT []
-    >>> runExceptT
+    >>> runExcept
 
-instance MonadTrans ParseT where
+instance MonadParse Parse where
-  lift = ParseT . lift . lift
+  withPath f x = Parse $ withReaderT f $ unParse x
-
+  parseErrorWith code text = Parse $ do
-instance Monad m => MonadParse (ParseT m) where
-  withPath f x = ParseT $ withReaderT f $ unParseT x
-  parseErrorWith code text = ParseT $ do
     path <- ask
     lift $ throwError $ ParseError {peCode = code, pePath = path, peMessage = text}
 

server/src-lib/Hasura/GraphQL/RemoteServer.hs

@@ -21,7 +21,7 @@ import Data.Text qualified as T
 import Data.Text.Extended (dquoteList, (<<>))
 import Hasura.Base.Error
 import Hasura.GraphQL.Parser.Constants qualified as G
-import Hasura.GraphQL.Parser.Monad (ParseT, runSchemaT)
+import Hasura.GraphQL.Parser.Monad (Parse, runSchemaT)
 import Hasura.GraphQL.Schema.Common
 import Hasura.GraphQL.Schema.Remote (buildRemoteParser)
 import Hasura.GraphQL.Transport.HTTP.Protocol
@@ -80,7 +80,7 @@ fetchRemoteSchema env manager _rscName rsDef@ValidatedRemoteSchemaDef {..} = do
   void $
     flip runReaderT minimumValidContext $
       runSchemaT $
-        buildRemoteParser @_ @_ @(ParseT Identity)
+        buildRemoteParser @_ @_ @Parse
           _rscIntroOriginal
           _rscRemoteRelationships
           _rscInfo
@@ -256,14 +256,14 @@ validateSchemaCustomizationsDistinct remoteSchemaCustomizer (RemoteSchemaIntrosp
     validateFieldMappingsAreDistinct :: G.TypeDefinition a b -> m ()
     validateFieldMappingsAreDistinct = \case
       G.TypeDefinitionInterface G.InterfaceTypeDefinition {..} -> do
-        let dups = duplicates $ (customizeFieldName _itdName . G._fldName) <$> _itdFieldsDefinition
+        let dups = duplicates $ customizeFieldName _itdName . G._fldName <$> _itdFieldsDefinition
         unless (Set.null dups) $
           throwRemoteSchema $
             "Field name mappings for interface type " <> _itdName
               <<> " are not distinct; the following fields appear more than once: "
               <> dquoteList dups
       G.TypeDefinitionObject G.ObjectTypeDefinition {..} -> do
-        let dups = duplicates $ (customizeFieldName _otdName . G._fldName) <$> _otdFieldsDefinition
+        let dups = duplicates $ customizeFieldName _otdName . G._fldName <$> _otdFieldsDefinition
         unless (Set.null dups) $
           throwRemoteSchema $
             "Field name mappings for object type " <> _otdName

server/src-lib/Hasura/GraphQL/Schema.hs

@@ -260,10 +260,10 @@ buildRoleContext options sources remotes allActionInfos customTypes role remoteS
       SourceInfo b ->
       ConcreteSchemaT
         m
-        ( [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))],
+        ( [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))],
-          [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))],
+          [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))],
-          [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))],
+          [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))],
-          [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))]
+          [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))]
         )
     buildSource sourceInfo@(SourceInfo _ tables functions _ _ sourceCustomization') =
       withSourceCustomization sourceCustomization (namingConventionSupport @b) globalDefaultNC do
@@ -378,10 +378,10 @@ buildRelayRoleContext options sources allActionInfos customTypes role expFeature
       SourceInfo b ->
       ConcreteSchemaT
         m
-        ( [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))],
+        ( [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))],
-          [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))],
+          [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))],
-          [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))],
+          [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))],
-          [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))]
+          [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))]
         )
     buildSource sourceInfo@(SourceInfo _ tables functions _ _ sourceCustomization') =
       withSourceCustomization sourceCustomization (namingConventionSupport @b) globalDefaultNC do
@@ -496,11 +496,11 @@ buildAndValidateRemoteSchemas ::
     MonadIO m
   ) =>
   HashMap RemoteSchemaName (RemoteSchemaCtx, MetadataObject) ->
-  [FieldParser (P.ParseT Identity) (NamespacedField (QueryRootField UnpreparedValue))] ->
+  [FieldParser P.Parse (NamespacedField (QueryRootField UnpreparedValue))] ->
-  [FieldParser (P.ParseT Identity) (NamespacedField (MutationRootField UnpreparedValue))] ->
+  [FieldParser P.Parse (NamespacedField (MutationRootField UnpreparedValue))] ->
   RoleName ->
   RemoteSchemaPermsCtx ->
-  ConcreteSchemaT m ([RemoteSchemaParser (P.ParseT Identity)], HashSet InconsistentMetadata)
+  ConcreteSchemaT m ([RemoteSchemaParser P.Parse], HashSet InconsistentMetadata)
 buildAndValidateRemoteSchemas remotes sourcesQueryFields sourcesMutationFields role remoteSchemaPermsCtx =
   runWriterT $ foldlM step [] (Map.elems remotes)
   where
@@ -551,7 +551,7 @@ buildRemoteSchemaParser ::
   RemoteSchemaPermsCtx ->
   RoleName ->
   RemoteSchemaCtx ->
-  ConcreteSchemaT m (Maybe (RemoteSchemaParser (P.ParseT Identity)))
+  ConcreteSchemaT m (Maybe (RemoteSchemaParser P.Parse))
 buildRemoteSchemaParser remoteSchemaPermsCtx roleName context = do
   let maybeIntrospection = getIntrospectionResult remoteSchemaPermsCtx roleName context
   for maybeIntrospection \introspection ->
@@ -668,7 +668,7 @@ buildMutationFields scenario sourceInfo tables (takeExposedAs FEAMutation -> fun
     guard $
       -- when function permissions are inferred, we don't expose the
       -- mutation functions for non-admin roles. See Note [Function Permissions]
-      roleName == adminRoleName || roleName `Map.member` (_fiPermissions functionInfo)
+      roleName == adminRoleName || roleName `Map.member` _fiPermissions functionInfo
     lift $ mkRFs MDBR $ buildFunctionMutationFields sourceInfo functionName functionInfo targetTableName
   pure $ concat $ tableMutations <> catMaybes functionMutations
   where
@@ -835,8 +835,8 @@ mkRootFields ::
   SourceConfig b ->
   Maybe QueryTagsConfig ->
   (a -> db b) ->
-  m [(FieldParser n a)] ->
+  m [FieldParser n a] ->
-  m [(FieldParser n (RootField db remote action raw))]
+  m [FieldParser n (RootField db remote action raw)]
 mkRootFields sourceName sourceConfig queryTagsConfig inj =
   fmap
     ( map
@@ -855,12 +855,12 @@ mutationRoot = G._mutation_root
 queryRoot :: G.Name
 queryRoot = G._query_root
 
-finalizeParser :: Parser 'Output (P.ParseT Identity) a -> ParserFn a
+finalizeParser :: Parser 'Output P.Parse a -> ParserFn a
-finalizeParser parser = runIdentity . P.runParseT . P.runParser parser
+finalizeParser parser = P.runParse . P.runParser parser
 
 type ConcreteSchemaT m a =
   P.SchemaT
-    (P.ParseT Identity)
+    P.Parse
     ( ReaderT
         ( SchemaOptions,
           SchemaContext,

server/src-lib/Hasura/GraphQL/Schema/Introspect.hs

@@ -206,9 +206,9 @@ buildIntrospectionSchema queryRoot' mutationRoot' subscriptionRoot' = do
   let -- The only directives that we currently expose over introspection are our
       -- statically defined ones.  So, for instance, we don't correctly expose
       -- directives from remote schemas.
-      directives = directivesInfo @(P.ParseT Identity)
+      directives = directivesInfo @P.Parse
       -- The __schema and __type introspection fields
-      introspection = [schema @(P.ParseT Identity), typeIntrospection]
+      introspection = [schema @P.Parse, typeIntrospection]
       {-# INLINE introspection #-}
 
   -- Collect type information of all non-introspection fields