diff --git a/scripts/hpc-ratchet b/scripts/hpc-ratchet index cec41f0..8332502 100755 --- a/scripts/hpc-ratchet +++ b/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: 155, BOOLEANS: 8, - EXPRESSIONS: 1412, - LOCAL_DECLS: 13, - TOP_LEVEL_DECLS: 669, + EXPRESSIONS: 1366, + LOCAL_DECLS: 10, + TOP_LEVEL_DECLS: 673, } diff --git a/src/GraphQL/Internal/Validation.hs b/src/GraphQL/Internal/Validation.hs index 88e02e1..9ad0eb5 100644 --- a/src/GraphQL/Internal/Validation.hs +++ b/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