Release 0.5.0.0

Fixes #2.

.gitignore

@@ -1,10 +1,10 @@
+# Stack
 .stack-work/
+/stack.yaml.lock
+
+# Cabal
+/dist/
+/dist-newstyle/
 .cabal-sandbox/
 cabal.sandbox.config
-dist/
-TAGS
-.#*
-.DS_Store
 cabal.project.local
-dist-newstyle/
-dist-newstyle/

CHANGELOG.md

@@ -1,6 +1,23 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 
+## [0.5.0.0] - 2019-08-14
+### Added
+- `executeWithName` executes an operation with the given name.
+- Export `Language.GraphQL.Encoder.definition`,
+  `Language.GraphQL.Encoder.type'` and `Language.GraphQL.Encoder.directive`.
+- Export `Language.GraphQL.Encoder.value`. Escapes \ and " in strings now.
+
+### Changed
+- `Operation` includes now possible operation name which allows to support
+  documents with multiple operations.
+- `Language.GraphQL.Encoder.document` and other encoding functions take a
+  `Formatter` as argument to distinguish between minified and pretty printing.
+- All encoder functions return `Data.Text.Lazy`.
+
+### Removed
+- Unused `Language.GraphQL.Encoder.spaced`.
+
 ## [0.4.0.0] - 2019-07-23
 ### Added
 - Support for mutations.
@@ -53,6 +70,7 @@ All notable changes to this project will be documented in this file.
 ### Added
 - Data types for the GraphQL language.
 
