Release 0.5.0.1

These functions are from Language.GraphQL.Schema.
There are actually only two generic types in GraphQL: Scalars and objects.
Enum is a scalar value. According to the specification enums may be
serailized to strings. And in the current implementation they used
untyped strings anyway, so there is no point to have differently named
functions with the same implementation as their scalar counterparts.

.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,41 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 
+## [0.5.0.1] - 2019-09-10
+### Added
+- Minimal documentation for all public symbols.
+
+### Deprecated
+- `Language.GraphQL.AST.FragmentName`. Replaced with Language.GraphQL.AST.Name.
+- `Language.GraphQL.Execute.Schema` - It is not a schema (at least not a
+  complete one), but a resolver list, and the resolvers should be provided by
+  the user separately, because the schema can originate from a GraphQL
+  document. `Schema` name should be free to provide a data type for the real
+  schema later.
+- `Language.GraphQL.Schema`: `enum`, `enumA`, `wrappedEnum` and `wrappedEnumA`.
+  There are actually only two generic types in GraphQL: Scalars and objects.
+  Enum is a scalar value.
+
+### Fixed
+- Parsing block string values.
+
+## [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 +88,8 @@ All notable changes to this project will be documented in this file.
 ### Added
 - Data types for the GraphQL language.
 
+[0.5.0.1]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.0...v0.5.0.1
+[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, so other solutions can
-- [ ] GraphQL Schema AST.
+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/).

docs/tutorial/tutorial.lhs

@@ -24,7 +24,6 @@ Since this file is a literate haskell file, we start by importing some dependenc
 > import Data.Time (getCurrentTime)
 >
 > import Language.GraphQL
-> import Language.GraphQL.Schema (Schema)
 > import qualified Language.GraphQL.Schema as Schema
 > import Language.GraphQL.Trans (ActionT(..))
 >
