Merge selections in a set into ordered map of fields

HLint.hs

@@ -3,3 +3,4 @@ import "hint" HLint.Generalise
 
 ignore "Use fmap"
 ignore "Redundant do"
+ignore "Use =<<"

graphql-wai/src/GraphQL/Wai.hs

@@ -2,13 +2,15 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
+-- | Basic WAI handlers for graphql-api
 module GraphQL.Wai
   ( toApplication
   ) where
 
 import Protolude
 
 import GraphQL (interpretAnonymousQuery)
+import GraphQL.API (HasObjectDefinition)
 import GraphQL.Resolver (HasResolver, Handler)
 import Network.Wai (Application, queryString, responseLBS)
 import GraphQL.Value.ToValue (toValue)
@@ -23,7 +25,9 @@ import qualified Data.Aeson as Aeson
 --
 -- If you have a 'Cat' type and a corresponding 'catHandler' then you
 -- can use "toApplication @Cat catHandler".
-toApplication :: forall r. (HasResolver IO r) => Handler IO r -> Application
+toApplication
+  :: forall r. (HasResolver IO r, HasObjectDefinition r)
+  => Handler IO r -> Application
 toApplication handler = app
   where
     app req respond =

src/GraphQL.hs

@@ -7,21 +7,27 @@
 -- __Note__: This module is highly subject to change. We're still figuring
 -- where to draw the lines and what to expose.
 module GraphQL
-  ( QueryError
+  (
+    -- * Running queries
+    interpretQuery
+  , interpretAnonymousQuery
   , Response(..)
-  , VariableValues
-  , Value
+    -- * Preparing queries then running them
+  , makeSchema
   , compileQuery
   , executeQuery
-  , interpretQuery
-  , interpretAnonymousQuery
+  , QueryError
+  , Schema
+  , VariableValues
+  , Value
   ) where
 
 import Protolude
 
 import Data.Attoparsec.Text (parseOnly, endOfInput)
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
+import GraphQL.API (HasObjectDefinition(..))
 import GraphQL.Internal.Execution
   ( VariableValues
   , ExecutionError
@@ -32,20 +38,21 @@ import qualified GraphQL.Internal.Syntax.AST as AST
 import qualified GraphQL.Internal.Syntax.Parser as Parser
 import GraphQL.Internal.Validation
   ( QueryDocument
-  , SelectionSet
+  , SelectionSetByType
   , ValidationErrors
   , validate
   , getSelectionSet
   , VariableValue
   )
 import GraphQL.Internal.Output
   ( GraphQLError(..)
-  , Error(..)
   , Response(..)
   , singleError
   )
+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.Value (Name, NameError, Value, pattern ValueObject)
 
 -- | Errors that can happen while processing a query document.
 data QueryError
@@ -58,6 +65,8 @@ data QueryError
   | ValidationError ValidationErrors
   -- | Validated, but failed during execution.
   | ExecutionError ExecutionError
+  -- | Error in the schema.
+  | SchemaError NameError
   -- | Got a value that wasn't an object.
   | NonObjectResult Value
   deriving (Eq, Show)
@@ -69,12 +78,14 @@ instance GraphQLError QueryError where
     "Validation errors:\n" <> mconcat ["  " <> formatError e <> "\n" | e <- NonEmpty.toList es]
   formatError (ExecutionError e) =
     "Execution error: " <> show e
+  formatError (SchemaError e) =
+    "Schema error: " <> formatError e
   formatError (NonObjectResult v) =
     "Query returned a value that is not an object: " <> show v
 
 -- | Execute a GraphQL query.
 executeQuery
-  :: forall api m. (HasResolver m api, Applicative m)
+  :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api)
   => 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".
@@ -83,59 +94,59 @@ 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 operation
+    Right operation -> toResult <$> resolve @m @api handler (Just operation)
   where
     toResult (Result errors result) =
       case result of
-        -- TODO: Prevent this at compile time.
+        -- 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))
 
+-- | Create a GraphQL schema.
+makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema
+makeSchema = first SchemaError (Schema.makeSchema <$> getDefinition @api)
+
 -- | Interpet a GraphQL query.
 --
 -- Compiles then executes a GraphQL query.
 interpretQuery
-  :: forall api m. (Applicative m, HasResolver m api)
+  :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api)
   => 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"@.
   -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'.
   -> m Response -- ^ The outcome of running the query.
 interpretQuery handler query name variables =
-  case parseQuery query of
-    Left err -> pure (PreExecutionFailure (Error err [] :| []))
-    Right parsed ->
-      case validate parsed of
-        Left errs -> pure (PreExecutionFailure (map toError errs))
-        Right document ->
-          executeQuery @api @m handler document name variables
-
+  case makeSchema @api >>= flip compileQuery query of
+    Left err -> pure (PreExecutionFailure (toError err :| []))
+    Right document -> executeQuery @api @m handler document name variables
 
 -- | Interpret an anonymous GraphQL query.
 --
 -- Anonymous queries have no name and take no variables.
 interpretAnonymousQuery