+[0.5.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.4.0.0...v0.5.0.0
 [0.4.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.3...v0.4.0.0
 [0.3]: https://github.com/caraus-ecms/graphql/compare/v0.2.1...v0.3
 [0.2.1]: https://github.com/caraus-ecms/graphql/compare/v0.2...v0.2.1

README.md

@@ -4,25 +4,38 @@
 [![Build Status](https://semaphoreci.com/api/v1/belka-ew/graphql/branches/master/badge.svg)](https://semaphoreci.com/belka-ew/graphql)
 [![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)
 
-For now this only provides a parser for the GraphQL query language and allows
+GraphQL implementation in Haskell.
-to execute queries and mutations without the schema validation step.
-But the idea is to be a Haskell port of
-[`graphql-js`](https://github.com/graphql/graphql-js). Next releases should
-include:
 
-- [x] GraphQL AST
+This implementation is relatively low-level by design, it doesn't provide any
-- [x] Parser for the GraphQL language.
+mappings between the GraphQL types and Haskell's type system and avoids
-- [x] Printer for GraphQL. This is not pretty yet.
+compile-time magic. It focuses on flexibility instead instead, so other
-- [ ] GraphQL Schema AST.
+solutions can be built on top of it.
-- [ ] Parser for the GraphQL Schema language.
+
-- [ ] Printer for the GraphQL Schema language.
+## State of the work
-- [ ] Interpreter of GraphQL requests.
+
-- [ ] Utilities to define GraphQL types and schema.
+For now this only provides a parser and a printer for the GraphQL query
+language and allows to execute queries and mutations without the schema
+validation step. But the idea is to be a Haskell port of
+[`graphql-js`](https://github.com/graphql/graphql-js).
+
+For the list of currently missing features see issues marked as
+"[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)".
+
+## Documentation
+
+API documentation is available through
+[hackage](https://hackage.haskell.org/package/graphql).
+
+You'll also find a small tutorial with some examples under
+[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
 
 ## Contact
 
 Suggestions, contributions and bug reports are welcome.
 
+Should you have questions on usage, please open an issue and ask – this helps
+to write useful documentation.
+
 Feel free to contact on Slack in [#haskell on
 GraphQL](https://graphql.slack.com/messages/haskell/). You can obtain an
 invitation [here](https://graphql-slack.herokuapp.com/).

graphql.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: dca80d6bcaa432cabc2499efc9f047c6f59546bc2ba75b35fed6efd694895598
+-- hash: 6598c2424405b7a92a4672ad7d1a4e8ad768ea47bf3ed0c3c5ae51bac8730301
 
 name:           graphql
-version:        0.4.0.0
+version:        0.5.0.0
 synopsis:       Haskell GraphQL implementation
 description:    This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
 category:       Language
@@ -66,6 +66,7 @@ test-suite tasty
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Language.GraphQL.EncoderSpec
       Language.GraphQL.ErrorSpec
       Language.GraphQL.LexerSpec
       Language.GraphQL.ParserSpec

package.yaml

@@ -1,5 +1,5 @@
 name:                graphql
-version:             0.4.0.0
+version:             0.5.0.0
 synopsis:            Haskell GraphQL implementation
 description:
   This package provides a rudimentary parser for the

src/Language/GraphQL/AST/Core.hs

@@ -21,8 +21,8 @@ type Name = Text
 
 type Document = NonEmpty Operation
 
-data Operation = Query    (NonEmpty Field)
+data Operation = Query (Maybe Text) (NonEmpty Field)
-               | Mutation (NonEmpty Field)
+               | Mutation (Maybe Text) (NonEmpty Field)
                  deriving (Eq,Show)
 
 data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)

src/Language/GraphQL/AST/Transform.hs

@@ -41,7 +41,6 @@ operations
   -> Maybe Core.Document
 operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
 
--- TODO: Replace Maybe by MonadThrow CustomError
 operation
   :: Schema.Subs
   -> Fragmenter
@@ -50,10 +49,10 @@ operation
 operation subs fr (Full.OperationSelectionSet sels) =
   operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
 -- TODO: Validate Variable definitions with substituter
-operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) =
+operation subs fr (Full.OperationDefinition operationType name _vars _dirs sels)
-  case ot of
+    = case operationType of
-    Full.Query    -> Core.Query    <$> node
+        Full.Query -> Core.Query name <$> node
-    Full.Mutation -> Core.Mutation <$> node
+        Full.Mutation -> Core.Mutation name <$> node
   where
     node = traverse (hush . selection subs fr) sels
 

src/Language/GraphQL/Encoder.hs

@@ -1,156 +1,238 @@
 {-# LANGUAGE OverloadedStrings #-}
--- | This module defines a printer for the @GraphQL@ language.
+{-# LANGUAGE ExplicitForAll #-}
+
+-- | This module defines a minifier and a printer for the @GraphQL@ language.
 module Language.GraphQL.Encoder
-    ( document
+    ( Formatter
-    , spaced
+    , definition
+    , directive
+    , document
+    , minified
+    , pretty
+    , type'
+    , value
     ) where
 
 import Data.Foldable (fold)
 import Data.Monoid ((<>))
 import qualified Data.List.NonEmpty as NonEmpty (toList)
-import Data.Text (Text, cons, intercalate, pack, snoc)
+import Data.Text.Lazy (Text)
+import qualified Data.Text.Lazy as Text.Lazy
+import Data.Text.Lazy.Builder (toLazyText)
+import Data.Text.Lazy.Builder.Int (decimal)
+import Data.Text.Lazy.Builder.RealFloat (realFloat)
 import Language.GraphQL.AST
 
--- * Document
+-- | Instructs the encoder whether a GraphQL should be minified or pretty
+--   printed.
+--   
+--   Use 'pretty' and 'minified' to construct the formatter.
+data Formatter
+    = Minified
+    | Pretty Word
 
-document :: Document -> Text
+-- Constructs a formatter for pretty printing.
-document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs
+pretty :: Formatter
+pretty = Pretty 0
 
-definition :: Definition -> Text
+-- Constructs a formatter for minifying.
-definition (DefinitionOperation x) = operationDefinition x
+minified :: Formatter
-definition (DefinitionFragment  x) = fragmentDefinition x
+minified = Minified
 
-operationDefinition :: OperationDefinition -> Text
+-- | Converts a 'Document' into a string.
-operationDefinition (OperationSelectionSet sels) = selectionSet sels
+document :: Formatter -> Document -> Text
-operationDefinition (OperationDefinition Query    name vars dirs sels) =
+document formatter defs
-  "query " <> node (fold name) vars dirs sels
+    | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument
-operationDefinition (OperationDefinition Mutation name vars dirs sels) =
+    | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n'
-  "mutation " <> node (fold name) vars dirs sels
+  where
+    encodeDocument = NonEmpty.toList $ definition formatter <$> defs
 
-node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
+-- | Converts a 'Definition' into a string.
-node name vars dirs sels =
+definition :: Formatter -> Definition -> Text
-       name
+definition formatter x
-    <> optempty variableDefinitions vars
+    | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n'
-    <> optempty directives dirs
+    | Minified <- formatter = encodeDefinition x
-    <> selectionSet sels
+  where
+    encodeDefinition (DefinitionOperation operation)
+        = operationDefinition formatter operation
+    encodeDefinition (DefinitionFragment fragment)
+        = fragmentDefinition formatter fragment
 
-variableDefinitions :: [VariableDefinition] -> Text
+operationDefinition :: Formatter -> OperationDefinition -> Text
-variableDefinitions = parensCommas variableDefinition
+operationDefinition formatter (OperationSelectionSet sels)
+    = selectionSet formatter sels
+operationDefinition formatter (OperationDefinition Query name vars dirs sels)
+    = "query " <> node formatter name vars dirs sels
+operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)
+    = "mutation " <> node formatter name vars dirs sels
 
-variableDefinition :: VariableDefinition -> Text
+node :: Formatter
-variableDefinition (VariableDefinition var ty dv) =
+     -> Maybe Name
-    variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
+     -> VariableDefinitions
+     -> Directives
+     -> SelectionSet
+     -> Text
+node formatter name vars dirs sels
+    = Text.Lazy.fromStrict (fold name)
+    <> optempty (variableDefinitions formatter) vars
+    <> optempty (directives formatter) dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
 
-defaultValue :: Value -> Text
+variableDefinitions :: Formatter -> [VariableDefinition] -> Text
-defaultValue val = "=" <> value val
+variableDefinitions formatter
+    = parensCommas formatter $ variableDefinition formatter
+
+variableDefinition :: Formatter -> VariableDefinition -> Text
+variableDefinition formatter (VariableDefinition var ty dv)
+    = variable var
+    <> eitherFormat formatter ": " ":"
+    <> type' ty
+    <> maybe mempty (defaultValue formatter) dv
+
+defaultValue :: Formatter -> Value -> Text
+defaultValue formatter val
+    = eitherFormat formatter " = " "="
+    <> value formatter val
 
 variable :: Name -> Text
-variable var = "$" <> var
+variable var = "$" <> Text.Lazy.fromStrict var
 
-selectionSet :: SelectionSet -> Text
+selectionSet :: Formatter -> SelectionSet -> Text
-selectionSet = bracesCommas selection . NonEmpty.toList
+selectionSet formatter
+    = bracesList formatter (selection formatter)
+    . NonEmpty.toList
 
-selectionSetOpt :: SelectionSetOpt -> Text
+selectionSetOpt :: Formatter -> SelectionSetOpt -> Text
-selectionSetOpt = bracesCommas selection
+selectionSetOpt formatter = bracesList formatter $ selection formatter
 
-selection :: Selection -> Text
+selection :: Formatter -> Selection -> Text
-selection (SelectionField          x) = field x
+selection formatter = Text.Lazy.append indent . f
-selection (SelectionInlineFragment x) = inlineFragment x
+  where
-selection (SelectionFragmentSpread x) = fragmentSpread x
+    f (SelectionField x) = field incrementIndent x
+    f (SelectionInlineFragment x) = inlineFragment incrementIndent x
+    f (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 :: Field -> Text
+field :: Formatter -> Field -> Text
-field (Field alias name args dirs selso) =
+field formatter (Field alias name args dirs selso)
-       optempty (`snoc` ':') (fold alias)
+    = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias)
-    <> name
+    <> Text.Lazy.fromStrict name
-    <> optempty arguments args
+    <> optempty (arguments formatter) args
-    <> optempty directives dirs
+    <> optempty (directives formatter) dirs
-    <> optempty selectionSetOpt selso
+    <> selectionSetOpt'
+  where
+    colon = eitherFormat formatter ": " ":"
+    selectionSetOpt'
+        | null selso = mempty
+        | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso
 
-arguments :: [Argument] -> Text
+arguments :: Formatter -> [Argument] -> Text
-arguments = parensCommas argument
+arguments formatter = parensCommas formatter $ argument formatter
 
-argument :: Argument -> Text
+argument :: Formatter -> Argument -> Text
-argument (Argument name v) = name <> ":" <> value v
+argument formatter (Argument name v)
+    = Text.Lazy.fromStrict name
+    <> eitherFormat formatter ": " ":"
+    <> value formatter v
 
 -- * Fragments
 
-fragmentSpread :: FragmentSpread -> Text
+fragmentSpread :: Formatter -> FragmentSpread -> Text
-fragmentSpread (FragmentSpread name ds) =
+fragmentSpread formatter (FragmentSpread name ds)
-    "..." <> name <> optempty directives ds
+    = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds
 
-inlineFragment :: InlineFragment -> Text
+inlineFragment :: Formatter -> InlineFragment -> Text
-inlineFragment (InlineFragment tc dirs sels) =
+inlineFragment formatter (InlineFragment tc dirs sels)
-    "... on " <> fold tc
+    = "... on "
-              <> directives dirs
+    <> Text.Lazy.fromStrict (fold tc)
-              <> selectionSet sels
+    <> directives formatter dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
 
-fragmentDefinition :: FragmentDefinition -> Text
+fragmentDefinition :: Formatter -> FragmentDefinition -> Text
-fragmentDefinition (FragmentDefinition name tc dirs sels) =
+fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
-    "fragment " <> name <> " on " <> tc
+    = "fragment " <> Text.Lazy.fromStrict name
-                <> optempty directives dirs
+    <> " on " <> Text.Lazy.fromStrict tc
-                <> selectionSet sels
+    <> optempty (directives formatter) dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
 
--- * Values
+-- * Miscellaneous
 
-value :: Value -> Text
+-- | Converts a 'Directive' into a string.
-value (ValueVariable x) = variable x
+directive :: Formatter -> Directive -> Text
--- TODO: This will be replaced with `decimal` Builder
+directive formatter (Directive name args)
-value (ValueInt      x) = pack $ show x
+    = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args
--- TODO: This will be replaced with `decimal` Builder
+
-value (ValueFloat    x) = pack $ show x
+directives :: Formatter -> Directives -> Text
-value (ValueBoolean  x) = booleanValue x
+directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)
-value ValueNull         = mempty
+directives Minified = spaces (directive Minified)
-value (ValueString   x) = stringValue x
+
-value (ValueEnum     x) = x
+-- | Converts a 'Value' into a string.
-value (ValueList     x) = listValue x
+value :: Formatter -> Value -> Text
-value (ValueObject   x) = objectValue x
+value _ (ValueVariable x) = variable x
+value _ (ValueInt x) = toLazyText $ decimal x
+value _ (ValueFloat x) = toLazyText $ realFloat x
+value _ (ValueBoolean  x) = booleanValue x
+value _ ValueNull = mempty
+value _ (ValueString x) = stringValue $ Text.Lazy.fromStrict x
+value _ (ValueEnum x) = Text.Lazy.fromStrict x
+value formatter (ValueList x) = listValue formatter x
+value formatter (ValueObject x) = objectValue formatter x
 
 booleanValue :: Bool -> Text
 booleanValue True  = "true"
 booleanValue False = "false"
 
--- TODO: Escape characters
 stringValue :: Text -> Text
-stringValue = quotes
+stringValue
+    = quotes
+    . Text.Lazy.replace "\"" "\\\""
+    . Text.Lazy.replace "\\" "\\\\"
 
-listValue :: [Value] -> Text
+listValue :: Formatter -> [Value] -> Text
-listValue = bracketsCommas value
+listValue formatter = bracketsCommas formatter $ value formatter
 
-objectValue :: [ObjectField] -> Text
+objectValue :: Formatter -> [ObjectField] -> Text
-objectValue = bracesCommas objectField
+objectValue formatter = intercalate $ objectField formatter
+  where
+    intercalate f
+        = braces
+        . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+        . fmap f
 
-objectField :: ObjectField -> Text
-objectField (ObjectField name v) = name <> ":" <> value v
 
--- * Directives
+objectField :: Formatter -> ObjectField -> Text
+objectField formatter (ObjectField name v)
+    = Text.Lazy.fromStrict name <> colon <> value formatter v
+  where
+    colon
+      | Pretty _ <- formatter = ": "
+      | Minified <- formatter = ":"
 
-directives :: [Directive] -> Text
+-- | Converts a 'Type' a type into a string.
-directives = spaces directive
+type' :: Type -> Text
-
+type' (TypeNamed   x) = Text.Lazy.fromStrict x
-directive :: Directive -> Text
+type' (TypeList    x) = listType x
-directive (Directive name args) = "@" <> name <> optempty arguments args
+type' (TypeNonNull x) = nonNullType x
-
--- * Type Reference
-
-type_ :: Type -> Text
-type_ (TypeNamed   x) = x
-type_ (TypeList    x) = listType x
-type_ (TypeNonNull x) = nonNullType x
 
 listType :: Type -> Text
-listType x = brackets (type_ x)
+listType x = brackets (type' x)
 
 nonNullType :: NonNullType -> Text
-nonNullType (NonNullTypeNamed x) = x <> "!"
+nonNullType (NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"
 nonNullType (NonNullTypeList  x) = listType x <> "!"
 
 -- * Internal
 
-spaced :: Text -> Text
-spaced = cons '\SP'
-
 between :: Char -> Char -> Text -> Text
-between open close = cons open . (`snoc` close)
+between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close)
 
 parens :: Text -> Text
 parens = between '(' ')'
@@ -164,17 +246,32 @@ braces = between '{' '}'
 quotes :: Text -> Text
 quotes = between '"' '"'
 
-spaces :: (a -> Text) -> [a] -> Text
+spaces :: forall a. (a -> Text) -> [a] -> Text
-spaces f = intercalate "\SP" . fmap f
+spaces f = Text.Lazy.intercalate "\SP" . fmap f
 
-parensCommas :: (a -> Text) -> [a] -> Text
+parensCommas :: forall a. Formatter -> (a -> Text) -> [a] -> Text
-parensCommas f = parens . intercalate "," . fmap f
+parensCommas formatter f
+    = parens
+    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+    . fmap f
 
-bracketsCommas :: (a -> Text) -> [a] -> Text
+bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text
-bracketsCommas f = brackets . intercalate "," . fmap f
+bracketsCommas formatter f
+    = brackets
+    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+    . fmap f
 
-bracesCommas :: (a -> Text) -> [a] -> Text
+bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text
-bracesCommas f = braces . intercalate "," . fmap f
+bracesList (Pretty intendation) f xs
+    = Text.Lazy.snoc (Text.Lazy.intercalate "\n" content) '\n'
+    <> (Text.Lazy.snoc $ Text.Lazy.replicate (fromIntegral intendation) "  ") '}'
+  where
+    content = "{" : fmap f xs
+bracesList Minified f xs = braces $ Text.Lazy.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
+
+eitherFormat :: forall a. Formatter -> a -> a -> a
+eitherFormat (Pretty _) x _ = x
+eitherFormat Minified _ x = x

src/Language/GraphQL/Execute.hs

@@ -4,12 +4,15 @@
 --   according to a 'Schema'.
 module Language.GraphQL.Execute
     ( execute
+    , executeWithName
     ) where
 
 import Control.Monad.IO.Class (MonadIO)
+import qualified Data.Aeson as Aeson
 import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty (NonEmpty((:|)))
-import qualified Data.Aeson as Aeson
+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
@@ -23,20 +26,47 @@ import qualified Language.GraphQL.Schema as Schema
 --
 --   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
 --   errors wrapped in an /errors/ field.
-execute
+execute :: MonadIO m
-    :: MonadIO m
+    => Schema m
-    => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value
+    -> Schema.Subs
+    -> AST.Document
+    -> m Aeson.Value
 execute schema subs doc =
-    maybe transformError (document schema) $ Transform.document subs doc
+    maybe transformError (document schema Nothing) $ Transform.document subs doc
   where
     transformError = return $ singleError "Schema transformation error."
 
-document :: MonadIO m => Schema m -> AST.Core.Document -> m Aeson.Value
+-- | Takes a 'Schema', operation name, a variable substitution function ('Schema.Subs'),
-document schema (op :| []) = operation schema op
+--   and a @GraphQL@ 'document'. The substitution is applied to the document using
-document _ _ = return $ singleError "Multiple operations not supported yet."
+--  'rootFields', and the 'Schema''s resolvers are applied to the resulting fields.
+--
+--   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
+--   errors wrapped in an /errors/ field.
+executeWithName :: MonadIO m
+    => Schema m
+    -> Text
+    -> Schema.Subs
+    -> AST.Document
+    -> m Aeson.Value
+executeWithName schema name subs doc =
+    maybe transformError (document schema $ Just name) $ Transform.document subs doc
+  where
+    transformError = return $ singleError "Schema transformation error."
+
+document :: MonadIO m => Schema m -> Maybe Text -> AST.Core.Document -> m Aeson.Value
+document schema Nothing (op :| []) = operation schema op
+document schema (Just name) operations = case NE.dropWhile matchingName operations of
+    [] -> return $ singleError
+        $ Text.unwords ["Operation", name, "couldn't be found in the document."]
+    (op:_)  -> operation schema op
+  where
+    matchingName (AST.Core.Query (Just name') _) = name == name'
+    matchingName (AST.Core.Mutation (Just name') _) = name == name'
+    matchingName _ = False
+document _ _ _ = return $ singleError "Missing operation name."
 
 operation :: MonadIO m => Schema m -> AST.Core.Operation -> m Aeson.Value
-operation schema (AST.Core.Query flds)
+operation schema (AST.Core.Query _ flds)
     = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
-operation schema (AST.Core.Mutation flds)
+operation schema (AST.Core.Mutation _ flds)
     = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-13.29
+resolver: lts-14.0
 packages:
 - '.'
 extra-deps: []

stack.yaml.lock

@@ -1,12 +0,0 @@
-# This file was autogenerated by Stack.
-# You should not edit this file by hand.
-# For more information, please see the documentation at:
-#   https://docs.haskellstack.org/en/stable/lock_files
-
-packages: []
-snapshots:
-- completed:
-    size: 500539
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/29.yaml
-    sha256: 006398c5e92d1d64737b7e98ae4d63987c36808814504d1451f56ebd98093f75
-  original: lts-13.29

tests/Language/GraphQL/EncoderSpec.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.EncoderSpec
+    ( spec
+    ) where
+
+import Language.GraphQL.AST ( Value(..))
+import Language.GraphQL.Encoder ( value
+                                , minified
+                                )
+import Test.Hspec ( Spec
+                  , describe
+                  , it
+                  , shouldBe
+                  )
+
+spec :: Spec
+spec = describe "value" $ do
+    it "escapes \\" $
+        value minified (ValueString "\\") `shouldBe` "\"\\\\\""
+    it "escapes quotes" $
+        value minified (ValueString "\"") `shouldBe` "\"\\\"\""

tests/Test/KitchenSinkSpec.hs

@@ -1,8 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Test.KitchenSinkSpec
     ( spec
     ) where
 
 import qualified Data.Text.IO as Text.IO
+import qualified Data.Text.Lazy.IO as Text.Lazy.IO
 import qualified Language.GraphQL.Encoder as Encoder
 import qualified Language.GraphQL.Parser as Parser
 import Paths_graphql (getDataFileName)
@@ -16,14 +19,58 @@ import Test.Hspec.Expectations ( expectationFailure
 import Text.Megaparsec ( errorBundlePretty
                        , parse
                        )
+import Text.RawString.QQ (r)
 
 spec :: Spec
-spec = describe "Kitchen Sink" $
+spec = describe "Kitchen Sink" $ do
-    it "prints the query" $ do
+    it "minifies the query" $ do
-        dataFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
+        dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
-        expected <- Text.IO.readFile dataFileName
+        minFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
+        actual <- Text.IO.readFile dataFileName
+        expected <- Text.Lazy.IO.readFile minFileName
 
         either
             (expectationFailure . errorBundlePretty)
-            (flip shouldBe expected . Encoder.document)
+            (flip shouldBe expected . Encoder.document Encoder.minified)
-            $ parse Parser.document dataFileName expected
+            $ parse Parser.document dataFileName actual
+
+    it "pretty prints the query" $ do
+        dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
+        actual <- Text.IO.readFile dataFileName
+        let expected = [r|query queryName($foo: ComplexType, $site: Site = MOBILE) {
+  whoever123is: node(id: [123, 456]) {
+    id
+    ... on User @defer {
+      field2 {
+        id
+        alias: field1(first: 10, after: $foo) @include(if: $foo) {
+          id
+          ...frag
+        }
+      }
+    }
+  }
+}
+
+mutation likeStory {
+  like(story: 123) @defer {
+    story {
+      id
+    }
+  }
+}
+
+fragment frag on Friend {
+  foo(size: $size, bar: $b, obj: {key: "value"})
+}
+
+{
+  unnamed(truthy: true, falsey: false)
+  query
+}
+|]
+
+        either
+            (expectationFailure . errorBundlePretty)
+            (flip shouldBe expected . Encoder.document Encoder.pretty)
+            $ parse Parser.document dataFileName actual

tests/data/kitchen-sink.graphql

@@ -7,11 +7,11 @@
 
 query queryName($foo: ComplexType, $site: Site = MOBILE) {
   whoever123is: node(id: [123, 456]) {
-    id , # Inline test comment
+    id, # Inline test comment
     ... on User @defer {
       field2 {
-        id ,
+        id,
-        alias: field1(first:10, after:$foo,) @include(if: $foo) {
+        alias: field1(first: 10, after: $foo) @include(if: $foo) {
           id,
           ...frag
         }

tests/data/kitchen-sink.min.graphql

@@ -1 +1 @@
-query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:"value"})}
+query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:"value"})}{unnamed(truthy:true,falsey:false),query}