Improve type safety on operation interpreting

graphql-wai/src/GraphQL/Wai.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Basic WAI handlers for graphql-api
 module GraphQL.Wai
@@ -15,8 +16,8 @@ import Network.HTTP.Types.Header (hContentType)
 import Network.HTTP.Types.Status (status200, status400)
 
 import GraphQL (interpretAnonymousQuery)
-import GraphQL.API (HasObjectDefinition)
-import GraphQL.Resolver (HasResolver, Handler)
+import GraphQL.API (HasObjectDefinition, Object)
+import GraphQL.Resolver (HasResolver, Handler, OperationResolverConstraint)
 import GraphQL.Value (toValue)
 
 
@@ -27,7 +28,12 @@ import GraphQL.Value (toValue)
 -- If you have a 'Cat' type and a corresponding 'catHandler' then you
 -- can use "toApplication @Cat catHandler".
 toApplication
-  :: forall r. (HasResolver IO r, HasObjectDefinition r)
+  :: forall r typeName interfaces fields.
+  ( HasResolver IO r
+  , r ~ Object typeName interfaces fields
+  , OperationResolverConstraint IO fields typeName interfaces
+  , HasObjectDefinition r
+  )
   => Handler IO r -> Application
 toApplication handler = app
   where

scripts/hpc-ratchet