@@ -37,7 +36,7 @@ example from [graphql.js](https://github.com/graphql/graphql-js).
 
 First we build a GraphQL schema.
 
-> schema1 :: Schema IO
+> schema1 :: NonEmpty (Schema.Resolver IO)
 > schema1 = hello :| []
 >
 > hello :: Schema.Resolver IO
@@ -67,7 +66,7 @@ returning
 
 For this example, we're going to be using time.
 
-> schema2 :: Schema IO
+> schema2 :: NonEmpty (Schema.Resolver IO)
 > schema2 = time :| []
 >
 > time :: Schema.Resolver IO
@@ -127,7 +126,7 @@ This will fail
 
 Now that we have two resolvers, we can define a schema which uses them both.
 
-> schema3 :: Schema IO
+> schema3 :: NonEmpty (Schema.Resolver IO)
 > schema3 = hello :| [time]
 >
 > query3 :: Text

graphql.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: dca80d6bcaa432cabc2499efc9f047c6f59546bc2ba75b35fed6efd694895598
+-- hash: 0b3b2cb6ec02a4eeaee98d4c003d4cbe68ab81fde1810b06b0b6eeb61010298c
 
 name:           graphql
-version:        0.4.0.0
+version:        0.5.0.1
 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.1
 synopsis:            Haskell GraphQL implementation
 description:
   This package provides a rudimentary parser for the

semaphoreci.sh

@@ -19,7 +19,8 @@ test() {
 }
 
 test_docs() {
-	$STACK --no-terminal ghc -- -Wall -fno-code docs/tutorial/tutorial.lhs
+	$STACK --no-terminal ghc -- -Wall -Werror -fno-code docs/tutorial/tutorial.lhs
+        $STACK --no-terminal haddock --no-haddock-deps
 }
 
 setup_lint() {

src/Language/GraphQL.hs

@@ -5,32 +5,31 @@ module Language.GraphQL
     ) where
 
 import Control.Monad.IO.Class (MonadIO)
-import qualified Data.Text as T
-
 import qualified Data.Aeson as Aeson
-import Text.Megaparsec (parse)
+import Data.List.NonEmpty (NonEmpty)
-
+import qualified Data.Text as T
+import Language.GraphQL.Error
 import Language.GraphQL.Execute
 import Language.GraphQL.Parser
-import Language.GraphQL.Schema
+import qualified Language.GraphQL.Schema as Schema
+import Text.Megaparsec (parse)
 
-import Language.GraphQL.Error
+-- | If the text parses correctly as a @GraphQL@ query the query is
-
+-- executed using the given 'Schema.Resolver's.
--- | Takes a 'Schema' and text representing a @GraphQL@ request document.
+graphql :: MonadIO m
---   If the text parses correctly as a @GraphQL@ query the query is
+    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
---   executed according to the given 'Schema'.
+    -> T.Text -- ^ Text representing a @GraphQL@ request document.
---
+    -> m Aeson.Value -- ^ Response.
---   Returns the response as an @Aeson.@'Aeson.Value'.
-graphql :: MonadIO m => Schema m -> T.Text -> m Aeson.Value
 graphql = flip graphqlSubs $ const Nothing
 
--- | Takes a 'Schema', a variable substitution function and text
+-- | If the text parses correctly as a @GraphQL@ query the substitution is
---   representing a @GraphQL@ request document.  If the text parses
+-- applied to the query and the query is then executed using to the given
---   correctly as a @GraphQL@ query the substitution is applied to the
+-- 'Schema.Resolver's.
---   query and the query is then executed according to the given 'Schema'.
+graphqlSubs :: MonadIO m
---
+    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
---   Returns the response as an @Aeson.@'Aeson.Value'.
+    -> Schema.Subs -- ^ Variable substitution function.
-graphqlSubs :: MonadIO m => Schema m -> Subs -> T.Text -> m Aeson.Value
+    -> T.Text -- ^ Text representing a @GraphQL@ request document.
-graphqlSubs schema f =
+    -> m Aeson.Value -- ^ Response.
-    either parseError (execute schema f)
+graphqlSubs schema f
+    = either parseError (execute schema f)
     . parse document ""

src/Language/GraphQL/AST.hs

@@ -39,63 +39,82 @@ import Language.GraphQL.AST.Core ( Alias
 
 -- * Document
 
+-- | GraphQL document.
 type Document = NonEmpty Definition
 
 -- * Operations
 
+-- | Top-level definition of a document, either an operation or a fragment.
 data Definition = DefinitionOperation OperationDefinition
                 | DefinitionFragment  FragmentDefinition
-                  deriving (Eq,Show)
+                  deriving (Eq, Show)
 
+-- | Operation definition.
 data OperationDefinition = OperationSelectionSet SelectionSet
                          | OperationDefinition   OperationType
                                                  (Maybe Name)
                                                  VariableDefinitions
                                                  Directives
                                                  SelectionSet
-                           deriving (Eq,Show)
+                           deriving (Eq, Show)
 
-data OperationType = Query | Mutation deriving (Eq,Show)
+-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
+--
+-- Currently only queries and mutations are supported.
+data OperationType = Query | Mutation deriving (Eq, Show)
 
--- * SelectionSet
+-- * Selections
 
+-- | "Top-level" selection, selection on a operation.
 type SelectionSet = NonEmpty Selection
 
 type SelectionSetOpt = [Selection]
 
-data Selection = SelectionField          Field
+-- | Single selection element.
+data Selection
+    = SelectionField          Field
     | SelectionFragmentSpread FragmentSpread
     | SelectionInlineFragment InlineFragment
-                 deriving (Eq,Show)
+    deriving (Eq, Show)
 
 -- * Field
 
-data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
+-- | GraphQL field.
-             deriving (Eq,Show)
+data Field
+    = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
+    deriving (Eq, Show)
 
 -- * Arguments
 
+-- | Argument list.
 type Arguments = [Argument]
 
+-- | Argument.
 data Argument = Argument Name Value deriving (Eq,Show)
 
 -- * Fragments
 
-data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)
+-- | Fragment spread.
+data FragmentSpread = FragmentSpread Name Directives deriving (Eq, Show)
 
+-- | Inline fragment.
 data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
-                      deriving (Eq,Show)
+                      deriving (Eq, Show)
 
-data FragmentDefinition =
+-- | Fragment definition.
-  FragmentDefinition FragmentName TypeCondition Directives SelectionSet
+data FragmentDefinition
-  deriving (Eq,Show)
+    = FragmentDefinition Name TypeCondition Directives SelectionSet
+    deriving (Eq, Show)
 
+{-# DEPRECATED FragmentName "Use Name instead" #-}
 type FragmentName = Name
 
+-- | Type condition.
 type TypeCondition = Name
 
 -- * Input values
 
+-- | Input value.
 data Value = ValueVariable Name
            | ValueInt Int32
            | ValueFloat Double
@@ -107,28 +126,38 @@ data Value = ValueVariable Name
            | ValueObject [ObjectField]
            deriving (Eq, Show)
 
+-- | Key-value pair.
+--
+-- A list of 'ObjectField's represents a GraphQL object type.
 data ObjectField = ObjectField Name Value deriving (Eq, Show)
 
 -- * Variables
 
+-- | Variable definition list.
 type VariableDefinitions = [VariableDefinition]
 
+-- | Variable definition.
 data VariableDefinition = VariableDefinition Name Type (Maybe Value)
-                          deriving (Eq,Show)
+                          deriving (Eq, Show)
 
 -- * Input types
 
+-- | Type representation.
 data Type = TypeNamed   Name
           | TypeList    Type
           | TypeNonNull NonNullType
-            deriving (Eq,Show)
+            deriving (Eq, Show)
 
+
+-- | Helper type to represent Non-Null types and lists of such types.
 data NonNullType = NonNullTypeNamed Name
                  | NonNullTypeList  Type
-                   deriving (Eq,Show)
+                   deriving (Eq, Show)
 
 -- * Directives
 
+-- | Directive list.
 type Directives = [Directive]
 
-data Directive = Directive Name [Argument] deriving (Eq,Show)
+-- | Directive.
+data Directive = Directive Name [Argument] deriving (Eq, Show)

src/Language/GraphQL/AST/Core.hs

@@ -19,19 +19,70 @@ import Data.Text (Text)
 -- | Name
 type Name = Text
 
+-- | GraphQL document is a non-empty list of operations.
 type Document = NonEmpty Operation
 
-data Operation = Query    (NonEmpty Field)
+-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
-               | Mutation (NonEmpty Field)
+--
-                 deriving (Eq,Show)
+-- Currently only queries and mutations are supported.
+data Operation
+    = Query (Maybe Text) (NonEmpty Field)
+    | Mutation (Maybe Text) (NonEmpty Field)
+    deriving (Eq, Show)
 
-data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)
+-- | A single GraphQL field.
+--
+-- Only required property of a field, is its name. Optionally it can also have
+-- an alias, arguments or a list of subfields.
+--
+-- Given the following query:
+--
+-- @
+-- {
+--   zuck: user(id: 4) {
+--     id
+--     name
+--   }
+-- }
+-- @
+--
+-- * "user", "id" and "name" are field names.
+-- * "user" has two subfields, "id" and "name".
+-- * "zuck" is an alias for "user". "id" and "name" have no aliases.
+-- * "id: 4" is an argument for "name". "id" and "name don't have any
+-- arguments.
+data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq, Show)
 
