Release 0.6.1.0

Fixes #10.

CHANGELOG.md

@@ -1,6 +1,20 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 
+## [0.6.1.0] - 2019-12-23
+### Fixed
+- Parsing multiple string arguments, such as 
+  `login(username: "username", password: "password")` would fail on the comma
+  due to strings not having a space consumer.
+- Fragment spread is evaluated based on the `__typename` resolver. If the
+  resolver is missing, it is assumed that the type condition is satisfied (all
+  fragments are included).
+- Escaping characters during encoding.
+
+### Added
+- Directive support (@skip and @include).
+- Pretifying multi-line string arguments as block strings.
+
 ## [0.6.0.0] - 2019-11-27
 ### Changed
 - `Language.GraphQL.Encoder` moved to `Language.GraphQL.AST.Encoder`.
@@ -148,6 +162,7 @@ All notable changes to this project will be documented in this file.
 ### Added
 - Data types for the GraphQL language.
 
+[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0
 [0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0
 [0.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...v0.5.1.0
 [0.5.0.1]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.0...v0.5.0.1

package.yaml

@@ -1,5 +1,5 @@
 name:                graphql
-version:             0.6.0.0
+version:             0.6.1.0
 synopsis:            Haskell GraphQL implementation
 description:
   This package provides a rudimentary parser for the
@@ -37,7 +37,8 @@ dependencies:
 library:
   source-dirs: src
   other-modules:
-    - Language.GraphQL.AST.Transform
+  - Language.GraphQL.Execute.Transform
+  - Language.GraphQL.Type.Directive
 
 tests:
   tasty:

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)

src/Language/GraphQL/AST/Encoder.hs

@@ -13,13 +13,17 @@ module Language.GraphQL.AST.Encoder
     , value
     ) where
 
+import Data.Char (ord)
 import Data.Foldable (fold)
 import Data.Monoid ((<>))
-import qualified Data.List.NonEmpty as NonEmpty (toList)
+import qualified Data.List.NonEmpty as NonEmpty
-import Data.Text.Lazy (Text)
+import Data.Text (Text)
-import qualified Data.Text.Lazy as Text.Lazy
+import qualified Data.Text as Text
-import Data.Text.Lazy.Builder (toLazyText)
+import qualified Data.Text.Lazy as Lazy (Text)
-import Data.Text.Lazy.Builder.Int (decimal)
+import qualified Data.Text.Lazy as Lazy.Text
+import Data.Text.Lazy.Builder (Builder)
+import qualified Data.Text.Lazy.Builder as Builder
+import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
 import Data.Text.Lazy.Builder.RealFloat (realFloat)
 import qualified Language.GraphQL.AST as Full
 
@@ -40,17 +44,17 @@ minified :: Formatter
 minified = Minified
 
 -- | Converts a 'Full.Document' into a string.
-document :: Formatter -> Full.Document -> Text
+document :: Formatter -> Full.Document -> Lazy.Text
 document formatter defs
-    | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument
+    | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
-    | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n'
+    | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
   where
     encodeDocument = NonEmpty.toList $ definition formatter <$> defs
 
 -- | Converts a 'Full.Definition' into a string.
-definition :: Formatter -> Full.Definition -> Text
+definition :: Formatter -> Full.Definition -> Lazy.Text
 definition formatter x
-    | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n'
+    | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
     | Minified <- formatter = encodeDefinition x
   where
     encodeDefinition (Full.DefinitionOperation operation)
@@ -58,7 +62,7 @@ definition formatter x
     encodeDefinition (Full.DefinitionFragment fragment)
         = fragmentDefinition formatter fragment
 
-operationDefinition :: Formatter -> Full.OperationDefinition -> Text
+operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
 operationDefinition formatter (Full.OperationSelectionSet sels)
     = selectionSet formatter sels
 operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
@@ -66,99 +70,106 @@ operationDefinition formatter (Full.OperationDefinition Full.Query name vars dir
 operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
     = "mutation " <> node formatter name vars dirs sels
 
-node :: Formatter
+node :: Formatter ->
-    -> Maybe Full.Name
+    Maybe Full.Name ->
-    -> [Full.VariableDefinition]
+    [Full.VariableDefinition] ->
-    -> [Full.Directive]
+    [Full.Directive] ->
-    -> Full.SelectionSet
+    Full.SelectionSet ->
-    -> Text
+    Lazy.Text
 node formatter name vars dirs sels
-    = Text.Lazy.fromStrict (fold name)
+    = Lazy.Text.fromStrict (fold name)
     <> optempty (variableDefinitions formatter) vars
     <> optempty (directives formatter) dirs
     <> eitherFormat formatter " " mempty
     <> selectionSet formatter sels
 
-variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Text
+variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
 variableDefinitions formatter
     = parensCommas formatter $ variableDefinition formatter
 
-variableDefinition :: Formatter -> Full.VariableDefinition -> Text
+variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
 variableDefinition formatter (Full.VariableDefinition var ty dv)
     = variable var
     <> eitherFormat formatter ": " ":"
     <> type' ty
     <> maybe mempty (defaultValue formatter) dv
 
-defaultValue :: Formatter -> Full.Value -> Text
+defaultValue :: Formatter -> Full.Value -> Lazy.Text
 defaultValue formatter val
     = eitherFormat formatter " = " "="
     <> value formatter val
 
-variable :: Full.Name -> Text
+variable :: Full.Name -> Lazy.Text
-variable var = "$" <> Text.Lazy.fromStrict var
+variable var = "$" <> Lazy.Text.fromStrict var
 
-selectionSet :: Formatter -> Full.SelectionSet -> Text
+selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
 selectionSet formatter
     = bracesList formatter (selection formatter)
     . NonEmpty.toList
 
-selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Text
+selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
 selectionSetOpt formatter = bracesList formatter $ selection formatter
 
-selection :: Formatter -> Full.Selection -> Text
+indent :: (Integral a) => a -> Lazy.Text
-selection formatter = Text.Lazy.append indent . f
+indent indentation = Lazy.Text.replicate (fromIntegral indentation) "  "
-  where
-    f (Full.SelectionField x) = field incrementIndent x
-    f (Full.SelectionInlineFragment x) = inlineFragment incrementIndent x
-    f (Full.SelectionFragmentSpread x) = fragmentSpread incrementIndent x
-    incrementIndent
-        | Pretty n <- formatter = Pretty $ n + 1
-        | otherwise = Minified
-    indent
-        | Pretty n <- formatter = Text.Lazy.replicate (fromIntegral $ n + 1) "  "
-        | otherwise = mempty
 
-field :: Formatter -> Full.Field -> Text
+selection :: Formatter -> Full.Selection -> Lazy.Text
-field formatter (Full.Field alias name args dirs selso)
+selection formatter = Lazy.Text.append indent' . encodeSelection
-    = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias)
+  where
-    <> Text.Lazy.fromStrict name
+    encodeSelection (Full.SelectionField field') = field incrementIndent field'
+    encodeSelection (Full.SelectionInlineFragment fragment) =
+        inlineFragment incrementIndent fragment
+    encodeSelection (Full.SelectionFragmentSpread spread) =
+        fragmentSpread incrementIndent spread
+    incrementIndent
+        | Pretty indentation <- formatter = Pretty $ indentation + 1
+        | otherwise = Minified
+    indent'
+        | Pretty indentation <- formatter = indent $ indentation + 1
+        | otherwise = ""
+
+colon :: Formatter -> Lazy.Text
+colon formatter = eitherFormat formatter ": " ":"
+
+field :: Formatter -> Full.Field -> Lazy.Text
+field formatter (Full.Field alias name args dirs set)
+    = optempty prependAlias (fold alias)
+    <> Lazy.Text.fromStrict name
     <> optempty (arguments formatter) args
     <> optempty (directives formatter) dirs
-    <> selectionSetOpt'
+    <> optempty selectionSetOpt' set
   where
-    colon = eitherFormat formatter ": " ":"
+    prependAlias aliasName = Lazy.Text.fromStrict aliasName <>  colon formatter
-    selectionSetOpt'
+    selectionSetOpt' = (eitherFormat formatter " " "" <>)
-        | null selso = mempty
+        . selectionSetOpt formatter
-        | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso
 
-arguments :: Formatter -> [Full.Argument] -> Text
+arguments :: Formatter -> [Full.Argument] -> Lazy.Text
 arguments formatter = parensCommas formatter $ argument formatter
 
-argument :: Formatter -> Full.Argument -> Text
+argument :: Formatter -> Full.Argument -> Lazy.Text
-argument formatter (Full.Argument name v)
+argument formatter (Full.Argument name value')
-    = Text.Lazy.fromStrict name
+    = Lazy.Text.fromStrict name
-    <> eitherFormat formatter ": " ":"
+    <> colon formatter
-    <> value formatter v
+    <> value formatter value'
 
 -- * Fragments
 
-fragmentSpread :: Formatter -> Full.FragmentSpread -> Text
+fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
 fragmentSpread formatter (Full.FragmentSpread name ds)
-    = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds
+    = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds
 
-inlineFragment :: Formatter -> Full.InlineFragment -> Text
+inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
 inlineFragment formatter (Full.InlineFragment tc dirs sels)
     = "... on "
-    <> Text.Lazy.fromStrict (fold tc)
+    <> Lazy.Text.fromStrict (fold tc)
     <> directives formatter dirs
     <> eitherFormat formatter " " mempty
     <> selectionSet formatter sels
 
-fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Text
+fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
 fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
-    = "fragment " <> Text.Lazy.fromStrict name
+    = "fragment " <> Lazy.Text.fromStrict name
-    <> " on " <> Text.Lazy.fromStrict tc
+    <> " on " <> Lazy.Text.fromStrict tc
     <> optempty (directives formatter) dirs
     <> eitherFormat formatter " " mempty
     <> selectionSet formatter sels
@@ -166,108 +177,128 @@ fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
 -- * Miscellaneous
 
 -- | Converts a 'Full.Directive' into a string.
-directive :: Formatter -> Full.Directive -> Text
+directive :: Formatter -> Full.Directive -> Lazy.Text
 directive formatter (Full.Directive name args)
-    = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args
+    = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
 
-directives :: Formatter -> [Full.Directive] -> Text
+directives :: Formatter -> [Full.Directive] -> Lazy.Text
-directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)
 directives Minified = spaces (directive Minified)
+directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
 
 -- | Converts a 'Full.Value' into a string.
-value :: Formatter -> Full.Value -> Text
+value :: Formatter -> Full.Value -> Lazy.Text
 value _ (Full.Variable x) = variable x
-value _ (Full.Int x) = toLazyText $ decimal x
+value _ (Full.Int x) = Builder.toLazyText $ decimal x
-value _ (Full.Float x) = toLazyText $ realFloat x
+value _ (Full.Float x) = Builder.toLazyText $ realFloat x
 value _ (Full.Boolean  x) = booleanValue x
 value _ Full.Null = mempty
-value _ (Full.String x) = stringValue $ Text.Lazy.fromStrict x
+value formatter (Full.String string) = stringValue formatter string
-value _ (Full.Enum x) = Text.Lazy.fromStrict x
+value _ (Full.Enum x) = Lazy.Text.fromStrict x
 value formatter (Full.List x) = listValue formatter x
 value formatter (Full.Object x) = objectValue formatter x
 
-booleanValue :: Bool -> Text
+booleanValue :: Bool -> Lazy.Text
 booleanValue True  = "true"
 booleanValue False = "false"
 
-stringValue :: Text -> Text
+stringValue :: Formatter -> Text -> Lazy.Text
-stringValue
+stringValue Minified string = Builder.toLazyText
-    = quotes
+    $ quote <> Text.foldr (mappend . escape') quote string
-    . Text.Lazy.replace "\"" "\\\""
+  where
-    . Text.Lazy.replace "\\" "\\\\"
+    quote = Builder.singleton '\"'
+    escape' '\n' = Builder.fromString "\\n"
+    escape' char = escape char
+stringValue (Pretty indentation) string = byStringType $ Text.lines string
+  where
+    byStringType [] = "\"\""
+    byStringType [line] = Builder.toLazyText
+        $ quote <> Text.foldr (mappend . escape) quote line
+    byStringType lines' = "\"\"\"\n"
+        <> Lazy.Text.unlines (transformLine <$> lines')
+        <> indent indentation
+        <> "\"\"\""
+    transformLine = (indent (indentation + 1) <>)
+        . Lazy.Text.fromStrict
+        . Text.replace "\"\"\"" "\\\"\"\""
+    quote = Builder.singleton '\"'
 
-listValue :: Formatter -> [Full.Value] -> Text
+escape :: Char -> Builder
+escape char'
+    | char' == '\\' = Builder.fromString "\\\\"
+    | char' == '\"' = Builder.fromString "\\\""
+    | char' == '\b' = Builder.fromString "\\b"
+    | char' == '\f' = Builder.fromString "\\f"
+    | char' == '\r' = Builder.fromString "\\r"
+    | char' < '\x0010' = unicode  "\\u000" char'
+    | char' < '\x0020' = unicode "\\u00" char'
+    | otherwise = Builder.singleton char'
+  where
+    unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
+
+listValue :: Formatter -> [Full.Value] -> Lazy.Text
 listValue formatter = bracketsCommas formatter $ value formatter
 
-objectValue :: Formatter -> [Full.ObjectField] -> Text
+objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text
 objectValue formatter = intercalate $ objectField formatter
   where
     intercalate f
         = braces
-        . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+        . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
         . fmap f
 
-
+objectField :: Formatter -> Full.ObjectField -> Lazy.Text
-objectField :: Formatter -> Full.ObjectField -> Text
+objectField formatter (Full.ObjectField name value') =
-objectField formatter (Full.ObjectField name v)
+    Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
-    = Text.Lazy.fromStrict name <> colon <> value formatter v
-  where
-    colon
-      | Pretty _ <- formatter = ": "
-      | Minified <- formatter = ":"
 
 -- | Converts a 'Full.Type' a type into a string.
-type' :: Full.Type -> Text
+type' :: Full.Type -> Lazy.Text
-type' (Full.TypeNamed   x) = Text.Lazy.fromStrict x
+type' (Full.TypeNamed   x) = Lazy.Text.fromStrict x
 type' (Full.TypeList    x) = listType x
 type' (Full.TypeNonNull x) = nonNullType x
 
-listType :: Full.Type -> Text
+listType :: Full.Type -> Lazy.Text
 listType x = brackets (type' x)
 
-nonNullType :: Full.NonNullType -> Text
+nonNullType :: Full.NonNullType -> Lazy.Text
-nonNullType (Full.NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"
+nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
 nonNullType (Full.NonNullTypeList  x) = listType x <> "!"
 
 -- * Internal
 
-between :: Char -> Char -> Text -> Text
+between :: Char -> Char -> Lazy.Text -> Lazy.Text
-between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close)
+between open close = Lazy.Text.cons open . (`Lazy.Text.snoc` close)
 
-parens :: Text -> Text
+parens :: Lazy.Text -> Lazy.Text
 parens = between '(' ')'
 
-brackets :: Text -> Text
+brackets :: Lazy.Text -> Lazy.Text
 brackets = between '[' ']'
 
-braces :: Text -> Text
+braces :: Lazy.Text -> Lazy.Text
 braces = between '{' '}'
 
-quotes :: Text -> Text
+spaces :: forall a. (a -> Lazy.Text) -> [a] -> Lazy.Text
-quotes = between '"' '"'
+spaces f = Lazy.Text.intercalate "\SP" . fmap f
 
-spaces :: forall a. (a -> Text) -> [a] -> Text
+parensCommas :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
-spaces f = Text.Lazy.intercalate "\SP" . fmap f
-
-parensCommas :: forall a. Formatter -> (a -> Text) -> [a] -> Text
 parensCommas formatter f
     = parens
-    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+    . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
     . fmap f
 
-bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text
+bracketsCommas :: Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
 bracketsCommas formatter f
     = brackets
-    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+    . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
     . fmap f
 
-bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text
+bracesList :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
 bracesList (Pretty intendation) f xs
-    = Text.Lazy.snoc (Text.Lazy.intercalate "\n" content) '\n'
+    = Lazy.Text.snoc (Lazy.Text.intercalate "\n" content) '\n'
-    <> (Text.Lazy.snoc $ Text.Lazy.replicate (fromIntegral intendation) "  ") '}'
+    <> (Lazy.Text.snoc $ Lazy.Text.replicate (fromIntegral intendation) "  ") '}'
   where
     content = "{" : fmap f xs
-bracesList Minified f xs = braces $ Text.Lazy.intercalate "," $ fmap f xs
+bracesList Minified f xs = braces $ Lazy.Text.intercalate "," $ fmap f xs
 
 optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b
 optempty f xs = if xs == mempty then mempty else f xs

src/Language/GraphQL/AST/Lexer.hs

@@ -134,7 +134,7 @@ braces = between (symbol "{") (symbol "}")
 
 -- | Parser for strings.
 string :: Parser T.Text
-string = between "\"" "\"" stringValue
+string = between "\"" "\"" stringValue <* spaceConsumer 
   where
     stringValue = T.pack <$> many stringCharacter
     stringCharacter = satisfy isStringCharacter1
@@ -143,7 +143,7 @@ string = between "\"" "\"" stringValue
 
 -- | Parser for block strings.
 blockString :: Parser T.Text
-blockString = between "\"\"\"" "\"\"\"" stringValue
+blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer 
   where
     stringValue = do
         byLine <- sepBy (many blockStringCharacter) lineTerminator

src/Language/GraphQL/Execute.hs

@@ -15,7 +15,7 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Language.GraphQL.AST as AST
 import qualified Language.GraphQL.AST.Core as AST.Core
-import qualified Language.GraphQL.AST.Transform as Transform
+import qualified Language.GraphQL.Execute.Transform as Transform
 import Language.GraphQL.Error
 import qualified Language.GraphQL.Schema as Schema
 

src/Language/GraphQL/Execute/Transform.hs

@@ -1,10 +1,10 @@
-{-# 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
 --   this transformation.
-module Language.GraphQL.AST.Transform
+module Language.GraphQL.Execute.Transform
     ( document
     ) where
 
@@ -20,15 +20,19 @@ import Data.Sequence (Seq, (<|), (><))
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.AST.Core as Core
 import qualified Language.GraphQL.Schema as Schema
+import qualified Language.GraphQL.Type.Directive as Directive
 
 -- | Associates a fragment name with a list of 'Core.Field's.
 data Replacement = Replacement
-    { fragments :: HashMap Core.Name (Seq Core.Selection)
+    { fragments :: HashMap Core.Name Core.Fragment
     , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
     }
 
 type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
 
+liftJust :: forall a. a -> TransformT a
+liftJust = lift . lift . Just
+
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
@@ -46,7 +50,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,27 +64,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') =
-selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do
+    maybe (Left mempty) (Right . Core.SelectionField) <$> field field'
-    fragments' <- gets fragments
+selection (Full.SelectionFragmentSpread fragment) =
-    Left <$> maybe lookupDefinition liftJust (HashMap.lookup name fragments')
+    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
-    lookupDefinition :: TransformT (Seq Core.Selection)
+    go acc sel = append acc <$> selection sel
-    lookupDefinition = do
+    append acc (Left list) = list >< acc
-        fragmentDefinitions' <- gets fragmentDefinitions
+    append acc (Right one) = one <| acc
-        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
+
-        fragmentDefinition found
+directives :: [Full.Directive] -> TransformT [Core.Directive]
-selection (Full.SelectionInlineFragment fragment)
+directives = traverse directive
-    | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
+  where
-        = Right
+    directive (Full.Directive directiveName directiveArguments) =
-        . Core.SelectionFragment
+        Core.Directive directiveName <$> arguments directiveArguments
-        . Core.Fragment typeCondition
-        <$> appendSelection selectionSet
-    | (Full.InlineFragment Nothing _ selectionSet) <- fragment
-        = Left <$> appendSelection selectionSet
 
 -- * Fragment replacement
 
@@ -94,12 +104,40 @@ collectFragments = do
         _ <- fragmentDefinition nextValue
         collectFragments
 
+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
+    fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
+    pure $ fragment <$ spreadDirectives 
+  where
+    lookupDefinition = do
+        fragmentDefinitions' <- gets fragmentDefinitions
+        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
+        fragmentDefinition found
+
 fragmentDefinition ::
     Full.FragmentDefinition ->
-    TransformT (Seq Core.Selection)
+    TransformT Core.Fragment
-fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do
+fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
     modify deleteFragmentDefinition
-    newValue <- appendSelection selections
+    fragmentSelection <- appendSelection selections
+    let newValue = Core.Fragment type' fragmentSelection
     modify $ insertFragment newValue
     liftJust newValue
   where
@@ -109,11 +147,20 @@ fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do
         let newFragments = HashMap.insert name newValue fragments'
          in Replacement newFragments fragmentDefinitions'
 
-field :: Full.Field -> TransformT Core.Field
+field :: Full.Field -> TransformT (Maybe Core.Field)
-field (Full.Field a n args _dirs sels) = do
+field (Full.Field alias name arguments' directives' selections) = do
-    arguments <- traverse argument args
+    fieldArguments <- traverse argument arguments'
-    selection' <- appendSelection sels
+    fieldSelections <- appendSelection selections
-    return $ Core.Field a n arguments selection'
+    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
@@ -134,17 +181,4 @@ 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
+objectField (Full.ObjectField name value') = (name,) <$> value value'
-
-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
-
-liftJust :: forall a. a -> TransformT a
-liftJust = lift . lift . Just

src/Language/GraphQL/Schema.hs

@@ -131,8 +131,8 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
     tryResolvers (SelectionField fld@(Field _ name _ _))
         = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
     tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
-        that <-  maybe (return "") resolveTypeName (find (compareResolvers "__typename") resolvers)
+        that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)
-        if Aeson.String typeCondition == that
+        if maybe True (Aeson.String typeCondition ==) that
             then fmap fold . traverse tryResolvers $ selections'
             else return mempty
     compareResolvers name (Resolver name' _) = name == name'

src/Language/GraphQL/Type/Directive.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.GraphQL.Type.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'

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-14.16
+resolver: lts-14.18
 
 packages:
 - .

tests/Language/GraphQL/AST/EncoderSpec.hs

@@ -1,19 +1,46 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Language.GraphQL.AST.EncoderSpec
     ( spec
     ) where
 
-import Language.GraphQL.AST (Value(..))
+import Language.GraphQL.AST
 import Language.GraphQL.AST.Encoder
-import Test.Hspec ( Spec
+import Test.Hspec (Spec, context, describe, it, shouldBe)
-                  , describe
+import Text.RawString.QQ (r)
-                  , it
-                  , shouldBe
-                  )
 
 spec :: Spec
-spec = describe "value" $ do
+spec = do
-    it "escapes \\" $
+    describe "value" $ do
-        value minified (String "\\") `shouldBe` "\"\\\\\""
+        context "minified" $ do
-    it "escapes quotes" $
+            it "escapes \\" $
-        value minified (String "\"") `shouldBe` "\"\\\"\""
+                value minified (String "\\") `shouldBe` "\"\\\\\""
+            it "escapes quotes" $
+                value minified (String "\"") `shouldBe` "\"\\\"\""
+            it "escapes backspace" $
+                value minified (String "a\bc") `shouldBe` "\"a\\bc\""
+            it "escapes Unicode" $
+                value minified (String "\0") `shouldBe` "\"\\u0000\""
+
+        context "pretty" $ do
+            it "uses strings for short string values" $
+                value pretty (String "Short text") `shouldBe` "\"Short text\""
+            it "uses block strings for text with new lines" $
+                value pretty (String "Line 1\nLine 2")
+                    `shouldBe` "\"\"\"\n  Line 1\n  Line 2\n\"\"\""
+            it "escapes \\ in short strings" $
+                value pretty (String "\\") `shouldBe` "\"\\\\\""
+
+    describe "definition" $
+        it "indents block strings in arguments" $
+            let arguments = [Argument "message" (String "line1\nline2")]
+                field = Field Nothing "field" arguments [] []
+                set = OperationSelectionSet $ pure $ SelectionField field
+                operation = DefinitionOperation set
+             in definition pretty operation `shouldBe` [r|{
+  field(message: """
+    line1
+    line2
+  """)
+}
+|]

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -30,3 +30,15 @@ spec = describe "Parser" $ do
             mutation auth($username: String!, $password: String!){
                 test
             }|]
+
+    it "accepts two string arguments" $
+        parse document "" `shouldSucceedOn` [r|
+            mutation auth{
+                test(username: "username", password: "password")
+            }|]
+
+    it "accepts two block string arguments" $
+        parse document "" `shouldSucceedOn` [r|
+            mutation auth{
+                test(username: """username""", password: """password""")
+            }|]

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

tests/Test/FragmentSpec.hs

@@ -48,117 +48,144 @@ hasErrors (Object object') = HashMap.member "errors" object'
 hasErrors _ = True
 
 spec :: Spec
-spec = describe "Inline fragment executor" $ do
+spec = do
-    it "chooses the first selection if the type matches" $ do
+    describe "Inline fragment executor" $ do
-        actual <- graphql (garment "Hat" :| []) inlineQuery
+        it "chooses the first selection if the type matches" $ do
-        let expected = object
+            actual <- graphql (garment "Hat" :| []) inlineQuery
-                [ "data" .= object
+            let expected = object
-                    [ "garment" .= object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+                    ]
+             in actual `shouldBe` expected
+
+        it "chooses the last selection if the type matches" $ do
+            actual <- graphql (garment "Shirt" :| []) inlineQuery
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "size" .= ("L" :: Text)
+                            ]
+                        ]
+                    ]
+             in actual `shouldBe` expected
+
+        it "embeds inline fragments without type" $ do
+            let query = [r|{
+              garment {
+                circumference
+                ... {
+                  size
+                }
+              }
+            }|]
+                resolvers = Schema.object "garment" $ return [circumference,  size]
+
+            actual <- graphql (resolvers :| []) query
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            , "size" .= ("L" :: Text)
+                            ]
+                        ]
+                    ]
+             in actual `shouldBe` expected
+
+        it "evaluates fragments on Query" $ do
+            let query = [r|{
+              ... {
+                size
+              }
+            }|]
+
+            actual <- graphql (size :| []) query
+            actual `shouldNotSatisfy` hasErrors
+
+    describe "Fragment spread executor" $ do
+        it "evaluates fragment spreads" $ do
+            let query = [r|
+              {
+                ...circumferenceFragment
+              }
+
+              fragment circumferenceFragment on Hat {
+                circumference
+              }
+            |]
+
+            actual <- graphql (circumference :| []) query
+            let expected = object
+                    [ "data" .= object
                         [ "circumference" .= (60 :: Int)
                         ]
                     ]
-                ]
+             in actual `shouldBe` expected
-         in actual `shouldBe` expected
 
-    it "chooses the last selection if the type matches" $ do
+        it "evaluates nested fragments" $ do
-        actual <- graphql (garment "Shirt" :| []) inlineQuery
+            let query = [r|
-        let expected = object
+              {
-                [ "data" .= object
+                garment {
-                    [ "garment" .= object
+                  ...circumferenceFragment
-                        [ "size" .= ("L" :: Text)
+                }
+              }
+
+              fragment circumferenceFragment on Hat {
+                ...hatFragment
+              }
+
+              fragment hatFragment on Hat {
+                circumference
+              }
+            |]
+
+            actual <- graphql (garment "Hat" :| []) query
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
                         ]
                     ]
-                ]
+             in actual `shouldBe` expected
-         in actual `shouldBe` expected
 
-    it "embeds inline fragments without type" $ do
+        it "rejects recursive fragments" $ do
-        let query = [r|{
+            let query = [r|
-          garment {
+              {
-            circumference
+                ...circumferenceFragment
-            ... {
+              }
-              size
-            }
-          }
-        }|]
-            resolvers = Schema.object "garment" $ return [circumference,  size]
 
-        actual <- graphql (resolvers :| []) query
+              fragment circumferenceFragment on Hat {
-        let expected = object
+                ...circumferenceFragment
-                [ "data" .= object
+              }
-                    [ "garment" .= object
+            |]
-                        [ "circumference" .= (60 :: Int)
+
-                        , "size" .= ("L" :: Text)
+            actual <- graphql (circumference :| []) query
+            actual `shouldSatisfy` hasErrors
+
+        it "considers type condition" $ do
+            let query = [r|
+              {
+                garment {
+                  ...circumferenceFragment
+                  ...sizeFragment
+                }
+              }
+              fragment circumferenceFragment on Hat {
+                circumference
+              }
+              fragment sizeFragment on Shirt {
+                size
+              }
+            |]
+                expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
                         ]
                     ]
-                ]
+            actual <- graphql (garment "Hat" :| []) query
-         in actual `shouldBe` expected
+            actual `shouldBe` expected
-
-    it "evaluates fragments on Query" $ do
-        let query = [r|{
-          ... {
-            size
-          }
-        }|]
-
-        actual <- graphql (size :| []) query
-        actual `shouldNotSatisfy` hasErrors
-
-    it "evaluates nested fragments" $ do
-        let query = [r|
-          {
-            ...circumferenceFragment
-          }
-
-          fragment circumferenceFragment on Hat {
-            circumference
-          }
-
-          fragment hatFragment on Hat {
-            ...circumferenceFragment
-          }
-        |]
-
-        actual <- graphql (circumference :| []) query
-        let expected = object
-                [ "data" .= object
-                    [ "circumference" .= (60 :: Int)
-                    ]
-                ]
-         in actual `shouldBe` expected
-
-    it "evaluates fragments defined in any order" $ do
-        let query = [r|
-          {
-            ...circumferenceFragment
-          }
-
-          fragment circumferenceFragment on Hat {
-            ...hatFragment
-          }
-
-          fragment hatFragment on Hat {
-            circumference
-          }
-        |]
-
-        actual <- graphql (circumference :| []) query
-        let expected = object
-                [ "data" .= object
-                    [ "circumference" .= (60 :: Int)
-                    ]
-                ]
-         in actual `shouldBe` expected
-
-    it "rejects recursive" $ do
-        let query = [r|
-          {
-            ...circumferenceFragment
-          }
-
-          fragment circumferenceFragment on Hat {
-            ...circumferenceFragment
-          }
-        |]
-
-        actual <- graphql (circumference :| []) query
-        actual `shouldSatisfy` hasErrors