@@ -35,7 +35,7 @@ In a just world, this would be a separate config file, or command-line arguments
 Each item represents the number of "things" we are OK with not being covered.
 """
 COVERAGE_TOLERANCE = {
-    ALTERNATIVES: 161,
+    ALTERNATIVES: 160,
     BOOLEANS: 8,
     EXPRESSIONS: 1412,
     LOCAL_DECLS: 13,

src/GraphQL.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 -- | Interface for GraphQL API.
 --
 -- __Note__: This module is highly subject to change. We're still figuring
@@ -27,7 +29,7 @@ import Protolude
 import Data.Attoparsec.Text (parseOnly, endOfInput)
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
-import GraphQL.API (HasObjectDefinition(..), SchemaError(..))
+import GraphQL.API (HasObjectDefinition(..), Object, SchemaError(..))
 import GraphQL.Internal.Execution
   ( VariableValues
   , ExecutionError
@@ -51,8 +53,13 @@ import GraphQL.Internal.Output
   )
 import GraphQL.Internal.Schema (Schema)
 import qualified GraphQL.Internal.Schema as Schema
-import GraphQL.Resolver (HasResolver(..), Result(..))
-import GraphQL.Value (Name, Value, pattern ValueObject)
+import GraphQL.Resolver
+  ( HasResolver(..)
+  , OperationResolverConstraint
+  , Result(..)
+  , resolveOperation
+  )
+import GraphQL.Value (Name, Value)
 
 -- | Errors that can happen while processing a query document.
 data QueryError
@@ -85,7 +92,10 @@ instance GraphQLError QueryError where
 
 -- | Execute a GraphQL query.
 executeQuery
-  :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api)
+  :: forall api m fields typeName interfaces.
+  ( Object typeName interfaces fields ~ api
+  , OperationResolverConstraint m fields typeName interfaces
+  )
   => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it.
   -> QueryDocument VariableValue  -- ^ A validated query document. Build one with 'compileQuery'.
   -> Maybe Name -- ^ An optional name. If 'Nothing', then executes the only operation in the query. If @Just "something"@, executes the query named @"something".
@@ -94,17 +104,14 @@ executeQuery
 executeQuery handler document name variables =
   case getOperation document name variables of
     Left e -> pure (ExecutionFailure (singleError e))
-    Right operation -> toResult <$> resolve @m @api handler (Just operation)
+    Right operation ->
+      toResult
+        <$> resolveOperation @m @fields @typeName @interfaces handler operation
   where
-    toResult (Result errors result) =
-      case result of
-        -- TODO: Prevent this at compile time. Particularly frustrating since
-        -- we *know* that api has an object definition.
-        ValueObject object ->
-          case NonEmpty.nonEmpty errors of
-            Nothing -> Success object
-            Just errs -> PartialSuccess object (map toError errs)
-        v -> ExecutionFailure (singleError (NonObjectResult v))
+    toResult (Result errors object) =
+      case NonEmpty.nonEmpty errors of
+        Nothing -> Success object
+        Just errs -> PartialSuccess object (map toError errs)
 
 -- | Create a GraphQL schema.
 makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema
@@ -114,7 +121,10 @@ makeSchema = first SchemaError (Schema.makeSchema <$> getDefinition @api)
 --
 -- Compiles then executes a GraphQL query.
 interpretQuery
-  :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api)
+  :: forall api m fields typeName interfaces.
+  ( Object typeName interfaces fields ~ api
+  , OperationResolverConstraint m fields typeName interfaces
+  )
   => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it.
   -> Text -- ^ The text of a query document. Will be parsed and then executed.
   -> Maybe Name -- ^ An optional name for the operation within document to run. If 'Nothing', execute the only operation in the document. If @Just "something"@, execute the query or mutation named @"something"@.
@@ -129,7 +139,10 @@ interpretQuery handler query name variables =
 --
 -- Anonymous queries have no name and take no variables.
 interpretAnonymousQuery
-  :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api)
+  :: forall api m fields typeName interfaces.
+  ( Object typeName interfaces fields ~ api
+  , OperationResolverConstraint m fields typeName interfaces
+  )
   => Handler m api -- ^ Handler for the anonymous query.
   -> Text -- ^ The text of the anonymous query. Should defined only a single, unnamed query operation.
   -> m Response -- ^ The result of running the query.

src/GraphQL/Internal/Resolver.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -18,9 +19,11 @@
 module GraphQL.Internal.Resolver
   ( ResolverError(..)
   , HasResolver(..)
+  , OperationResolverConstraint
   , (:<>)(..)
   , Result(..)
   , unionValue
+  , resolveOperation
   ) where
 
 -- TODO (probably incomplete, the spec is large)
@@ -147,6 +150,21 @@ class HasResolver m a where
   type Handler m a
   resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value)
 
+type OperationResolverConstraint m fields typeName interfaces =
+    ( RunFields m (RunFieldsType m fields)
+    , API.HasObjectDefinition (API.Object typeName interfaces fields)
+    , Monad m
+    )
+
+resolveOperation
+  :: forall m fields typeName interfaces.
+  ( OperationResolverConstraint m fields typeName interfaces )
+  => Handler m (API.Object typeName interfaces fields)
+  -> SelectionSetByType Value
+  -> m (Result GValue.Object)
+resolveOperation handler ss =
+  resolveObject @m @fields @typeName @interfaces handler ss
+
 -- | Called when the schema expects an input argument @name@ of type @a@ but
 -- @name@ has not been provided.
 valueMissing :: API.Defaultable a => Name -> Either ResolverError a
@@ -357,6 +375,40 @@ instance forall m a b dispatchType.
     where
       nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing)
 
+resolveObject
+  :: forall m fields typeName interfaces.
+  ( OperationResolverConstraint m fields typeName interfaces )
+  => Handler m (API.Object typeName interfaces fields)
+  -> SelectionSetByType Value
+  -> m (Result GValue.Object)
+resolveObject mHandler selectionSet =
+  case getSelectionSet of
+    Left err -> return (Result [err] (GValue.Object' OrderedMap.empty))
+    Right ss -> do
+      -- Run the handler so the field resolvers have access to the object.
+      -- This (and other places, including field resolvers) is where user
+      -- code can do things like look up something in a database.
+      handler <- mHandler
+      r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss
+      let (Result errs obj)  = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r
+      pure (Result errs obj)
+
+  where
+    getSelectionSet = do
+      defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields)
+      -- Fields of a selection set may be behind "type conditions", due to
+      -- inline fragments or the use of fragment spreads. These type
+      -- conditions are represented in the schema by the name of a type
+      -- (e.g. "Dog"). To determine which type conditions (and thus which
+      -- fields) are relevant for this 1selection set, we need to look up the
+      -- actual types they refer to, as interfaces (say) match objects
+      -- differently than unions.
+      --
+      -- See <https://facebook.github.io/graphql/#sec-Field-Collection> for
+      -- more details.
+      (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet
+      pure ss'
+
 instance forall typeName interfaces fields m.
          ( RunFields m (RunFieldsType m fields)
          , API.HasObjectDefinition (API.Object typeName interfaces fields)
@@ -365,33 +417,9 @@ instance forall typeName interfaces fields m.
   type Handler m (API.Object typeName interfaces fields) = m (RunFieldsHandler m (RunFieldsType m fields))
 
   resolve _ Nothing = throwE MissingSelectionSet
-  resolve mHandler (Just selectionSet) =
-    case getSelectionSet of
-      Left err -> throwE err
-      Right ss -> do
-        -- Run the handler so the field resolvers have access to the object.
-        -- This (and other places, including field resolvers) is where user
-        -- code can do things like look up something in a database.
-        handler <- mHandler
-        r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss
-        let (Result errs obj)  = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r
-        pure (Result errs (GValue.ValueObject obj))
-
-    where
-      getSelectionSet = do
-        defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields)
-        -- Fields of a selection set may be behind "type conditions", due to
-        -- inline fragments or the use of fragment spreads. These type
-        -- conditions are represented in the schema by the name of a type
-        -- (e.g. "Dog"). To determine which type conditions (and thus which
-        -- fields) are relevant for this 1selection set, we need to look up the
-        -- actual types they refer to, as interfaces (say) match objects
-        -- differently than unions.
-        --
-        -- See <https://facebook.github.io/graphql/#sec-Field-Collection> for
-        -- more details.
-        (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet
-        pure ss'
+  resolve handler (Just ss) = do
+    result <- resolveObject @m @fields @typeName @interfaces handler ss
+    return $ GValue.ValueObject <$> result
 
 -- TODO(tom): we're getting to a point where it might make sense to
 -- split resolver into submodules (GraphQL.Resolver.Union  etc.)

src/GraphQL/Resolver.hs

@@ -2,17 +2,15 @@
 --
 -- Contains everything you need to write handlers for your GraphQL schema.
 module GraphQL.Resolver
-  ( ResolverError(..)
-  , HasResolver(..)
-  , (:<>)(..)
-  , Result(..)
-  , unionValue
+  ( module Export
   ) where
 
-import GraphQL.Internal.Resolver
+import GraphQL.Internal.Resolver as Export
   ( ResolverError(..)
   , HasResolver(..)
+  , OperationResolverConstraint
   , (:<>)(..)
   , Result(..)
   , unionValue
+  , resolveOperation
   )