Validate all fragments are used

CHANGELOG.md

@@ -8,22 +8,27 @@ and this project adheres to
 
 ## [Unreleased]
 ### Changed
-- `AST.Document.Selection` wraps additional new types: `FragmentSpread`
+- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
-  and  `InlineFragment`. Thus validation rules can be more concise.
+  and  `InlineFragment`. Thus validation rules can be defined more concise.
 
 ### Added
-- `Validate.Validation.Rule`: `SelectionRule`, `FragmentRule` and
+- `Validate.Validation.Rule`: `SelectionRule`, `FieldRule`, `FragmentRule` and
   `FragmentSpreadRule` constructors.
 - `Validate.Rules`:
   - `fragmentsOnCompositeTypesRule`
   - `fragmentSpreadTargetDefinedRule`
   - `fragmentSpreadTypeExistenceRule`
+  - `noUnusedFragmentsRule`
+- `AST.Document.Field`.
 - `AST.Document.FragmentSpread`.
 - `AST.Document.InlineFragment`.
 
 ### Fixed
 - Collecting existing types from the schema considers subscriptions.
 
+### Removed
+- `AST.Document.Alias`. Use `AST.Document.Name` instead.
+
 ## [0.10.0.0] - 2020-08-29
 ### Changed
 - `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`.

src/Language/GraphQL/AST/Document.hs

@@ -5,8 +5,7 @@
 -- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
 -- for more information.
 module Language.GraphQL.AST.Document
-    ( Alias
+    ( Argument(..)
-    , Argument(..)
     , ArgumentsDefinition(..)
     , ConstValue(..)
     , Definition(..)
@@ -15,6 +14,7 @@ module Language.GraphQL.AST.Document
     , Document
     , EnumValueDefinition(..)
     , ExecutableDefinition(..)
+    , Field(..)
     , FieldDefinition(..)
     , FragmentDefinition(..)
     , FragmentSpread(..)
@@ -118,9 +118,14 @@ type SelectionSet = NonEmpty Selection
 -- | Field selection.
 type SelectionSetOpt = [Selection]
 
--- | Selection is a single entry in a selection set. It can be a single field,
+-- | Selection is a single entry in a selection set. It can be a single 'Field',
--- fragment spread or inline fragment.
+-- 'FragmentSpread' or an 'InlineFragment'.
---
+data Selection
+    = FieldSelection Field
+    | FragmentSpreadSelection FragmentSpread
+    | InlineFragmentSelection InlineFragment
+    deriving (Eq, Show)
+
 -- The only required property of a field is its name. Optionally it can also
 -- have an alias, arguments, directives and a list of subfields.
 --
@@ -134,10 +139,8 @@ type SelectionSetOpt = [Selection]
 --   }
 -- }
 -- @
-data Selection
+data Field =
-    = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt Location
+    Field (Maybe Name) Name [Argument] [Directive] SelectionSetOpt Location
-    | FragmentSpreadSelection FragmentSpread
-    | InlineFragmentSelection InlineFragment
     deriving (Eq, Show)
 
 -- Inline fragments don't have any name and the type condition ("on UserType")
@@ -189,22 +192,6 @@ data FragmentSpread = FragmentSpread Name [Directive] Location
 --  Here "id" is an argument for the field "user" and its value is 4.
 data Argument = Argument Name Value deriving (Eq,Show)
 
--- ** Field Alias
-
--- | Alternative field name.
---
--- @
--- {
---   smallPic: profilePic(size: 64)
---   bigPic: profilePic(size: 1024)
--- }
--- @
---
--- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
--- used to distinquish between profile pictures with different arguments
--- (sizes).
-type Alias = Name
-
 -- ** Fragments
 
 -- | Fragment definition.

src/Language/GraphQL/AST/Encoder.hs

@@ -126,8 +126,8 @@ indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
 selection :: Formatter -> Selection -> Lazy.Text
 selection formatter = Lazy.Text.append indent' . encodeSelection
   where