+-- | 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
 
-data Argument = Argument Name Value deriving (Eq,Show)
+-- | Single argument.
+--
+-- @
+-- {
+--   user(id: 4) {
+--     name
+--   }
+-- }
+-- @
+--
+--  Here "id" is an argument for the field "user" and its value is 4.
+data Argument = Argument Name Value deriving (Eq, Show)
 
-data Value = ValueInt Int32
+-- | Represents accordingly typed GraphQL values.
+data Value
+    = ValueInt Int32
     -- GraphQL Float is double precision
     | ValueFloat Double
     | ValueString Text
@@ -40,9 +91,12 @@ data Value = ValueInt Int32
     | ValueEnum Name
     | ValueList [Value]
     | ValueObject [ObjectField]
-             deriving (Eq,Show)
+    deriving (Eq, Show)
 
 instance IsString Value where
   fromString = ValueString . fromString
 
-data ObjectField = ObjectField Name Value deriving (Eq,Show)
+-- | Key-value pair.
+--
+-- A list of 'ObjectField's represents a GraphQL object type.
+data ObjectField = ObjectField Name Value deriving (Eq, Show)

src/Language/GraphQL/AST/Transform.hs

@@ -18,7 +18,8 @@ import qualified Language.GraphQL.Schema as Schema
 --   empty list is returned.
 type Fragmenter = Core.Name -> [Core.Field]
 
