Reduce operation type repetition

scripts/hpc-ratchet

@@ -35,11 +35,11 @@ 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: 160,
+    ALTERNATIVES: 154,
     BOOLEANS: 8,
-    EXPRESSIONS: 1412,
-    LOCAL_DECLS: 13,
-    TOP_LEVEL_DECLS: 669,
+    EXPRESSIONS: 1366,
+    LOCAL_DECLS: 10,
+    TOP_LEVEL_DECLS: 673,
 }
 
 

src/GraphQL/Internal/Validation.hs

@@ -107,30 +107,34 @@ data QueryDocument value
   | MultipleOperations (Operations value)
   deriving (Eq, Show)
 
+
+data OperationType
+  = Mutation
+  | Query
+  deriving (Eq, Show)
+
 data Operation value
-  = Query VariableDefinitions (Directives value) (SelectionSetByType value)
-  | Mutation VariableDefinitions (Directives value) (SelectionSetByType value)
+  = Operation OperationType VariableDefinitions (Directives value) (SelectionSetByType value)
   deriving (Eq, Show)
 
 instance Functor Operation where
-  fmap f (Query vars directives selectionSet) = Query vars (fmap f directives) (fmap f selectionSet)
-  fmap f (Mutation vars directives selectionSet) = Mutation vars (fmap f directives) (fmap f selectionSet)
+  fmap f (Operation operationType vars directives selectionSet)
+    = Operation operationType vars (fmap f directives) (fmap f selectionSet)
 
 instance Foldable Operation where
-  foldMap f (Query _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet
-  foldMap f (Mutation _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet
+  foldMap f (Operation _ _ directives selectionSet)
+    = foldMap f directives `mappend` foldMap f selectionSet
 
 instance Traversable Operation where
-  traverse f (Query vars directives selectionSet) = Query vars <$> traverse f directives <*> traverse f selectionSet
-  traverse f (Mutation vars directives selectionSet) = Mutation vars <$> traverse f directives <*> traverse f selectionSet
+  traverse f (Operation operationType vars directives selectionSet)
+    = Operation operationType vars <$> traverse f directives <*> traverse f selectionSet
 
 -- | Get the selection set for an operation.
 getSelectionSet :: Operation value -> SelectionSetByType value
-getSelectionSet (Query _ _ ss) = ss
-getSelectionSet (Mutation _ _ ss) = ss
+getSelectionSet (Operation _ _ _ ss) = ss
 
 -- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'.
-type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value
+type OperationBuilder value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value
 
 type Operations value = Map (Maybe Name) (Operation value)
 
@@ -154,7 +158,7 @@ validate schema (AST.QueryDocument defns) = runValidator $ do
       assertAllFragmentsUsed frags (visitedFrags <> usedFrags)
       validValuesSS <- validateValues ss
       resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS
-      pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS))
+      pure (LoneAnonymousOperation (Operation Query emptyVariableDefinitions emptyDirectives resolvedValuesSS))
     _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed))
 
   where
@@ -165,41 +169,29 @@ validate schema (AST.QueryDocument defns) = runValidator $ do
     splitDefns (AST.DefinitionFragment frag) = Right frag
 
     splitOps (AST.AnonymousQuery ss) = Left ss
-    splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Query, node))
-    splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Mutation, node))
+    splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Operation Query, node))
+    splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Operation Mutation, node))
 
     assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation ()
     assertAllFragmentsUsed fragments used =
-      let unused = ( Set.map pure (Map.keysSet fragments)) `Set.difference` used
+      let unused = Set.map pure (Map.keysSet fragments) `Set.difference` used
       in unless (Set.null unused) (throwE (UnusedFragments unused))
 
 -- * Operations
 
-validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationType AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value)
+validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationBuilder AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value)
 validateOperations schema fragments ops = do
   deduped <- lift (mapErrors DuplicateOperation (makeMap ops))
   traverse validateNode deduped
   where
-    validateNode (operationType, AST.Node _ vars directives ss) =
-      operationType <$> lift (validateVariableDefinitions schema vars)
+    validateNode (operationBuilder, AST.Node _ vars directives ss) =
+      operationBuilder <$> lift (validateVariableDefinitions schema vars)
                     <*> lift (validateDirectives directives)
                     <*> validateSelectionSet schema fragments ss
 
--- TODO: Either make operation type (Query, Mutation) a parameter of an
--- Operation constructor or give all the fields accessors. This duplication is
--- driving me batty.
 validateOperation :: Operation AST.Value -> Validation (Operation VariableValue)
-validateOperation (Query vars directives selectionSet) = do
-  validValues <- Query vars <$> validateValues directives <*> validateValues selectionSet
-  -- Instead of doing this, we could build up a list of used variables as we
-  -- resolve them.
-  let usedVariables = getVariables validValues
-  let definedVariables = getDefinedVariables vars
-  let unusedVariables = definedVariables `Set.difference` usedVariables
-  unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables)
-  resolveVariables vars validValues
-validateOperation (Mutation vars directives selectionSet) = do
-  validValues <- Mutation vars <$> validateValues directives <*> validateValues selectionSet
+validateOperation (Operation operationType vars directives selectionSet) = do
+  validValues <- Operation operationType vars <$> validateValues directives <*> validateValues selectionSet
   -- Instead of doing this, we could build up a list of used variables as we
   -- resolve them.
   let usedVariables = getVariables validValues