-  :: forall api m. (Applicative m, HasResolver m api)
+  :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api)
   => 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.
 interpretAnonymousQuery handler query = interpretQuery @api @m handler query Nothing mempty
 
 -- | Turn some text into a valid query document.
-compileQuery :: Text -> Either QueryError (QueryDocument VariableValue)
-compileQuery query = do
+compileQuery :: Schema -> Text -> Either QueryError (QueryDocument VariableValue)
+compileQuery schema query = do
   parsed <- first ParseError (parseQuery query)
-  first ValidationError (validate parsed)
+  first ValidationError (validate schema parsed)
 
 -- | Parse a query document.
 parseQuery :: Text -> Either Text AST.QueryDocument
 parseQuery query = first toS (parseOnly (Parser.queryDocument <* endOfInput) query)
 
 -- | Get an operation from a query document ready to be processed.
-getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (SelectionSet Value)
+getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (SelectionSetByType Value)
 getOperation document name vars = first ExecutionError $ do
   op <- Execution.getOperation document name
   resolved <- substituteVariables op vars

src/GraphQL/Internal/OrderedMap.hs

@@ -36,9 +36,15 @@ module GraphQL.Internal.OrderedMap
   , orderedMap
   -- * Querying
   , lookup
+  -- * Filtering
+  , GraphQL.Internal.OrderedMap.catMaybes
   -- * Combine
   -- ** Union
   , unions
+  , unionWith
+  , unionsWith
+  , unionWithM
+  , unionsWithM
   -- * Conversion
   , toList
   , toMap
@@ -69,7 +75,7 @@ data OrderedMap key value
 --
 -- /O(n log n)/
 toList :: forall key value. Ord key => OrderedMap key value -> [(key, value)]
-toList (OrderedMap keys entries) = catMaybes (foreach keys $ \k -> (,) k <$> Map.lookup k entries)
+toList (OrderedMap keys entries) = Protolude.catMaybes (foreach keys $ \k -> (,) k <$> Map.lookup k entries)
 
 instance Foldable (OrderedMap key) where
   foldr f z (OrderedMap _ entries) = foldr f z entries
@@ -120,6 +126,61 @@ values = map snd . toList
 unions :: forall key value. Ord key => [OrderedMap key value] -> Maybe (OrderedMap key value)
 unions orderedMaps = orderedMap (orderedMaps >>= toList)
 
+-- | Append the second ordered map to the first, combining any shared elements
+-- with the given function.
+unionWith :: Ord key
+          => (value -> value -> value)
+          -> OrderedMap key value
+          -> OrderedMap key value
+          -> OrderedMap key value
+unionWith f x y =
+  OrderedMap
+  { toMap = Map.unionWith f (toMap x) (toMap y)
+  , keys = keys x <> [k | k <- keys y, k `Map.notMember` toMap x]
+  }
+
+-- | Append together a list of ordered maps, preserving ordering of keys.
+-- Combine any shared elements with the given function.
+unionsWith :: Ord key
+           => (value -> value -> value)
+           -> [OrderedMap key value]
+           -> OrderedMap key value
+unionsWith f = foldl' (unionWith f) empty
+
+-- | Take two ordered maps, append the second one to the first. If the second
+-- contains any keys that also appear in the first, combine the two values
+-- with the given function.
+unionWithM :: (Monad m, Ord key)
+           => (value -> value -> m value)
+           -> OrderedMap key value
+           -> OrderedMap key value
+           -> m (OrderedMap key value)
+unionWithM f x y = sequenceA (unionWith (liftMM f) (map pure x) (map pure y))
+
+-- | Take a list of ordered maps and append them together. Any shared elements
+-- are combined using the given function.
+unionsWithM :: (Monad m, Ord key)
+            => (value -> value -> m value)
+            -> [OrderedMap key value]
+            -> m (OrderedMap key value)
+unionsWithM f xs = sequenceA (unionsWith (liftMM f) (map (map pure) xs))
+
+liftMM :: Monad m => (a -> b -> m c) -> m a -> m b -> m c
+liftMM f a' b' = do
+  (a, b) <- (,) <$> a' <*> b'
+  f a b
+
+-- | Take an ordered map with 'Maybe' values and return the same map with all
+-- the 'Nothing' values removed.
+catMaybes :: Ord key => OrderedMap key (Maybe value) -> OrderedMap key value
+catMaybes xs =
+  OrderedMap
+  { keys = [ k | k <- keys xs, k `Map.member` newMap ]
+  , toMap = newMap
+  }
+  where
+    newMap = Map.mapMaybe identity (toMap xs)
+
 -- | Construct an ordered map from a list.
 --
 -- /O(n log n)/.