-    encodeSelection (Field alias name args directives' selections _) =
+    encodeSelection (FieldSelection fieldSelection) =
-        field incrementIndent alias name args directives' selections
+        field incrementIndent fieldSelection
     encodeSelection (InlineFragmentSelection fragmentSelection) =
         inlineFragment incrementIndent fragmentSelection
     encodeSelection (FragmentSpreadSelection fragmentSelection) =
@@ -142,15 +142,9 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
 colon :: Formatter -> Lazy.Text
 colon formatter = eitherFormat formatter ": " ":"
 
--- | Converts Field into a string
+-- | Converts Field into a string.
-field :: Formatter ->
+field :: Formatter -> Field -> Lazy.Text
-    Maybe Name ->
+field formatter (Field alias name args dirs set _)
-    Name ->
-    [Argument] ->
-    [Directive] ->
-    [Selection] ->
-    Lazy.Text
-field formatter alias name args dirs set
     = optempty prependAlias (fold alias)
     <> Lazy.Text.fromStrict name
     <> optempty (arguments formatter) args

src/Language/GraphQL/AST/Parser.hs

@@ -376,12 +376,12 @@ selectionSetOpt :: Parser SelectionSetOpt
 selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
 
 selection :: Parser Selection
-selection = field
+selection = FieldSelection <$> field
     <|> FragmentSpreadSelection <$> try fragmentSpread
     <|> InlineFragmentSelection <$> inlineFragment
     <?> "Selection"
 
-field :: Parser Selection
+field :: Parser Field
 field = label "Field" $ do
     location <- getLocation
     alias' <- optional alias
@@ -391,7 +391,7 @@ field = label "Field" $ do
     selectionSetOpt' <- selectionSetOpt
     pure $ Field alias' name' arguments' directives' selectionSetOpt' location
 
-alias :: Parser Alias
+alias :: Parser Name
 alias = try (name <* colon) <?> "Alias"
 
 arguments :: Parser [Argument]

src/Language/GraphQL/Execute/Transform.hs

@@ -288,39 +288,42 @@ operation operationDefinition replacement
 selection
     :: Full.Selection
     ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))
-selection (Full.Field alias name arguments' directives' selections _) =
+selection (Full.FieldSelection fieldSelection) =
-    maybe (Left mempty) (Right . SelectionField) <$> do
+    maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection
-        fieldArguments <- foldM go HashMap.empty arguments'
+selection (Full.FragmentSpreadSelection fragmentSelection)
-        fieldSelections <- appendSelection selections
+    = maybe (Left mempty) (Right . SelectionFragment)
-        fieldDirectives <- Definition.selection <$> directives directives'
+    <$> fragmentSpread fragmentSelection
-        let field' = Field alias name fieldArguments fieldSelections
-        pure $ field' <$ fieldDirectives
-  where
-    go arguments (Full.Argument name' value') =
-        inputField arguments name' value'
-selection (Full.FragmentSpreadSelection fragmentSelection) =
-    fragmentSpread fragmentSelection
 selection (Full.InlineFragmentSelection fragmentSelection) =
     inlineFragment fragmentSelection
 
+field :: Full.Field ->  State (Replacement m) (Maybe (Field m))
+field (Full.Field alias name arguments' directives' selections _) = do
+    fieldArguments <- foldM go HashMap.empty arguments'
+    fieldSelections <- appendSelection selections
+    fieldDirectives <- Definition.selection <$> directives directives'
+    let field' = Field alias name fieldArguments fieldSelections
+    pure $ field' <$ fieldDirectives
+  where
+    go arguments (Full.Argument name' value') =
+        inputField arguments name' value'
+
 fragmentSpread
     :: Full.FragmentSpread