--- TODO: Replace Maybe by MonadThrow with CustomError
+-- | Rewrites the original syntax tree into an intermediate representation used
+-- for query execution.
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
 document subs doc = operations subs fr ops
   where
@@ -41,7 +42,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 +50,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

@@ -1,42 +1,76 @@
 {-# LANGUAGE OverloadedStrings #-}
 
--- | This module provides the function to execute a @GraphQL@ request --
+-- | This module provides functions to execute a @GraphQL@ request.
---   according to a 'Schema'.
 module Language.GraphQL.Execute
     ( execute
+    , executeWithName
     ) where
 
 import Control.Monad.IO.Class (MonadIO)
-import qualified Data.List.NonEmpty as NE
-import Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.Aeson as Aeson
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
+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 Language.GraphQL.Error
-import Language.GraphQL.Schema (Schema)
 import qualified Language.GraphQL.Schema as Schema
 
--- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a
+-- | The substitution is applied to the document, and the resolvers are applied
---   @GraphQL@ 'document'. The substitution is applied to the document using
+-- to the resulting fields.
---  '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
+-- Returns the result of the query against the schema wrapped in a /data/
---   errors wrapped in an /errors/ field.
+-- field, or errors wrapped in an /errors/ field.
-execute
+execute :: MonadIO m
-    :: MonadIO m
+    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
-    => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value
+    -> Schema.Subs -- ^ Variable substitution function.
+    -> AST.Document -- @GraphQL@ 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
+-- | The substitution is applied to the document, and the resolvers are applied
-document schema (op :| []) = operation schema op
+-- to the resulting fields. The operation name can be used if the document
-document _ _ = return $ singleError "Multiple operations not supported yet."
+-- defines multiple root operations.
+--
+-- Returns the result of the query against the schema wrapped in a /data/
+-- field, or errors wrapped in an /errors/ field.
+executeWithName :: MonadIO m
+    => NonEmpty (Schema.Resolver m) -- ^ Resolvers
+    -> Text -- ^ Operation name.
+    -> Schema.Subs -- ^ Variable substitution function.
+    -> AST.Document -- ^ @GraphQL@ 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."
 
-operation :: MonadIO m => Schema m -> AST.Core.Operation -> m Aeson.Value
+document :: MonadIO m
-operation schema (AST.Core.Query flds)
+    => NonEmpty (Schema.Resolver 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
+    => NonEmpty (Schema.Resolver m)
+    -> AST.Core.Operation
+    -> m Aeson.Value
+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))

src/Language/GraphQL/Lexer.hs

@@ -71,6 +71,8 @@ type Parser = Parsec Void T.Text
 ignoredCharacters :: Parser ()
 ignoredCharacters = space1 <|> skipSome (char ',')
 
+-- | Parser that skips comments and meaningless characters, whitespaces and
+-- commas.
 spaceConsumer :: Parser ()
 spaceConsumer = Lexer.space ignoredCharacters comment empty
 

src/Language/GraphQL/Parser.hs

@@ -16,6 +16,7 @@ import Text.Megaparsec ( lookAhead
                        , (<?>)
                        )
 
