Support directives (skip and include)

Fixes #24.

6 files changed, 211 insertions, 33 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 38d5217..5cc152c 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -10,6 +10,9 @@ All notable changes to this project will be documented in this file.
   resolver is missing, it is assumed that the type condition is satisfied (all
   fragments are included).
 
+### Added
+- Directive support (@skip and @include).
+
 ## [0.6.0.0] - 2019-11-27
 ### Changed
 - `Language.GraphQL.Encoder` moved to `Language.GraphQL.AST.Encoder`.
diff --git a/package.yaml b/package.yaml
index c2c5028..222b64e 100644
--- a/package.yaml
+++ b/package.yaml
@@ -38,6 +38,7 @@ library:
   source-dirs: src
   other-modules:
     - Language.GraphQL.AST.Transform
+    - Language.GraphQL.Execute.Directive
 
 tests:
   tasty:
diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs
index f7a008f..7ba4830 100644
--- a/src/Language/GraphQL/AST/Core.hs
+++ b/src/Language/GraphQL/AST/Core.hs
@@ -2,6 +2,8 @@
 module Language.GraphQL.AST.Core
     ( Alias
     , Argument(..)
+    , Arguments(..)
+    , Directive(..)
     , Document
     , Field(..)
     , Fragment(..)
@@ -39,6 +41,14 @@ data Field
 -- | Single argument.
 data Argument = Argument Name Value deriving (Eq, Show)
 
+-- | Argument list.
+newtype Arguments = Arguments (HashMap Name Value)
+    deriving (Eq, Show)
+
+-- | Directive.
+data Directive = Directive Name Arguments
+    deriving (Eq, Show)
+
 -- | Represents fragments and inline fragments.
 data Fragment
     = Fragment TypeCondition (Seq Selection)
diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs
index 4822248..fadf929 100644
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/src/Language/GraphQL/AST/Transform.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TupleSections #-}
 
 -- | After the document is parsed, before getting executed the AST is
 --   transformed into a similar, simpler AST. This module is responsible for
@@ -19,6 +19,7 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq, (<|), (><))
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.AST.Core as Core
+import qualified Language.GraphQL.Execute.Directive as Directive
 import qualified Language.GraphQL.Schema as Schema
 
 -- | Associates a fragment name with a list of 'Core.Field's.
@@ -46,7 +47,6 @@ document subs document' =
 
 -- * Operation
 
--- TODO: Replace Maybe by MonadThrow CustomError
 operations :: [Full.OperationDefinition] -> TransformT Core.Document
 operations operations' = do
     coreOperations <- traverse operation operations'
@@ -61,20 +61,34 @@ operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =
 operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
     Core.Mutation name <$> appendSelection sels
 
+-- * Selection
+
 selection ::
     Full.Selection ->
     TransformT (Either (Seq Core.Selection) Core.Selection)
-selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld
+selection (Full.SelectionField field') =
+    maybe (Left mempty) (Right . Core.SelectionField) <$> field field'
 selection (Full.SelectionFragmentSpread fragment) =
-    Right . Core.SelectionFragment <$> fragmentSpread fragment
-selection (Full.SelectionInlineFragment fragment)
-    | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
-        = Right
-        . Core.SelectionFragment
-        . Core.Fragment typeCondition
-        <$> appendSelection selectionSet
-    | (Full.InlineFragment Nothing _ selectionSet) <- fragment
-        = Left <$> appendSelection selectionSet
+    maybe (Left mempty) (Right . Core.SelectionFragment)
+    <$> fragmentSpread fragment
+selection (Full.SelectionInlineFragment fragment) =
+    inlineFragment fragment
+
+appendSelection ::
+    Traversable t =>
+    t Full.Selection ->
+    TransformT (Seq Core.Selection)
+appendSelection = foldM go mempty
+  where
+    go acc sel = append acc <$> selection sel
+    append acc (Left list) = list >< acc
+    append acc (Right one) = one <| acc
+
+directives :: [Full.Directive] -> TransformT [Core.Directive]
+directives = traverse directive
+  where
+    directive (Full.Directive directiveName directiveArguments) =
+        Core.Directive directiveName <$> arguments directiveArguments
 
 -- * Fragment replacement
 
@@ -87,10 +101,27 @@ collectFragments = do
         _ <- fragmentDefinition nextValue
         collectFragments
 
-fragmentSpread :: Full.FragmentSpread -> TransformT Core.Fragment
-fragmentSpread (Full.FragmentSpread name _) = do
+inlineFragment ::
+    Full.InlineFragment ->
+    TransformT (Either (Seq Core.Selection) Core.Selection)
+inlineFragment (Full.InlineFragment type' directives' selectionSet) = do
+    fragmentDirectives <- Directive.selection <$> directives directives'
+    case fragmentDirectives of
+        Nothing -> pure $ Left mempty
+        _ -> do
+            fragmentSelectionSet <- appendSelection selectionSet
+            pure $ maybe Left selectionFragment type' fragmentSelectionSet
+  where
+    selectionFragment typeName = Right
+        . Core.SelectionFragment
+        . Core.Fragment typeName
+
+fragmentSpread :: Full.FragmentSpread -> TransformT (Maybe Core.Fragment)
+fragmentSpread (Full.FragmentSpread name directives') = do
+    spreadDirectives <- Directive.selection <$> directives directives'
     fragments' <- gets fragments
-    maybe lookupDefinition liftJust (HashMap.lookup name fragments')
+    fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
+    pure $ fragment <$ spreadDirectives 
   where
     lookupDefinition = do
         fragmentDefinitions' <- gets fragmentDefinitions
@@ -100,10 +131,10 @@ fragmentSpread (Full.FragmentSpread name _) = do
 fragmentDefinition ::
     Full.FragmentDefinition ->
     TransformT Core.Fragment
-fragmentDefinition (Full.FragmentDefinition name typeCondition _dirs selections) = do
+fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
     modify deleteFragmentDefinition
     fragmentSelection <- appendSelection selections
-    let newValue = Core.Fragment typeCondition fragmentSelection
+    let newValue = Core.Fragment type' fragmentSelection
     modify $ insertFragment newValue
     liftJust newValue
   where
@@ -113,11 +144,20 @@ fragmentDefinition (Full.FragmentDefinition name typeCondition _dirs selections)
         let newFragments = HashMap.insert name newValue fragments'
          in Replacement newFragments fragmentDefinitions'
 
-field :: Full.Field -> TransformT Core.Field
-field (Full.Field a n args _dirs sels) = do
-    arguments <- traverse argument args
-    selection' <- appendSelection sels
-    return $ Core.Field a n arguments selection'
+field :: Full.Field -> TransformT (Maybe Core.Field)
+field (Full.Field alias name arguments' directives' selections) = do
+    fieldArguments <- traverse argument arguments'
+    fieldSelections <- appendSelection selections
+    fieldDirectives <- Directive.selection <$> directives directives'
+    let field' = Core.Field alias name fieldArguments fieldSelections
+    pure $ field' <$ fieldDirectives
+
+arguments :: [Full.Argument] -> TransformT Core.Arguments
+arguments = fmap Core.Arguments . foldM go HashMap.empty
+  where
+    go arguments' argument' = do
+        (Core.Argument name value') <- argument argument'
+        return $ HashMap.insert name value' arguments'
 
 argument :: Full.Argument -> TransformT Core.Argument
 argument (Full.Argument n v) = Core.Argument n <$> value v
@@ -138,17 +178,7 @@ value (Full.Object o) =
     Core.Object . HashMap.fromList <$> traverse objectField o
 
 objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
-objectField (Full.ObjectField n v) = (n,) <$> value v
-
-appendSelection ::
-    Traversable t =>
-    t Full.Selection ->
-    TransformT (Seq Core.Selection)
-appendSelection = foldM go mempty
-  where
-    go acc sel = append acc <$> selection sel
-    append acc (Left list) = list >< acc
-    append acc (Right one) = one <| acc
+objectField (Full.ObjectField name value') = (name,) <$> value value'
 
 liftJust :: forall a. a -> TransformT a
 liftJust = lift . lift . Just
diff --git a/src/Language/GraphQL/Execute/Directive.hs b/src/Language/GraphQL/Execute/Directive.hs
new file mode 100644
index 0000000..733b6cf
--- /dev/null
+++ b/src/Language/GraphQL/Execute/Directive.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.GraphQL.Execute.Directive
+    ( selection
+    ) where
+
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL.AST.Core
+
+-- | Directive processing status.
+data Status
+    = Skip -- ^ Skip the selection and stop directive processing
+    | Include Directive -- ^ The directive was processed, try other handlers
+    | Continue Directive -- ^ Directive handler mismatch, try other handlers
+
+-- | Takes a list of directives, handles supported directives and excludes them
+--   from the result. If the selection should be skipped, returns 'Nothing'.
+selection :: [Directive] -> Maybe [Directive]
+selection = foldr go (Just [])
+  where
+    go directive' directives' =
+        case (skip . include) (Continue directive') of
+            (Include _) -> directives'
+            Skip -> Nothing
+            (Continue x) -> (x :) <$> directives'
+
+handle :: (Directive -> Status) -> Status -> Status
+handle _ Skip = Skip
+handle handler (Continue directive) = handler directive
+handle handler (Include directive) = handler directive
+
+-- * Directive implementations
+
+skip :: Status -> Status
+skip = handle skip'
+  where
+    skip' directive'@(Directive "skip" (Arguments arguments)) =
+        case HashMap.lookup "if" arguments of
+            (Just (Boolean True)) -> Skip
+            _ -> Include directive'
+    skip' directive' = Continue directive'
+
+include :: Status -> Status
+include = handle include'
+  where
+    include' directive'@(Directive "include" (Arguments arguments)) =
+        case HashMap.lookup "if" arguments of
+            (Just (Boolean True)) -> Include directive'
+            _ -> Skip
+    include' directive' = Continue directive'
diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs
new file mode 100644
index 0000000..2224bc5
--- /dev/null
+++ b/tests/Test/DirectiveSpec.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Test.DirectiveSpec
+    ( spec
+    ) where
+
+import Data.Aeson (Value, object, (.=))
+import Data.List.NonEmpty (NonEmpty(..))
+import Language.GraphQL
+import qualified Language.GraphQL.Schema as Schema
+import Test.Hspec (Spec, describe, it, shouldBe)
+import Text.RawString.QQ (r)
+
+experimentalResolver :: Schema.Resolver IO
+experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int) 
+
+emptyObject :: Value
+emptyObject = object
+    [ "data" .= object []
+    ]
+
+spec :: Spec
+spec =
+    describe "Directive executor" $ do
+        it "should be able to @skip fields" $ do
+            let query = [r|
+              {
+                experimentalField @skip(if: true)
+              }
+            |]
+
+            actual <- graphql (experimentalResolver :| []) query
+            actual `shouldBe` emptyObject
+
+        it "should not skip fields if @skip is false" $ do
+            let query = [r|
+              {
+                experimentalField @skip(if: false)
+              }
+            |]
+                expected = object
+                    [ "data" .= object
+                        [ "experimentalField" .= (5 :: Int)
+                        ]
+                    ]
+
+            actual <- graphql (experimentalResolver :| []) query
+            actual `shouldBe` expected
+
+        it "should skip fields if @include is false" $ do
+            let query = [r|
+              {
+                experimentalField @include(if: false)
+              }
+            |]
+
+            actual <- graphql (experimentalResolver :| []) query
+            actual `shouldBe` emptyObject
+
+        it "should be able to @skip a fragment spread" $ do
+            let query = [r|
+              {
+                ...experimentalFragment @skip(if: true)
+              }
+
+              fragment experimentalFragment on ExperimentalType {
+                experimentalField
+              }
+            |]
+
+            actual <- graphql (experimentalResolver :| []) query
+            actual `shouldBe` emptyObject
+
+        it "should be able to @skip an inline fragment" $ do
+            let query = [r|
+              {
+                ... on ExperimentalType @skip(if: true) {
+                  experimentalField
+                }
+              }
+            |]
+
+            actual <- graphql (experimentalResolver :| []) query
+            actual `shouldBe` emptyObject