-    ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))
+    -> State (Replacement m) (Maybe (Fragment m))
-fragmentSpread (Full.FragmentSpread name directives' _) =
+fragmentSpread (Full.FragmentSpread name directives' _) = do
-    maybe (Left mempty) (Right . SelectionFragment) <$> do
+    spreadDirectives <- Definition.selection <$> directives directives'
-        spreadDirectives <- Definition.selection <$> directives directives'
+    fragments' <- gets fragments
-        fragments' <- gets fragments
 
-        fragmentDefinitions' <- gets fragmentDefinitions
+    fragmentDefinitions' <- gets fragmentDefinitions
-        case HashMap.lookup name fragments' of
+    case HashMap.lookup name fragments' of
-            Just definition -> lift $ pure $ definition <$ spreadDirectives
+        Just definition -> lift $ pure $ definition <$ spreadDirectives
-            Nothing
+        Nothing
-                | Just definition <- HashMap.lookup name fragmentDefinitions' -> do
+            | Just definition <- HashMap.lookup name fragmentDefinitions' -> do
-                    fragDef <- fragmentDefinition definition
+                fragDef <- fragmentDefinition definition
-                    case fragDef of
+                case fragDef of
-                        Just fragment -> lift $ pure $ fragment <$ spreadDirectives
+                    Just fragment -> lift $ pure $ fragment <$ spreadDirectives
-                        _ -> lift $ pure  Nothing
+                    _ -> lift $ pure  Nothing
-                | otherwise -> lift $ pure  Nothing
+            | otherwise -> lift $ pure  Nothing
 
 inlineFragment
     :: Full.InlineFragment

src/Language/GraphQL/Validate.hs

@@ -85,8 +85,8 @@ selection :: forall m. Selection -> ValidateT m
 selection selection'
     | FragmentSpreadSelection fragmentSelection <- selection' =
         visitChildSelections ruleFilter $ fragmentSpread fragmentSelection
-    | Field _ _ _ _ selectionSet _ <- selection' =
+    | FieldSelection fieldSelection <- selection' =
-        visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
+        visitChildSelections ruleFilter $ field fieldSelection
     | InlineFragmentSelection fragmentSelection <- selection' =
         visitChildSelections ruleFilter $ inlineFragment fragmentSelection
   where
@@ -94,6 +94,14 @@ selection selection'
         mapReaderT (runRule accumulator) $ rule selection'
     ruleFilter accumulator _ = pure accumulator
 
+field :: forall m. Field -> ValidateT m
+field field'@(Field _ _ _ _ selections _) =
+    visitChildSelections ruleFilter $ traverseSelectionSet selections
+  where
+    ruleFilter accumulator (FieldRule rule) =
+        mapReaderT (runRule accumulator) $ rule field'
+    ruleFilter accumulator _ = pure accumulator
+
 inlineFragment :: forall m. InlineFragment -> ValidateT m
 inlineFragment fragment@(InlineFragment _ _ selections _) =
     visitChildSelections ruleFilter $ traverseSelectionSet selections

src/Language/GraphQL/Validate/Rules.hs

@@ -14,6 +14,7 @@ module Language.GraphQL.Validate.Rules
     , fragmentSpreadTargetDefinedRule
     , fragmentSpreadTypeExistenceRule
     , loneAnonymousOperationRule
+    , noUnusedFragmentsRule
     , singleFieldSubscriptionsRule
     , specifiedRules
     , uniqueFragmentNamesRule
@@ -45,9 +46,10 @@ specifiedRules =
     , uniqueOperationNamesRule
     -- Fragments.
     , uniqueFragmentNamesRule
-    , fragmentSpreadTargetDefinedRule
     , fragmentSpreadTypeExistenceRule
     , fragmentsOnCompositeTypesRule
+    , noUnusedFragmentsRule
+    , fragmentSpreadTargetDefinedRule
     ]
 
 -- | Definition must be OperationDefinition or FragmentDefinition.
@@ -92,15 +94,16 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
         "Anonymous Subscription must select only one top level field."
     collectFields selectionSet = foldM forEach HashSet.empty selectionSet
     forEach accumulator = \case
-        Field alias name _ directives _ _
+        FieldSelection fieldSelection -> forField accumulator fieldSelection
-            | any skip directives -> pure accumulator
-            | Just aliasedName <- alias -> pure
-                $ HashSet.insert aliasedName accumulator
-            | otherwise -> pure $ HashSet.insert name accumulator
         FragmentSpreadSelection fragmentSelection ->
             forSpread accumulator fragmentSelection
         InlineFragmentSelection fragmentSelection ->
             forInline accumulator fragmentSelection
+    forField accumulator (Field alias name _ directives _ _)
+        | any skip directives = pure accumulator
+        | Just aliasedName <- alias = pure
+            $ HashSet.insert aliasedName accumulator
+        | otherwise = pure $ HashSet.insert name accumulator
     forSpread accumulator (FragmentSpread fragmentName directives _)
         | any skip directives = pure accumulator
         | otherwise = do
@@ -129,7 +132,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
             Just compositeType
                 | Just objectType <- Schema.subscription schema'
                 , True <- doesFragmentTypeApply compositeType objectType ->
-                    HashSet.union accumulator<$> collectFields selectionSet
+                    HashSet.union accumulator <$> collectFields selectionSet
                 | otherwise -> pure accumulator
     collectFromSpread fragmentName accumulator = do
         modify $ HashSet.insert fragmentName
@@ -338,3 +341,44 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
         , Text.unpack typeCondition,
         "\"."
         ]