+-- | Parser for the GraphQL documents.
 document :: Parser Document
 document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)
 
@@ -93,7 +94,7 @@ fragmentDefinition = FragmentDefinition
                  <*> opt directives
                  <*> selectionSet
 
-fragmentName :: Parser FragmentName
+fragmentName :: Parser Name
 fragmentName = but (symbol "on") *> name
 
 typeCondition :: Parser TypeCondition
@@ -107,8 +108,8 @@ value = ValueVariable <$> variable
     <|> ValueInt      <$> integer
     <|> ValueBoolean  <$> booleanValue
     <|> ValueNull     <$  symbol "null"
-    <|> ValueString   <$> string
     <|> ValueString   <$> blockString
+    <|> ValueString   <$> string
     <|> ValueEnum     <$> try enumValue
     <|> ValueList     <$> listValue
     <|> ValueObject   <$> objectValue

src/Language/GraphQL/Schema.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
---   functions for defining and manipulating Schemas.
+-- functions for defining and manipulating schemas.
 module Language.GraphQL.Schema
     ( Resolver
     , Schema
@@ -43,6 +43,7 @@ import Language.GraphQL.Trans
 import Language.GraphQL.Type
 import Language.GraphQL.AST.Core
 
+{-# DEPRECATED Schema "Use NonEmpty (Resolver m) instead" #-}
 -- | A GraphQL schema.
 --   @m@ is usually expected to be an instance of 'MonadIO'.
 type Schema m = NonEmpty (Resolver m)
@@ -110,18 +111,17 @@ wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
     => Name -> ActionT m (Wrapping a) -> Resolver m
 wrappedScalar name = wrappedScalarA name . const
 
--- | Represents one of a finite set of possible values.
+{-# DEPRECATED enum "Use scalar instead" #-}
---   Used in place of a 'scalar' when the possible responses are easily enumerable.
 enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
 enum name = enumA name . const
 
--- | Like 'enum' but also taking 'Argument's.
+{-# DEPRECATED enumA "Use scalarA instead" #-}
 enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
 enumA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld resolver = withField (return resolver) fld
 
--- | Like 'enum' but also taking 'Argument's and can be null or a list of enums.
+{-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-}
 wrappedEnumA :: MonadIO m
     => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
 wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
@@ -131,7 +131,7 @@ wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
         = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
     resolveRight fld (List resolver) = withField (return resolver) fld
 
--- | Like 'enum' but can be null or a list of enums.
+{-# DEPRECATED wrappedEnum "Use wrappedScalar instead" #-}
 wrappedEnum :: MonadIO m => Name -> ActionT m (Wrapping [Text]) -> Resolver m
 wrappedEnum name = wrappedEnumA name . const
 

src/Language/GraphQL/Trans.hs

@@ -9,6 +9,7 @@ import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Except (ExceptT)
 import Data.Text (Text)
 
+-- | Monad transformer stack used by the resolvers to provide error handling.
 newtype ActionT m a = ActionT { runActionT :: ExceptT Text m a }
 
 instance Functor m => Functor (ActionT m) where

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-13.29
+resolver: lts-14.5
 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/Language/GraphQL/ParserSpec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Language.GraphQL.ParserSpec
     ( spec
     ) where
@@ -11,8 +12,19 @@ import Test.Hspec ( Spec
                   , shouldSatisfy
                   )
 import Text.Megaparsec (parse)
+import Text.RawString.QQ (r)
 
 spec :: Spec
-spec = describe "Parser" $
+spec = describe "Parser" $ do
     it "accepts BOM header" $
         parse document "" "\xfeff{foo}" `shouldSatisfy` isRight
+
+    it "accepts block strings as argument" $
+        parse document "" [r|{
+              hello(text: """Argument""")
+            }|] `shouldSatisfy` isRight
+
+    it "accepts strings as argument" $
+        parse document "" [r|{
+              hello(text: "Argument")
+            }|] `shouldSatisfy` isRight

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/Test/StarWars/Data.hs

@@ -26,6 +26,7 @@ import Control.Monad.Trans.Except (throwE)
 import Data.Maybe (catMaybes)
 import Data.Text (Text)
 import Language.GraphQL.Trans
+import Language.GraphQL.Type
 
 -- * Data
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@@ -190,8 +191,8 @@ getDroid' _      = empty
 getFriends :: Character -> [Character]
 getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
 
-getEpisode :: Alternative f => Int -> f Text
+getEpisode :: Int -> Maybe (Wrapping Text)
-getEpisode 4 = pure "NEWHOPE"
+getEpisode 4 = pure $ Named "NEWHOPE"
-getEpisode 5 = pure "EMPIRE"
+getEpisode 5 = pure $ Named "EMPIRE"
-getEpisode 6 = pure "JEDI"
+getEpisode 6 = pure $ Named "JEDI"
 getEpisode _ = empty

tests/Test/StarWars/Schema.hs

@@ -11,52 +11,48 @@ module Test.StarWars.Schema
 import Control.Monad.Trans.Except (throwE)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.IO.Class (MonadIO(..))
-import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.List.NonEmpty (NonEmpty(..))
-import Language.GraphQL.Schema ( Schema
+import Data.Maybe (catMaybes)
-                               , Resolver
-                               , Argument(..)
-                               , Value(..)
-                               )
 import qualified Language.GraphQL.Schema as Schema
 import Language.GraphQL.Trans
 import Language.GraphQL.Type
 import Test.StarWars.Data
 
--- * Schema
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
 
-schema :: MonadIO m => Schema m
+schema :: MonadIO m => NonEmpty (Schema.Resolver m)
 schema = hero :| [human, droid]
 
-hero :: MonadIO m => Resolver m
+hero :: MonadIO m => Schema.Resolver m
 hero = Schema.objectA "hero" $ \case
   [] -> character artoo
-  [Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4
+  [Schema.Argument "episode" (Schema.ValueEnum "NEWHOPE")] -> character $ getHero 4
-  [Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5
+  [Schema.Argument "episode" (Schema.ValueEnum "EMPIRE" )] -> character $ getHero 5
-  [Argument "episode" (ValueEnum "JEDI"   )] -> character $ getHero 6
+  [Schema.Argument "episode" (Schema.ValueEnum "JEDI"   )] -> character $ getHero 6
   _ -> ActionT $ throwE "Invalid arguments."
 
-human :: MonadIO m => Resolver m
+human :: MonadIO m => Schema.Resolver m
 human = Schema.wrappedObjectA "human" $ \case
-  [Argument "id" (ValueString i)] -> do
+  [Schema.Argument "id" (Schema.ValueString i)] -> do
       humanCharacter <- lift $ return $ getHuman i >>= Just
       case humanCharacter of
         Nothing -> return Null
         Just e -> Named <$> character e
   _ -> ActionT $ throwE "Invalid arguments."
 
-droid :: MonadIO m => Resolver m
+droid :: MonadIO m => Schema.Resolver m
 droid = Schema.objectA "droid" $ \case
-   [Argument "id" (ValueString i)] -> character =<< liftIO (getDroid i)
+   [Schema.Argument "id" (Schema.ValueString i)] -> character =<< liftIO (getDroid i)
    _ -> ActionT $ throwE "Invalid arguments."
 
-character :: MonadIO m => Character -> ActionT m [Resolver m]
+character :: MonadIO m => Character -> ActionT m [Schema.Resolver m]
 character char = return
     [ Schema.scalar "id" $ return $ id_ char
     , Schema.scalar "name" $ return $ name char
     , Schema.wrappedObject "friends"
         $ traverse character $ List $ Named <$> getFriends char
-    , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char
+    , Schema.wrappedScalar "appearsIn" $ return . List
+        $ catMaybes (getEpisode <$> appearsIn char)
     , Schema.scalar "secretBackstory" $ secretBackstory char
     , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
     , Schema.scalar "__typename" $ return $ typeName char

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}