+
+-- | Defined fragments must be used within a document.
+noUnusedFragmentsRule :: forall m. Rule m
+noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment ->
+    asks ast >>= findSpreadByName fragment
+  where
+    findSpreadByName (FragmentDefinition fragName _ _ _ location) definitions
+        | foldr (go fragName) False definitions = lift Nothing
+        | otherwise = pure $ Error
+            { message = errorMessage fragName
+            , locations = [location]
+            , path = []
+            }
+    errorMessage fragName = concat
+        [ "Fragment \""
+        , Text.unpack fragName
+        , "\" is never used."
+        ]
+    go fragName (viewOperation -> Just operation) accumulator
+        | SelectionSet selections _ <- operation =
+            evaluateSelections fragName accumulator selections
+        | OperationDefinition _ _ _ _ selections _ <- operation =
+            evaluateSelections fragName accumulator selections
+    go fragName (viewFragment -> Just fragment) accumulator
+        | FragmentDefinition _ _ _ selections _ <- fragment =
+            evaluateSelections fragName accumulator selections
+    go _ _ _ = False
+    evaluateSelection fragName selection accumulator
+        | FragmentSpreadSelection spreadSelection <- selection
+        , FragmentSpread spreadName _ _ <- spreadSelection
+        , spreadName == fragName = True
+        | FieldSelection fieldSelection <- selection
+        , Field _ _ _ _ selections _ <- fieldSelection =
+            evaluateSelections fragName accumulator selections
+        | InlineFragmentSelection inlineSelection <- selection
+        , InlineFragment _ _ selections _ <- inlineSelection =
+            evaluateSelections fragName accumulator selections
+        | otherwise = accumulator || False
+    evaluateSelections :: Foldable t => Name -> Bool -> t Selection -> Bool
+    evaluateSelections fragName accumulator selections =
+        foldr (evaluateSelection fragName) accumulator selections

src/Language/GraphQL/Validate/Validation.hs

@@ -52,6 +52,7 @@ data Rule m
     | SelectionRule (Selection -> RuleT m)
     | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
     | FragmentSpreadRule (FragmentSpread -> RuleT m)
+    | FieldRule (Field -> RuleT m)
 
 -- | Monad transformer used by the rules.
 type RuleT m = ReaderT (Validation m) Maybe Error

tests/Language/GraphQL/AST/EncoderSpec.hs

@@ -124,7 +124,7 @@ spec = do
             let arguments = [Argument "message" (String "line1\nline2")]
                 field = Field Nothing "field" arguments [] [] $ Location 0 0
                 operation = DefinitionOperation
-                    $ SelectionSet (pure field)
+                    $ SelectionSet (pure $ FieldSelection field)
                     $ Location 0 0
              in definition pretty operation `shouldBe` [r|{
   field(message: """

tests/Language/GraphQL/ValidateSpec.hs

@@ -373,3 +373,23 @@ spec =
                     , path = []
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects unused fragments" $
+            let queryString = [r|
+              fragment nameFragment on Dog { # unused
+                name
+              }
+
+              {
+                dog {
+                  name
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Fragment \"nameFragment\" is never used."
+                    , locations = [AST.Location 2 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected