graphql 0.5.1.0 → 0.6.0.0

raw patch · 26 files changed

+1215/−1142 lines, 26 filesdep +containersdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• CHANGELOG.md +44/−0
• graphql.cabal +12/−11
• src/Language/GraphQL.hs +1/−1
• src/Language/GraphQL/AST.hs +64/−46
• src/Language/GraphQL/AST/Core.hs +26/−78
• src/Language/GraphQL/AST/Encoder.hs +277/−0
• src/Language/GraphQL/AST/Lexer.hs +228/−0
• src/Language/GraphQL/AST/Parser.hs +188/−0
• src/Language/GraphQL/AST/Transform.hs +111/−97
• src/Language/GraphQL/Encoder.hs +0/−277
• src/Language/GraphQL/Execute.hs +3/−2
• src/Language/GraphQL/Lexer.hs +0/−228
• src/Language/GraphQL/Parser.hs +0/−188
• src/Language/GraphQL/Schema.hs +15/−47
• src/Language/GraphQL/Trans.hs +13/−3
• src/Language/GraphQL/Type.hs +2/−4
• tests/Language/GraphQL/AST/EncoderSpec.hs +19/−0
• tests/Language/GraphQL/AST/LexerSpec.hs +92/−0
• tests/Language/GraphQL/AST/ParserSpec.hs +32/−0
• tests/Language/GraphQL/EncoderSpec.hs +0/−21
• tests/Language/GraphQL/LexerSpec.hs +0/−92
• tests/Language/GraphQL/ParserSpec.hs +0/−26
• tests/Test/FragmentSpec.hs +71/−4
• tests/Test/KitchenSinkSpec.hs +2/−2
• tests/Test/StarWars/Data.hs +5/−5
• tests/Test/StarWars/Schema.hs +10/−10

@@ -1,6 +1,49 @@ # Change Log All notable changes to this project will be documented in this file. +## [0.6.0.0] - 2019-11-27+### Changed+- `Language.GraphQL.Encoder` moved to `Language.GraphQL.AST.Encoder`.+- `Language.GraphQL.Parser` moved to `Language.GraphQL.AST.Parser`.+- `Language.GraphQL.Lexer` moved to `Language.GraphQL.AST.Lexer`.+- All `Language.GraphQL.AST.Value` data constructor prefixes were removed. The+  module should be imported qualified.+- All `Language.GraphQL.AST.Core.Value` data constructor prefixes were removed.+  The module should be imported qualified.+- `Language.GraphQL.AST.Core.Object` is now just a HashMap.+- `Language.GraphQL.AST.Transform` is isn't exposed publically anymore.+- `Language.GraphQL.Schema.resolve` accepts a selection `Seq` (`Data.Sequence`)+  instead of a list. Selections are stored as sequences internally as well.+- Add a reader instance to the resolver's monad stack. The Reader contains+  a Name/Value hashmap, which will contain resolver arguments.++### Added+- Nested fragment support.++### Fixed+- Consume ignored tokens after `$` and `!`. I mistakenly assumed that+  `$variable` is a single token, same as `Type!` is a single token. This is not+  the case, for example `Variable` is defined as `$ Name`, so these are two+  tokens, therefore whitespaces and commas after `$` and `!` should be+  consumed.++### Improved+- `Language.GraphQL.AST.Parser.type_`: Try type parsers in a variable+  definition in a different order to avoid using `but`.++### Removed+- `Language.GraphQL.AST.Arguments`. Use `[Language.GraphQL.AST.Argument]`+  instead.+- `Language.GraphQL.AST.Directives`. Use `[Language.GraphQL.AST.Directives]`+  instead.+- `Language.GraphQL.AST.VariableDefinitions`. Use+  `[Language.GraphQL.AST.VariableDefinition]` instead.+- `Language.GraphQL.AST.FragmentName`. Use `Language.GraphQL.AST.Name` instead.+- `Language.GraphQL.Execute.Schema` - It was a resolver list, not a schema.+- `Language.GraphQL.Schema`: `enum`, `enumA`, `wrappedEnum` and `wrappedEnumA`.+  Use `scalar`, `scalarA`, `wrappedScalar` and `wrappedScalarA` instead.++ ## [0.5.1.0] - 2019-10-22 ### Deprecated - `Language.GraphQL.AST.Arguments`. Use `[Language.GraphQL.AST.Argument]`@@ -105,6 +148,7 @@ ### Added - Data types for the GraphQL language. +[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 [0.5.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.4.0.0...v0.5.0.0

@@ -1,6 +1,6 @@ cabal-version: 1.12 name: graphql-version: 0.5.1.0+version: 0.6.0.0 license: BSD3 license-file: LICENSE copyright: (c) 2019 Eugen Wissner,@@ -34,22 +34,22 @@         Language.GraphQL         Language.GraphQL.AST         Language.GraphQL.AST.Core-        Language.GraphQL.AST.Transform-        Language.GraphQL.Encoder+        Language.GraphQL.AST.Encoder+        Language.GraphQL.AST.Lexer+        Language.GraphQL.AST.Parser         Language.GraphQL.Error         Language.GraphQL.Execute-        Language.GraphQL.Lexer-        Language.GraphQL.Parser         Language.GraphQL.Schema         Language.GraphQL.Trans         Language.GraphQL.Type     hs-source-dirs: src     other-modules:-        Paths_graphql+        Language.GraphQL.AST.Transform     default-language: Haskell2010     build-depends:-        aeson >=1.4.5.0 && <1.5,+        aeson >=1.4.6.0 && <1.5,         base >=4.7 && <5,+        containers >=0.6.0.1 && <0.7,         megaparsec >=7.0.5 && <7.1,         text >=1.2.3.1 && <1.3,         transformers >=0.5.6.2 && <0.6,@@ -60,10 +60,10 @@     main-is: Spec.hs     hs-source-dirs: tests     other-modules:-        Language.GraphQL.EncoderSpec+        Language.GraphQL.AST.EncoderSpec+        Language.GraphQL.AST.LexerSpec+        Language.GraphQL.AST.ParserSpec         Language.GraphQL.ErrorSpec-        Language.GraphQL.LexerSpec-        Language.GraphQL.ParserSpec         Test.FragmentSpec         Test.KitchenSinkSpec         Test.StarWars.Data@@ -73,8 +73,9 @@     default-language: Haskell2010     ghc-options: -threaded -rtsopts -with-rtsopts=-N     build-depends:-        aeson >=1.4.5.0 && <1.5,+        aeson >=1.4.6.0 && <1.5,         base >=4.7 && <5,+        containers >=0.6.0.1 && <0.7,         graphql -any,         hspec >=2.7.1 && <2.8,         hspec-expectations >=0.8.2 && <0.9,

@@ -10,7 +10,7 @@ import qualified Data.Text as T import Language.GraphQL.Error import Language.GraphQL.Execute-import Language.GraphQL.Parser+import Language.GraphQL.AST.Parser import qualified Language.GraphQL.Schema as Schema import Text.Megaparsec (parse) 

@@ -5,14 +5,11 @@ module Language.GraphQL.AST     ( Alias     , Argument(..)-    , Arguments     , Definition(..)     , Directive(..)-    , Directives     , Document     , Field(..)     , FragmentDefinition(..)-    , FragmentName     , FragmentSpread(..)     , InlineFragment(..)     , Name@@ -27,22 +24,23 @@     , TypeCondition     , Value(..)     , VariableDefinition(..)-    , VariableDefinitions     ) where  import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text)-import Language.GraphQL.AST.Core ( Alias-                                 , Name-                                 , TypeCondition-                                 )  -- * Document  -- | GraphQL document. type Document = NonEmpty Definition +-- | Name+type Name = Text++-- | Directive.+data Directive = Directive Name [Argument] deriving (Eq, Show)+ -- * Operations  -- | Top-level definition of a document, either an operation or a fragment.@@ -68,7 +66,7 @@  -- * Selections --- | "Top-level" selection, selection on a operation.+-- | "Top-level" selection, selection on an operation or fragment. type SelectionSet = NonEmpty Selection  -- | Field selection.@@ -83,18 +81,56 @@  -- * Field --- | GraphQL field.+-- | Single GraphQL field.+--+-- The 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 "user". "id" and "name" don't have any+-- arguments. data Field     = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt     deriving (Eq, Show) --- * Arguments---- | Argument list.-{-# DEPRECATED Arguments "Use [Argument] instead" #-}-type Arguments = [Argument]+-- | 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 --- | Argument.+-- | 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)  -- * Fragments@@ -111,21 +147,18 @@     = FragmentDefinition Name TypeCondition [Directive] SelectionSet     deriving (Eq, Show) -{-# DEPRECATED FragmentName "Use Name instead" #-}-type FragmentName = Name---- * Input values+-- * Inputs  -- | Input value.-data Value = ValueVariable Name-           | ValueInt Int32-           | ValueFloat Double-           | ValueString Text-           | ValueBoolean Bool-           | ValueNull-           | ValueEnum Name-           | ValueList [Value]-           | ValueObject [ObjectField]+data Value = Variable Name+           | Int Int32+           | Float Double+           | String Text+           | Boolean Bool+           | Null+           | Enum Name+           | List [Value]+           | Object [ObjectField]            deriving (Eq, Show)  -- | Key-value pair.@@ -133,17 +166,12 @@ -- A list of 'ObjectField's represents a GraphQL object type. data ObjectField = ObjectField Name Value deriving (Eq, Show) --- * Variables---- | Variable definition list.-{-# DEPRECATED VariableDefinitions "Use [VariableDefinition] instead" #-}-type VariableDefinitions = [VariableDefinition]- -- | Variable definition. data VariableDefinition = VariableDefinition Name Type (Maybe Value)                           deriving (Eq, Show) --- * Input types+-- | Type condition.+type TypeCondition = Name  -- | Type representation. data Type = TypeNamed   Name@@ -151,17 +179,7 @@           | TypeNonNull NonNullType             deriving (Eq, Show) - -- | Helper type to represent Non-Null types and lists of such types. data NonNullType = NonNullTypeNamed Name                  | NonNullTypeList  Type                    deriving (Eq, Show)---- * Directives---- | Directive list.-{-# DEPRECATED Directives "Use [Directive] instead" #-}-type Directives = [Directive]---- | Directive.-data Directive = Directive Name [Argument] deriving (Eq, Show)

@@ -6,7 +6,6 @@     , Field(..)     , Fragment(..)     , Name-    , ObjectField(..)     , Operation(..)     , Selection(..)     , TypeCondition@@ -14,12 +13,12 @@     ) where  import Data.Int (Int32)+import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty)-import Data.String+import Data.Sequence (Seq)+import Data.String (IsString(..)) import Data.Text (Text)---- | Name-type Name = Text+import Language.GraphQL.AST (Alias, Name, TypeCondition)  -- | GraphQL document is a non-empty list of operations. type Document = NonEmpty Operation@@ -28,87 +27,21 @@ -- -- Currently only queries and mutations are supported. data Operation-    = Query (Maybe Text) (NonEmpty Selection)-    | Mutation (Maybe Text) (NonEmpty Selection)+    = Query (Maybe Text) (Seq Selection)+    | Mutation (Maybe Text) (Seq Selection)     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] [Selection] 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+-- | Single GraphQL field.+data Field+    = Field (Maybe Alias) Name [Argument] (Seq Selection)+    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) --- | Represents accordingly typed GraphQL values.-data Value-    = ValueInt Int32-    -- GraphQL Float is double precision-    | ValueFloat Double-    | ValueString Text-    | ValueBoolean Bool-    | ValueNull-    | ValueEnum Name-    | ValueList [Value]-    | ValueObject [ObjectField]-    deriving (Eq, Show)--instance IsString Value where-  fromString = ValueString . fromString---- | Key-value pair.------ A list of 'ObjectField's represents a GraphQL object type.-data ObjectField = ObjectField Name Value deriving (Eq, Show)---- | Type condition.-type TypeCondition = Name- -- | Represents fragments and inline fragments. data Fragment-    = Fragment TypeCondition (NonEmpty Selection)+    = Fragment TypeCondition (Seq Selection)     deriving (Eq, Show)  -- | Single selection element.@@ -116,3 +49,18 @@     = SelectionFragment Fragment     | SelectionField Field     deriving (Eq, Show)++-- | Represents accordingly typed GraphQL values.+data Value+    = Int Int32+    | Float Double -- ^ GraphQL Float is double precision+    | String Text+    | Boolean Bool+    | Null+    | Enum Name+    | List [Value]+    | Object (HashMap Name Value)+    deriving (Eq, Show)++instance IsString Value where+    fromString = String . fromString

@@ -0,0 +1,277 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExplicitForAll #-}++-- | This module defines a minifier and a printer for the @GraphQL@ language.+module Language.GraphQL.AST.Encoder+    ( Formatter+    , 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.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 qualified Language.GraphQL.AST as Full++-- | Instructs the encoder whether the GraphQL document should be minified or+--   pretty printed.+--+--   Use 'pretty' or 'minified' to construct the formatter.+data Formatter+    = Minified+    | Pretty Word++-- | Constructs a formatter for pretty printing.+pretty :: Formatter+pretty = Pretty 0++-- | Constructs a formatter for minifying.+minified :: Formatter+minified = Minified++-- | Converts a 'Full.Document' into a string.+document :: Formatter -> Full.Document -> Text+document formatter defs+    | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument+    | Minified <-formatter = Text.Lazy.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 x+    | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n'+    | Minified <- formatter = encodeDefinition x+  where+    encodeDefinition (Full.DefinitionOperation operation)+        = operationDefinition formatter operation+    encodeDefinition (Full.DefinitionFragment fragment)+        = fragmentDefinition formatter fragment++operationDefinition :: Formatter -> Full.OperationDefinition -> Text+operationDefinition formatter (Full.OperationSelectionSet sels)+    = selectionSet formatter sels+operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)+    = "query " <> node formatter name vars dirs sels+operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)+    = "mutation " <> node formatter name vars dirs sels++node :: Formatter+    -> Maybe Full.Name+    -> [Full.VariableDefinition]+    -> [Full.Directive]+    -> Full.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++variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Text+variableDefinitions formatter+    = parensCommas formatter $ variableDefinition formatter++variableDefinition :: Formatter -> Full.VariableDefinition -> 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 val+    = eitherFormat formatter " = " "="+    <> value formatter val++variable :: Full.Name -> Text+variable var = "$" <> Text.Lazy.fromStrict var++selectionSet :: Formatter -> Full.SelectionSet -> Text+selectionSet formatter+    = bracesList formatter (selection formatter)+    . NonEmpty.toList++selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Text+selectionSetOpt formatter = bracesList formatter $ selection formatter++selection :: Formatter -> Full.Selection -> Text+selection formatter = Text.Lazy.append indent . f+  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+field formatter (Full.Field alias name args dirs selso)+    = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias)+    <> Text.Lazy.fromStrict name+    <> optempty (arguments formatter) args+    <> optempty (directives formatter) dirs+    <> selectionSetOpt'+  where+    colon = eitherFormat formatter ": " ":"+    selectionSetOpt'+        | null selso = mempty+        | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso++arguments :: Formatter -> [Full.Argument] -> Text+arguments formatter = parensCommas formatter $ argument formatter++argument :: Formatter -> Full.Argument -> Text+argument formatter (Full.Argument name v)+    = Text.Lazy.fromStrict name+    <> eitherFormat formatter ": " ":"+    <> value formatter v++-- * Fragments++fragmentSpread :: Formatter -> Full.FragmentSpread -> Text+fragmentSpread formatter (Full.FragmentSpread name ds)+    = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds++inlineFragment :: Formatter -> Full.InlineFragment -> Text+inlineFragment formatter (Full.InlineFragment tc dirs sels)+    = "... on "+    <> Text.Lazy.fromStrict (fold tc)+    <> directives formatter dirs+    <> eitherFormat formatter " " mempty+    <> selectionSet formatter sels++fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Text+fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)+    = "fragment " <> Text.Lazy.fromStrict name+    <> " on " <> Text.Lazy.fromStrict tc+    <> optempty (directives formatter) dirs+    <> eitherFormat formatter " " mempty+    <> selectionSet formatter sels++-- * Miscellaneous++-- | Converts a 'Full.Directive' into a string.+directive :: Formatter -> Full.Directive -> Text+directive formatter (Full.Directive name args)+    = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args++directives :: Formatter -> [Full.Directive] -> Text+directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)+directives Minified = spaces (directive Minified)++-- | Converts a 'Full.Value' into a string.+value :: Formatter -> Full.Value -> Text+value _ (Full.Variable x) = variable x+value _ (Full.Int x) = toLazyText $ decimal x+value _ (Full.Float x) = toLazyText $ realFloat x+value _ (Full.Boolean  x) = booleanValue x+value _ Full.Null = mempty+value _ (Full.String x) = stringValue $ Text.Lazy.fromStrict x+value _ (Full.Enum x) = Text.Lazy.fromStrict x+value formatter (Full.List x) = listValue formatter x+value formatter (Full.Object x) = objectValue formatter x++booleanValue :: Bool -> Text+booleanValue True  = "true"+booleanValue False = "false"++stringValue :: Text -> Text+stringValue+    = quotes+    . Text.Lazy.replace "\"" "\\\""+    . Text.Lazy.replace "\\" "\\\\"++listValue :: Formatter -> [Full.Value] -> Text+listValue formatter = bracketsCommas formatter $ value formatter++objectValue :: Formatter -> [Full.ObjectField] -> Text+objectValue formatter = intercalate $ objectField formatter+  where+    intercalate f+        = braces+        . Text.Lazy.intercalate (eitherFormat formatter ", " ",")+        . fmap f+++objectField :: Formatter -> Full.ObjectField -> Text+objectField formatter (Full.ObjectField name v)+    = 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.TypeNamed   x) = Text.Lazy.fromStrict x+type' (Full.TypeList    x) = listType x+type' (Full.TypeNonNull x) = nonNullType x++listType :: Full.Type -> Text+listType x = brackets (type' x)++nonNullType :: Full.NonNullType -> Text+nonNullType (Full.NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"+nonNullType (Full.NonNullTypeList  x) = listType x <> "!"++-- * Internal++between :: Char -> Char -> Text -> Text+between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close)++parens :: Text -> Text+parens = between '(' ')'++brackets :: Text -> Text+brackets = between '[' ']'++braces :: Text -> Text+braces = between '{' '}'++quotes :: Text -> Text+quotes = between '"' '"'++spaces :: forall a. (a -> Text) -> [a] -> 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 ", " ",")+    . fmap f++bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text+bracketsCommas formatter f+    = brackets+    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")+    . fmap f++bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text+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

@@ -0,0 +1,228 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module defines a bunch of small parsers used to parse individual+--   lexemes.+module Language.GraphQL.AST.Lexer+    ( Parser+    , amp+    , at+    , bang+    , blockString+    , braces+    , brackets+    , colon+    , dollar+    , comment+    , equals+    , integer+    , float+    , lexeme+    , name+    , parens+    , pipe+    , spaceConsumer+    , spread+    , string+    , symbol+    , unicodeBOM+    ) where++import Control.Applicative ( Alternative(..)+                           , liftA2+                           )+import Data.Char ( chr+                 , digitToInt+                 , isAsciiLower+                 , isAsciiUpper+                 , ord+                 )+import Data.Foldable (foldl')+import Data.List (dropWhileEnd)+import Data.Proxy (Proxy(..))+import Data.Void (Void)+import Text.Megaparsec ( Parsec+                       , between+                       , chunk+                       , chunkToTokens+                       , notFollowedBy+                       , oneOf+                       , option+                       , optional+                       , satisfy+                       , sepBy+                       , skipSome+                       , takeP+                       , takeWhile1P+                       , try+                       )+import Text.Megaparsec.Char ( char+                            , digitChar+                            , space1+                            )+import qualified Text.Megaparsec.Char.Lexer as Lexer+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++-- | Standard parser.+-- Accepts the type of the parsed token.+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++-- | Parser for comments.+comment :: Parser ()+comment = Lexer.skipLineComment "#"++-- | Lexeme definition which ignores whitespaces and commas.+lexeme :: forall a. Parser a -> Parser a+lexeme = Lexer.lexeme spaceConsumer++-- | Symbol definition which ignores whitespaces and commas.+symbol :: T.Text -> Parser T.Text+symbol = Lexer.symbol spaceConsumer++-- | Parser for "!".+bang :: Parser T.Text+bang = symbol "!"++-- | Parser for "$".+dollar :: Parser T.Text+dollar = symbol "$"++-- | Parser for "@".+at :: Parser Char+at = char '@'++-- | Parser for "&".+amp :: Parser T.Text+amp = symbol "&"++-- | Parser for ":".+colon :: Parser T.Text+colon = symbol ":"++-- | Parser for "=".+equals :: Parser T.Text+equals = symbol "="++-- | Parser for the spread operator (...).+spread :: Parser T.Text+spread = symbol "..."++-- | Parser for "|".+pipe :: Parser T.Text+pipe = symbol "|"++-- | Parser for an expression between "(" and ")".+parens :: forall a. Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++-- | Parser for an expression between "[" and "]".+brackets :: forall a. Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++-- | Parser for an expression between "{" and "}".+braces :: forall a. Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++-- | Parser for strings.+string :: Parser T.Text+string = between "\"" "\"" stringValue+  where+    stringValue = T.pack <$> many stringCharacter+    stringCharacter = satisfy isStringCharacter1+        <|> escapeSequence+    isStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter++-- | Parser for block strings.+blockString :: Parser T.Text+blockString = between "\"\"\"" "\"\"\"" stringValue+  where+    stringValue = do+        byLine <- sepBy (many blockStringCharacter) lineTerminator+        let indentSize = foldr countIndent 0 $ tail byLine+            withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)+            withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent++        return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines+    removeEmptyLine [] = True+    removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)+    removeEmptyLine _ = False+    blockStringCharacter+        = takeWhile1P Nothing isWhiteSpace+        <|> takeWhile1P Nothing isBlockStringCharacter1+        <|> escapeTripleQuote+        <|> try (chunk "\"" <* notFollowedBy (chunk "\"\""))+    escapeTripleQuote = chunk "\\" >>= flip option (chunk "\"\"")+    isBlockStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter+    countIndent [] acc = acc+    countIndent (x:_) acc+        | T.null x = acc+        | not (isWhiteSpace $ T.head x) = acc+        | acc == 0 = T.length x+        | otherwise = min acc $ T.length x+    removeIndent _ [] = []+    removeIndent n (x:chunks) = T.drop n x : chunks++-- | Parser for integers.+integer :: Integral a => Parser a+integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal++-- | Parser for floating-point numbers.+float :: Parser Double+float = Lexer.signed (pure ()) $ lexeme Lexer.float++-- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/).+name :: Parser T.Text+name = do+    firstLetter <- nameFirstLetter+    rest <- many $ nameFirstLetter <|> digitChar+    _ <- spaceConsumer+    return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest+      where+        nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'++isChunkDelimiter :: Char -> Bool+isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']++isWhiteSpace :: Char -> Bool+isWhiteSpace = liftA2 (||) (== ' ') (== '\t')++lineTerminator :: Parser T.Text+lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"++isSourceCharacter :: Char -> Bool+isSourceCharacter = isSourceCharacter' . ord+  where+    isSourceCharacter' code = code >= 0x0020+                           || code == 0x0009+                           || code == 0x000a+                           || code == 0x000d++escapeSequence :: Parser Char+escapeSequence = do+    _ <- char '\\'+    escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']+    case escaped of+        'b' -> return '\b'+        'f' -> return '\f'+        'n' -> return '\n'+        'r' -> return '\r'+        't' -> return '\t'+        'u' -> chr . foldl' step 0+                   . chunkToTokens (Proxy :: Proxy T.Text)+                 <$> takeP Nothing 4+        _ -> return escaped+  where+    step accumulator = (accumulator * 16 +) . digitToInt++-- | Parser for the "Byte Order Mark".+unicodeBOM :: Parser ()+unicodeBOM = optional (char '\xfeff') >> pure ()

@@ -0,0 +1,188 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | @GraphQL@ document parser.+module Language.GraphQL.AST.Parser+    ( document+    ) where++import Control.Applicative ( Alternative(..)+                           , optional+                           )+import Data.List.NonEmpty (NonEmpty(..))+import Language.GraphQL.AST+import Language.GraphQL.AST.Lexer+import Text.Megaparsec ( lookAhead+                       , option+                       , try+                       , (<?>)+                       )++-- | Parser for the GraphQL documents.+document :: Parser Document+document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)++definition :: Parser Definition+definition = DefinitionOperation <$> operationDefinition+         <|> DefinitionFragment  <$> fragmentDefinition+         <?> "definition error!"++operationDefinition :: Parser OperationDefinition+operationDefinition = OperationSelectionSet <$> selectionSet+                  <|> OperationDefinition   <$> operationType+                                            <*> optional name+                                            <*> opt variableDefinitions+                                            <*> opt directives+                                            <*> selectionSet+                  <?> "operationDefinition error"++operationType :: Parser OperationType+operationType = Query <$ symbol "query"+    <|> Mutation <$ symbol "mutation"+    <?> "operationType error"++-- * SelectionSet++selectionSet :: Parser SelectionSet+selectionSet = braces $ manyNE selection++selectionSetOpt :: Parser SelectionSetOpt+selectionSetOpt = braces $ some selection++selection :: Parser Selection+selection = SelectionField          <$> field+        <|> try (SelectionFragmentSpread <$> fragmentSpread)+        <|> SelectionInlineFragment <$> inlineFragment+        <?> "selection error!"++-- * Field++field :: Parser Field+field = Field <$> optional alias+              <*> name+              <*> opt arguments+              <*> opt directives+              <*> opt selectionSetOpt++alias :: Parser Alias+alias = try $ name <* colon++-- * Arguments++arguments :: Parser [Argument]+arguments = parens $ some argument++argument :: Parser Argument+argument = Argument <$> name <* colon <*> value++-- * Fragments++fragmentSpread :: Parser FragmentSpread+fragmentSpread = FragmentSpread <$  spread+                                <*> fragmentName+                                <*> opt directives++inlineFragment :: Parser InlineFragment+inlineFragment = InlineFragment <$  spread+                                <*> optional typeCondition+                                <*> opt directives+                                <*> selectionSet++fragmentDefinition :: Parser FragmentDefinition+fragmentDefinition = FragmentDefinition+                 <$  symbol "fragment"+                 <*> name+                 <*> typeCondition+                 <*> opt directives+                 <*> selectionSet++fragmentName :: Parser Name+fragmentName = but (symbol "on") *> name++typeCondition :: Parser TypeCondition+typeCondition = symbol "on" *> name++-- * Input Values++value :: Parser Value+value = Variable <$> variable+    <|> Float    <$> try float+    <|> Int      <$> integer+    <|> Boolean  <$> booleanValue+    <|> Null     <$  symbol "null"+    <|> String   <$> blockString+    <|> String   <$> string+    <|> Enum     <$> try enumValue+    <|> List     <$> listValue+    <|> Object   <$> objectValue+    <?> "value error!"+  where+    booleanValue :: Parser Bool+    booleanValue = True  <$ symbol "true"+               <|> False <$ symbol "false"++    enumValue :: Parser Name+    enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name++    listValue :: Parser [Value]+    listValue = brackets $ some value++    objectValue :: Parser [ObjectField]+    objectValue = braces $ some objectField++objectField :: Parser ObjectField+objectField = ObjectField <$> name <* symbol ":" <*> value++-- * Variables++variableDefinitions :: Parser [VariableDefinition]+variableDefinitions = parens $ some variableDefinition++variableDefinition :: Parser VariableDefinition+variableDefinition = VariableDefinition <$> variable+                                        <*  colon+                                        <*> type_+                                        <*> optional defaultValue+variable :: Parser Name+variable = dollar *> name++defaultValue :: Parser Value+defaultValue = equals *> value++-- * Input Types++type_ :: Parser Type+type_ = try (TypeNonNull <$> nonNullType)+    <|> TypeList <$> brackets type_+    <|> TypeNamed <$> name+    <?> "type_ error!"++nonNullType :: Parser NonNullType+nonNullType = NonNullTypeNamed <$> name <* bang+          <|> NonNullTypeList  <$> brackets type_  <* bang+          <?> "nonNullType error!"++-- * Directives++directives :: Parser [Directive]+directives = some directive++directive :: Parser Directive+directive = Directive+        <$  at+        <*> name+        <*> opt arguments++-- * Internal++opt :: Monoid a => Parser a -> Parser a+opt = option mempty++-- Hack to reverse parser success+but :: Parser a -> Parser ()+but pn = False <$ lookAhead pn <|> pure True >>= \case+    False -> empty+    True  -> pure ()++manyNE :: Alternative f => f a -> f (NonEmpty a)+manyNE p = (:|) <$> p <*> many p

@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ExplicitForAll #-}  -- | After the document is parsed, before getting executed the AST is --   transformed into a similar, simpler AST. This module is responsible for@@ -7,130 +8,143 @@     ( document     ) where -import Control.Applicative (empty)-import Data.Bifunctor (first)-import Data.Either (partitionEithers)-import Data.Foldable (fold, foldMap)-import Data.List.NonEmpty (NonEmpty)+import Control.Arrow (first)+import Control.Monad (foldM, unless)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import qualified Data.List.NonEmpty as NonEmpty-import Data.Monoid (Alt(Alt,getAlt), (<>))+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 --- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't---   match an empty list is returned.-type Fragmenter = Core.Name -> [Core.Field]+-- | Associates a fragment name with a list of 'Core.Field's.+data Replacement = Replacement+    { fragments :: HashMap Core.Name (Seq Core.Selection)+    , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition+    } +type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a+ -- | 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+document subs document' =+    flip runReaderT subs+        $ evalStateT (collectFragments >> operations operationDefinitions)+        $ Replacement HashMap.empty fragmentTable   where-    (fr, ops) = first foldFrags-              . partitionEithers-              . NonEmpty.toList-              $ defrag subs-            <$> doc--    foldFrags :: [Fragmenter] -> Fragmenter-    foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs+    (fragmentTable, operationDefinitions) = foldr defragment mempty document'+    defragment (Full.DefinitionOperation definition) acc =+        (definition :) <$> acc+    defragment (Full.DefinitionFragment definition) acc =+        let (Full.FragmentDefinition name _ _ _) = definition+         in first (HashMap.insert name definition) acc  -- * Operation  -- TODO: Replace Maybe by MonadThrow CustomError-operations-  :: Schema.Subs-  -> Fragmenter-  -> [Full.OperationDefinition]-  -> Maybe Core.Document-operations subs fr = NonEmpty.nonEmpty . fmap (operation subs fr)+operations :: [Full.OperationDefinition] -> TransformT Core.Document+operations operations' = do+    coreOperations <- traverse operation operations'+    lift . lift $ NonEmpty.nonEmpty coreOperations -operation-  :: Schema.Subs-  -> Fragmenter-  -> Full.OperationDefinition-  -> Core.Operation-operation subs fr (Full.OperationSelectionSet sels) =-  operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels+operation :: Full.OperationDefinition -> TransformT Core.Operation+operation (Full.OperationSelectionSet sels) =+    operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels -- TODO: Validate Variable definitions with substituter-operation subs fr (Full.OperationDefinition Full.Query name _vars _dirs sels) =-    Core.Query name $ appendSelection subs fr sels-operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =-    Core.Mutation name $ appendSelection subs fr sels+operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =+    Core.Query name <$> appendSelection sels+operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =+    Core.Mutation name <$> appendSelection sels -selection-  :: Schema.Subs-  -> Fragmenter-  -> Full.Selection-  -> Either [Core.Selection] Core.Selection-selection subs fr (Full.SelectionField fld)-    = Right $ Core.SelectionField $ field subs fr fld-selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _))-    = Left $ Core.SelectionField <$> fr name-selection subs fr  (Full.SelectionInlineFragment fragment)+selection ::+    Full.Selection ->+    TransformT (Either (Seq Core.Selection) Core.Selection)+selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld+selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do+    fragments' <- gets fragments+    Left <$> maybe lookupDefinition liftJust (HashMap.lookup name fragments')+  where+    lookupDefinition :: TransformT (Seq Core.Selection)+    lookupDefinition = do+        fragmentDefinitions' <- gets fragmentDefinitions+        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'+        fragmentDefinition found+selection (Full.SelectionInlineFragment fragment)     | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment         = Right-        $ Core.SelectionFragment-        $ Core.Fragment typeCondition-        $ appendSelection subs fr selectionSet+        . Core.SelectionFragment+        . Core.Fragment typeCondition+        <$> appendSelection selectionSet     | (Full.InlineFragment Nothing _ selectionSet) <- fragment-        = Left $ NonEmpty.toList $ appendSelection subs fr selectionSet+        = Left <$> appendSelection selectionSet  -- * Fragment replacement --- | Extract Fragments into a single Fragmenter function and a Operation---   Definition.-defrag-  :: Schema.Subs-  -> Full.Definition-  -> Either Fragmenter Full.OperationDefinition-defrag _    (Full.DefinitionOperation op) =-  Right op-defrag subs (Full.DefinitionFragment fragDef) =-  Left $ fragmentDefinition subs fragDef+-- | Extract fragment definitions into a single 'HashMap'.+collectFragments :: TransformT ()+collectFragments = do+    fragDefs <- gets fragmentDefinitions+    let nextValue = head $ HashMap.elems fragDefs+    unless (HashMap.null fragDefs) $ do+        _ <- fragmentDefinition nextValue+        collectFragments -fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter-fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name'-    | name == name' = selection' <$> do-        selections <- NonEmpty.toList $ selection subs mempty <$> sels-        either id pure selections-    | otherwise = empty+fragmentDefinition ::+    Full.FragmentDefinition ->+    TransformT (Seq Core.Selection)+fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do+    modify deleteFragmentDefinition+    newValue <- appendSelection selections+    modify $ insertFragment newValue+    liftJust newValue   where-    selection' (Core.SelectionField field') = field'-    selection' _ = error "Fragments within fragments are not supported yet"+    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =+        Replacement fragments' $ HashMap.delete name fragmentDefinitions'+    insertFragment newValue (Replacement fragments' fragmentDefinitions') =+        let newFragments = HashMap.insert name newValue fragments'+         in Replacement newFragments fragmentDefinitions' -field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field-field subs fr (Full.Field a n args _dirs sels) =-    Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)-  where-    go :: Full.Selection -> [Core.Selection] -> [Core.Selection]-    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> fr name) <>)-    go sel = (either id pure (selection subs fr sel) <>)+field :: Full.Field -> TransformT Core.Field+field (Full.Field a n args _dirs sels) = do+    arguments <- traverse argument args+    selection' <- appendSelection sels+    return $ Core.Field a n arguments selection' -argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument-argument subs (Full.Argument n v) = Core.Argument n <$> value subs v+argument :: Full.Argument -> TransformT Core.Argument+argument (Full.Argument n v) = Core.Argument n <$> value v -value :: Schema.Subs -> Full.Value -> Maybe Core.Value-value subs (Full.ValueVariable n) = subs n-value _    (Full.ValueInt      i) = pure $ Core.ValueInt i-value _    (Full.ValueFloat    f) = pure $ Core.ValueFloat f-value _    (Full.ValueString   x) = pure $ Core.ValueString x-value _    (Full.ValueBoolean  b) = pure $ Core.ValueBoolean b-value _     Full.ValueNull        = pure   Core.ValueNull-value _    (Full.ValueEnum     e) = pure $ Core.ValueEnum e-value subs (Full.ValueList     l) =-  Core.ValueList   <$> traverse (value subs) l-value subs (Full.ValueObject   o) =-  Core.ValueObject <$> traverse (objectField subs) o+value :: Full.Value -> TransformT Core.Value+value (Full.Variable n) = do+    substitute' <- lift ask+    lift . lift $ substitute' n+value (Full.Int i) = pure $ Core.Int i+value (Full.Float f) = pure $ Core.Float f+value (Full.String x) = pure $ Core.String x+value (Full.Boolean b) = pure $ Core.Boolean b+value Full.Null = pure   Core.Null+value (Full.Enum e) = pure $ Core.Enum e+value (Full.List l) =+    Core.List <$> traverse value l+value (Full.Object o) =+    Core.Object . HashMap.fromList <$> traverse objectField o -objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField-objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v+objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)+objectField (Full.ObjectField n v) = (n,) <$> value v  appendSelection ::-    Schema.Subs ->-    Fragmenter ->-    NonEmpty Full.Selection ->-    NonEmpty Core.Selection-appendSelection subs fr = NonEmpty.fromList-    . foldr (either (++) (:) . selection subs fr) []+    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

@@ -1,277 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ExplicitForAll #-}---- | This module defines a minifier and a printer for the @GraphQL@ language.-module Language.GraphQL.Encoder-    ( Formatter-    , 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.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---- | 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---- | Constructs a formatter for pretty printing.-pretty :: Formatter-pretty = Pretty 0---- | Constructs a formatter for minifying.-minified :: Formatter-minified = Minified---- | Converts a 'Document' into a string.-document :: Formatter -> Document -> Text-document formatter defs-    | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument-    | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n'-  where-    encodeDocument = NonEmpty.toList $ definition formatter <$> defs---- | Converts a 'Definition' into a string.-definition :: Formatter -> Definition -> Text-definition formatter x-    | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n'-    | Minified <- formatter = encodeDefinition x-  where-    encodeDefinition (DefinitionOperation operation)-        = operationDefinition formatter operation-    encodeDefinition (DefinitionFragment fragment)-        = fragmentDefinition formatter fragment--operationDefinition :: Formatter -> OperationDefinition -> Text-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--node :: Formatter-    -> Maybe Name-    -> [VariableDefinition]-    -> [Directive]-    -> 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--variableDefinitions :: Formatter -> [VariableDefinition] -> Text-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 = "$" <> Text.Lazy.fromStrict var--selectionSet :: Formatter -> SelectionSet -> Text-selectionSet formatter-    = bracesList formatter (selection formatter)-    . NonEmpty.toList--selectionSetOpt :: Formatter -> SelectionSetOpt -> Text-selectionSetOpt formatter = bracesList formatter $ selection formatter--selection :: Formatter -> Selection -> Text-selection formatter = Text.Lazy.append indent . f-  where-    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 :: Formatter -> Field -> Text-field formatter (Field alias name args dirs selso)-    = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias)-    <> Text.Lazy.fromStrict name-    <> optempty (arguments formatter) args-    <> optempty (directives formatter) dirs-    <> selectionSetOpt'-  where-    colon = eitherFormat formatter ": " ":"-    selectionSetOpt'-        | null selso = mempty-        | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso--arguments :: Formatter -> [Argument] -> Text-arguments formatter = parensCommas formatter $ argument formatter--argument :: Formatter -> Argument -> Text-argument formatter (Argument name v)-    = Text.Lazy.fromStrict name-    <> eitherFormat formatter ": " ":"-    <> value formatter v---- * Fragments--fragmentSpread :: Formatter -> FragmentSpread -> Text-fragmentSpread formatter (FragmentSpread name ds)-    = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds--inlineFragment :: Formatter -> InlineFragment -> Text-inlineFragment formatter (InlineFragment tc dirs sels)-    = "... on "-    <> Text.Lazy.fromStrict (fold tc)-    <> directives formatter dirs-    <> eitherFormat formatter " " mempty-    <> selectionSet formatter sels--fragmentDefinition :: Formatter -> FragmentDefinition -> Text-fragmentDefinition formatter (FragmentDefinition name tc dirs sels)-    = "fragment " <> Text.Lazy.fromStrict name-    <> " on " <> Text.Lazy.fromStrict tc-    <> optempty (directives formatter) dirs-    <> eitherFormat formatter " " mempty-    <> selectionSet formatter sels---- * Miscellaneous---- | Converts a 'Directive' into a string.-directive :: Formatter -> Directive -> Text-directive formatter (Directive name args)-    = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args--directives :: Formatter -> [Directive] -> Text-directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)-directives Minified = spaces (directive Minified)---- | Converts a 'Value' into a string.-value :: Formatter -> Value -> Text-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"--stringValue :: Text -> Text-stringValue-    = quotes-    . Text.Lazy.replace "\"" "\\\""-    . Text.Lazy.replace "\\" "\\\\"--listValue :: Formatter -> [Value] -> Text-listValue formatter = bracketsCommas formatter $ value formatter--objectValue :: Formatter -> [ObjectField] -> Text-objectValue formatter = intercalate $ objectField formatter-  where-    intercalate f-        = braces-        . Text.Lazy.intercalate (eitherFormat formatter ", " ",")-        . fmap f---objectField :: Formatter -> ObjectField -> Text-objectField formatter (ObjectField name v)-    = Text.Lazy.fromStrict name <> colon <> value formatter v-  where-    colon-      | Pretty _ <- formatter = ": "-      | Minified <- formatter = ":"---- | Converts a 'Type' a type into a string.-type' :: Type -> Text-type' (TypeNamed   x) = Text.Lazy.fromStrict x-type' (TypeList    x) = listType x-type' (TypeNonNull x) = nonNullType x--listType :: Type -> Text-listType x = brackets (type' x)--nonNullType :: NonNullType -> Text-nonNullType (NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"-nonNullType (NonNullTypeList  x) = listType x <> "!"---- * Internal--between :: Char -> Char -> Text -> Text-between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close)--parens :: Text -> Text-parens = between '(' ')'--brackets :: Text -> Text-brackets = between '[' ']'--braces :: Text -> Text-braces = between '{' '}'--quotes :: Text -> Text-quotes = between '"' '"'--spaces :: forall a. (a -> Text) -> [a] -> 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 ", " ",")-    . fmap f--bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text-bracketsCommas formatter f-    = brackets-    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")-    . fmap f--bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text-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

@@ -8,6 +8,7 @@  import Control.Monad.IO.Class (MonadIO) import qualified Data.Aeson as Aeson+import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE import Data.Text (Text)@@ -71,6 +72,6 @@     -> AST.Core.Operation     -> m Aeson.Value operation schema (AST.Core.Query _ flds)-    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))+    = runCollectErrs (Schema.resolve (toList schema) flds) operation schema (AST.Core.Mutation _ flds)-    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))+    = runCollectErrs (Schema.resolve (toList schema) flds)

@@ -1,228 +0,0 @@-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE OverloadedStrings #-}---- | This module defines a bunch of small parsers used to parse individual---   lexemes.-module Language.GraphQL.Lexer -    ( Parser-    , amp-    , at-    , bang-    , blockString-    , braces-    , brackets-    , colon-    , dollar-    , comment-    , equals-    , integer-    , float-    , lexeme-    , name-    , parens-    , pipe-    , spaceConsumer-    , spread-    , string-    , symbol-    , unicodeBOM-    ) where--import Control.Applicative ( Alternative(..)-                           , liftA2-                           )-import Data.Char ( chr-                 , digitToInt-                 , isAsciiLower-                 , isAsciiUpper-                 , ord-                 )-import Data.Foldable (foldl')-import Data.List (dropWhileEnd)-import Data.Proxy (Proxy(..))-import Data.Void (Void)-import Text.Megaparsec ( Parsec-                       , between-                       , chunk-                       , chunkToTokens-                       , notFollowedBy-                       , oneOf-                       , option-                       , optional-                       , satisfy-                       , sepBy-                       , skipSome-                       , takeP-                       , takeWhile1P-                       , try-                       )-import Text.Megaparsec.Char ( char-                            , digitChar-                            , space1-                            )-import qualified Text.Megaparsec.Char.Lexer as Lexer-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL---- | Standard parser.--- Accepts the type of the parsed token.-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---- | Parser for comments.-comment :: Parser ()-comment = Lexer.skipLineComment "#"---- | Lexeme definition which ignores whitespaces and commas.-lexeme :: forall a. Parser a -> Parser a-lexeme = Lexer.lexeme spaceConsumer---- | Symbol definition which ignores whitespaces and commas.-symbol :: T.Text -> Parser T.Text-symbol = Lexer.symbol spaceConsumer---- | Parser for "!".-bang :: Parser Char-bang = char '!'---- | Parser for "$".-dollar :: Parser Char-dollar = char '$'---- | Parser for "@".-at :: Parser Char-at = char '@'---- | Parser for "&".-amp :: Parser T.Text-amp = symbol "&"---- | Parser for ":".-colon :: Parser T.Text-colon = symbol ":"---- | Parser for "=".-equals :: Parser T.Text-equals = symbol "="---- | Parser for the spread operator (...).-spread :: Parser T.Text-spread = symbol "..."---- | Parser for "|".-pipe :: Parser T.Text-pipe = symbol "|"---- | Parser for an expression between "(" and ")".-parens :: forall a. Parser a -> Parser a-parens = between (symbol "(") (symbol ")")---- | Parser for an expression between "[" and "]".-brackets :: forall a. Parser a -> Parser a-brackets = between (symbol "[") (symbol "]")---- | Parser for an expression between "{" and "}".-braces :: forall a. Parser a -> Parser a-braces = between (symbol "{") (symbol "}")---- | Parser for strings.-string :: Parser T.Text-string = between "\"" "\"" stringValue-  where-    stringValue = T.pack <$> many stringCharacter-    stringCharacter = satisfy isStringCharacter1-        <|> escapeSequence-    isStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter---- | Parser for block strings.-blockString :: Parser T.Text-blockString = between "\"\"\"" "\"\"\"" stringValue-  where-    stringValue = do-        byLine <- sepBy (many blockStringCharacter) lineTerminator-        let indentSize = foldr countIndent 0 $ tail byLine-            withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)-            withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent--        return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines-    removeEmptyLine [] = True-    removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)-    removeEmptyLine _ = False-    blockStringCharacter-        = takeWhile1P Nothing isWhiteSpace-        <|> takeWhile1P Nothing isBlockStringCharacter1-        <|> escapeTripleQuote-        <|> try (chunk "\"" <* notFollowedBy (chunk "\"\""))-    escapeTripleQuote = chunk "\\" >>= flip option (chunk "\"\"")-    isBlockStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter-    countIndent [] acc = acc-    countIndent (x:_) acc-        | T.null x = acc-        | not (isWhiteSpace $ T.head x) = acc-        | acc == 0 = T.length x-        | otherwise = min acc $ T.length x-    removeIndent _ [] = []-    removeIndent n (x:chunks) = T.drop n x : chunks---- | Parser for integers.-integer :: Integral a => Parser a-integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal---- | Parser for floating-point numbers.-float :: Parser Double-float = Lexer.signed (pure ()) $ lexeme Lexer.float---- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/).-name :: Parser T.Text-name = do-    firstLetter <- nameFirstLetter-    rest <- many $ nameFirstLetter <|> digitChar-    _ <- spaceConsumer-    return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest-      where-        nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'--isChunkDelimiter :: Char -> Bool-isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']--isWhiteSpace :: Char -> Bool-isWhiteSpace = liftA2 (||) (== ' ') (== '\t')--lineTerminator :: Parser T.Text-lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"--isSourceCharacter :: Char -> Bool-isSourceCharacter = isSourceCharacter' . ord-  where-    isSourceCharacter' code = code >= 0x0020-                           || code == 0x0009-                           || code == 0x000a-                           || code == 0x000d--escapeSequence :: Parser Char-escapeSequence = do-    _ <- char '\\'-    escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']-    case escaped of-        'b' -> return '\b'-        'f' -> return '\f'-        'n' -> return '\n'-        'r' -> return '\r'-        't' -> return '\t'-        'u' -> chr . foldl' step 0-                   . chunkToTokens (Proxy :: Proxy T.Text)-                 <$> takeP Nothing 4-        _ -> return escaped-  where-    step accumulator = (accumulator * 16 +) . digitToInt---- | Parser for the "Byte Order Mark".-unicodeBOM :: Parser ()-unicodeBOM = optional (char '\xfeff') >> pure ()

@@ -1,188 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}---- | @GraphQL@ document parser.-module Language.GraphQL.Parser-    ( document-    ) where--import Control.Applicative ( Alternative(..)-                           , optional-                           )-import Data.List.NonEmpty (NonEmpty(..))-import Language.GraphQL.AST-import Language.GraphQL.Lexer-import Text.Megaparsec ( lookAhead-                       , option-                       , try-                       , (<?>)-                       )---- | Parser for the GraphQL documents.-document :: Parser Document-document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)--definition :: Parser Definition-definition = DefinitionOperation <$> operationDefinition-         <|> DefinitionFragment  <$> fragmentDefinition-         <?> "definition error!"--operationDefinition :: Parser OperationDefinition-operationDefinition = OperationSelectionSet <$> selectionSet-                  <|> OperationDefinition   <$> operationType-                                            <*> optional name-                                            <*> opt variableDefinitions-                                            <*> opt directives-                                            <*> selectionSet-                  <?> "operationDefinition error"--operationType :: Parser OperationType-operationType = Query <$ symbol "query"-    <|> Mutation <$ symbol "mutation"-    <?> "operationType error"---- * SelectionSet--selectionSet :: Parser SelectionSet-selectionSet = braces $ manyNE selection--selectionSetOpt :: Parser SelectionSetOpt-selectionSetOpt = braces $ some selection--selection :: Parser Selection-selection = SelectionField          <$> field-        <|> try (SelectionFragmentSpread <$> fragmentSpread)-        <|> SelectionInlineFragment <$> inlineFragment-        <?> "selection error!"---- * Field--field :: Parser Field-field = Field <$> optional alias-              <*> name-              <*> opt arguments-              <*> opt directives-              <*> opt selectionSetOpt--alias :: Parser Alias-alias = try $ name <* colon---- * Arguments--arguments :: Parser [Argument]-arguments = parens $ some argument--argument :: Parser Argument-argument = Argument <$> name <* colon <*> value---- * Fragments--fragmentSpread :: Parser FragmentSpread-fragmentSpread = FragmentSpread <$  spread-                                <*> fragmentName-                                <*> opt directives--inlineFragment :: Parser InlineFragment-inlineFragment = InlineFragment <$  spread-                                <*> optional typeCondition-                                <*> opt directives-                                <*> selectionSet--fragmentDefinition :: Parser FragmentDefinition-fragmentDefinition = FragmentDefinition-                 <$  symbol "fragment"-                 <*> name-                 <*> typeCondition-                 <*> opt directives-                 <*> selectionSet--fragmentName :: Parser Name-fragmentName = but (symbol "on") *> name--typeCondition :: Parser TypeCondition-typeCondition = symbol "on" *> name---- * Input Values--value :: Parser Value-value = ValueVariable <$> variable-    <|> ValueFloat    <$> try float-    <|> ValueInt      <$> integer-    <|> ValueBoolean  <$> booleanValue-    <|> ValueNull     <$  symbol "null"-    <|> ValueString   <$> blockString-    <|> ValueString   <$> string-    <|> ValueEnum     <$> try enumValue-    <|> ValueList     <$> listValue-    <|> ValueObject   <$> objectValue-    <?> "value error!"-  where-    booleanValue :: Parser Bool-    booleanValue = True  <$ symbol "true"-               <|> False <$ symbol "false"--    enumValue :: Parser Name-    enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name--    listValue :: Parser [Value]-    listValue = brackets $ some value--    objectValue :: Parser [ObjectField]-    objectValue = braces $ some objectField--objectField :: Parser ObjectField-objectField = ObjectField <$> name <* symbol ":" <*> value---- * Variables--variableDefinitions :: Parser [VariableDefinition]-variableDefinitions = parens $ some variableDefinition--variableDefinition :: Parser VariableDefinition-variableDefinition = VariableDefinition <$> variable-                                        <*  colon-                                        <*> type_-                                        <*> optional defaultValue-variable :: Parser Name-variable = dollar *> name--defaultValue :: Parser Value-defaultValue = equals *> value---- * Input Types--type_ :: Parser Type-type_ = try (TypeNamed <$> name <* but "!")-    <|> TypeList       <$> brackets type_-    <|> TypeNonNull    <$> nonNullType-    <?> "type_ error!"--nonNullType :: Parser NonNullType-nonNullType = NonNullTypeNamed <$> name <* bang-          <|> NonNullTypeList  <$> brackets type_  <* bang-          <?> "nonNullType error!"---- * Directives--directives :: Parser [Directive]-directives = some directive--directive :: Parser Directive-directive = Directive-        <$  at-        <*> name-        <*> opt arguments---- * Internal--opt :: Monoid a => Parser a -> Parser a-opt = option mempty---- Hack to reverse parser success-but :: Parser a -> Parser ()-but pn = False <$ lookAhead pn <|> pure True >>= \case-    False -> empty-    True  -> pure ()--manyNE :: Alternative f => f a -> f (NonEmpty a)-manyNE p = (:|) <$> p <*> many p

@@ -4,17 +4,12 @@ -- functions for defining and manipulating schemas. module Language.GraphQL.Schema     ( Resolver-    , Schema     , Subs     , object     , objectA     , scalar     , scalarA-    , enum-    , enumA     , resolve-    , wrappedEnum-    , wrappedEnumA     , wrappedObject     , wrappedObjectA     , wrappedScalar@@ -28,23 +23,19 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT)+import Control.Monad.Trans.Reader (runReaderT) import Data.Foldable (find, fold)-import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromMaybe) import qualified Data.Aeson as Aeson import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.Sequence (Seq) import Data.Text (Text) import qualified Data.Text as T+import Language.GraphQL.AST.Core import Language.GraphQL.Error 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)+import qualified Language.GraphQL.Type as Type  -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error --   information (if an error has occurred). @m@ is usually expected to be an@@ -69,7 +60,7 @@  -- | Like 'object' but also taking 'Argument's and can be null or a list of objects. wrappedObjectA :: MonadIO m-    => Name -> ([Argument] -> ActionT m (Wrapping [Resolver m])) -> Resolver m+    => Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight   where     resolveRight fld@(Field _ _ _ sels) resolver@@ -77,7 +68,7 @@  -- | Like 'object' but can be null or a list of objects. wrappedObject :: MonadIO m-    => Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m+    => Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m wrappedObject name = wrappedObjectA name . const  -- | A scalar represents a primitive value, like a string or an integer.@@ -91,54 +82,31 @@   where     resolveRight fld result = withField (return result) fld --- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.+-- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars. wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)-    => Name -> ([Argument] -> ActionT m (Wrapping a)) -> Resolver m+    => Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight   where-    resolveRight fld (Named result) = withField (return result) fld-    resolveRight fld Null+    resolveRight fld (Type.Named result) = withField (return result) fld+    resolveRight fld Type.Null         = return $ HashMap.singleton (aliasOrName fld) Aeson.Null-    resolveRight fld (List result) = withField (return result) fld+    resolveRight fld (Type.List result) = withField (return result) fld  -- | Like 'scalar' but can be null or a list of scalars. wrappedScalar :: (MonadIO m, Aeson.ToJSON a)-    => Name -> ActionT m (Wrapping a) -> Resolver m+    => Name -> ActionT m (Type.Wrapping a) -> Resolver m wrappedScalar name = wrappedScalarA name . const -{-# DEPRECATED enum "Use scalar instead" #-}-enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m-enum name = enumA name . const--{-# DEPRECATED enumA "Use scalarA instead" #-}-enumA :: MonadIO m => Name -> ([Argument] -> ActionT m [Text]) -> Resolver m-enumA name f = Resolver name $ resolveFieldValue f resolveRight-  where-    resolveRight fld resolver = withField (return resolver) fld--{-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-}-wrappedEnumA :: MonadIO m-    => Name -> ([Argument] -> ActionT m (Wrapping [Text])) -> Resolver m-wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight-  where-    resolveRight fld (Named resolver) = withField (return resolver) fld-    resolveRight fld Null-        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null-    resolveRight fld (List resolver) = withField (return resolver) fld--{-# DEPRECATED wrappedEnum "Use wrappedScalar instead" #-}-wrappedEnum :: MonadIO m => Name -> ActionT m (Wrapping [Text]) -> Resolver m-wrappedEnum name = wrappedEnumA name . const- resolveFieldValue :: MonadIO m     => ([Argument] -> ActionT m a)     -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))     -> Field     -> CollectErrsT m (HashMap Text Aeson.Value) resolveFieldValue f resolveRight fld@(Field _ _ args _) = do-    result <- lift $ runExceptT . runActionT $ f args+    result <- lift $ reader . runExceptT . runActionT $ f args     either resolveLeft (resolveRight fld) result       where+        reader = flip runReaderT $ Context mempty         resolveLeft err = do             _ <- addErrMsg err             return $ HashMap.singleton (aliasOrName fld) Aeson.Null@@ -153,7 +121,7 @@ --   'Resolver' to each 'Field'. Resolves into a value containing the --   resolved 'Field', or a null value and error information. resolve :: MonadIO m-    => [Resolver m] -> [Selection] -> CollectErrsT m Aeson.Value+    => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers   where     resolveTypeName (Resolver "__typename" f) = do

@@ -1,6 +1,7 @@ -- | Monad transformer stack used by the @GraphQL@ resolvers. module Language.GraphQL.Trans     ( ActionT(..)+    , Context(Context)     ) where  import Control.Applicative (Alternative(..))@@ -8,11 +9,20 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Reader (ReaderT)+import Data.HashMap.Strict (HashMap) import Data.Text (Text)+import Language.GraphQL.AST.Core (Name, Value) --- | Monad transformer stack used by the resolvers to provide error handling.-newtype ActionT m a = ActionT { runActionT :: ExceptT Text m a }+-- | Resolution context holds resolver arguments.+newtype Context = Context (HashMap Name Value) +-- | Monad transformer stack used by the resolvers to provide error handling+--   and resolution context (resolver arguments).+newtype ActionT m a = ActionT+    { runActionT :: ExceptT Text (ReaderT Context m) a+    }+ instance Functor m => Functor (ActionT m) where     fmap f = ActionT . fmap f . runActionT @@ -25,7 +35,7 @@     (ActionT action) >>= f = ActionT $ action >>= runActionT . f  instance MonadTrans ActionT where-    lift = ActionT . lift+    lift = ActionT . lift . lift  instance MonadIO m => MonadIO (ActionT m) where     liftIO = lift . liftIO

@@ -1,11 +1,9 @@--- | Definitions for @GraphQL@ type system.+-- | Definitions for @GraphQL@ input types. module Language.GraphQL.Type     ( Wrapping(..)     ) where -import Data.Aeson as Aeson ( ToJSON-                           , toJSON-                           )+import Data.Aeson as Aeson (ToJSON, toJSON) import qualified Data.Aeson as Aeson  -- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping

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

@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Language.GraphQL.AST.LexerSpec+    ( spec+    ) where++import Data.Text (Text)+import Data.Void (Void)+import Language.GraphQL.AST.Lexer+import Test.Hspec (Spec, context, describe, it)+import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)+import Text.Megaparsec (ParseErrorBundle, parse)+import Text.RawString.QQ (r)++spec :: Spec+spec = describe "Lexer" $ do+    context "Reference tests" $ do+        it "accepts BOM header" $+            parse unicodeBOM "" `shouldSucceedOn` "\xfeff"++        it "lexes strings" $ do+            parse string "" [r|"simple"|] `shouldParse` "simple"+            parse string "" [r|" white space "|] `shouldParse` " white space "+            parse string "" [r|"quote \""|] `shouldParse` [r|quote "|]+            parse string "" [r|"escaped \n"|] `shouldParse` "escaped \n"+            parse string "" [r|"slashes \\ \/"|] `shouldParse` [r|slashes \ /|]+            parse string "" [r|"unicode \u1234\u5678\u90AB\uCDEF"|]+                `shouldParse` "unicode ሴ噸邫췯"++        it "lexes block string" $ do+            parse blockString "" [r|"""simple"""|] `shouldParse` "simple"+            parse blockString "" [r|""" white space """|]+                `shouldParse` " white space "+            parse blockString "" [r|"""contains " quote"""|]+                `shouldParse` [r|contains " quote|]+            parse blockString "" [r|"""contains \""" triplequote"""|]+                `shouldParse` [r|contains """ triplequote|]+            parse blockString "" "\"\"\"multi\nline\"\"\"" `shouldParse` "multi\nline"+            parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""+                `shouldParse` "multi\nline\nnormalized"+            parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""+                `shouldParse` "multi\nline\nnormalized"+            parse blockString "" [r|"""unescaped \n\r\b\t\f\u1234"""|]+                `shouldParse` [r|unescaped \n\r\b\t\f\u1234|]+            parse blockString "" [r|"""slashes \\ \/"""|]+                `shouldParse` [r|slashes \\ \/|]+            parse blockString "" [r|"""++                spans+                  multiple+                    lines++                """|] `shouldParse` "spans\n  multiple\n    lines"++        it "lexes numbers" $ do+            parse integer "" "4" `shouldParse` (4 :: Int)+            parse float "" "4.123" `shouldParse` 4.123+            parse integer "" "-4" `shouldParse` (-4 :: Int)+            parse integer "" "9" `shouldParse` (9 :: Int)+            parse integer "" "0" `shouldParse` (0 :: Int)+            parse float "" "-4.123" `shouldParse` (-4.123)+            parse float "" "0.123" `shouldParse` 0.123+            parse float "" "123e4" `shouldParse` 123e4+            parse float "" "123E4" `shouldParse` 123E4+            parse float "" "123e-4" `shouldParse` 123e-4+            parse float "" "123e+4" `shouldParse` 123e+4+            parse float "" "-1.123e4" `shouldParse` (-1.123e4)+            parse float "" "-1.123E4" `shouldParse` (-1.123E4)+            parse float "" "-1.123e-4" `shouldParse` (-1.123e-4)+            parse float "" "-1.123e+4" `shouldParse` (-1.123e+4)+            parse float "" "-1.123e4567" `shouldParse` (-1.123e4567)++        it "lexes punctuation" $ do+            parse bang "" "!" `shouldParse` "!"+            parse dollar "" "$" `shouldParse` "$"+            runBetween parens `shouldSucceedOn` "()"+            parse spread "" "..." `shouldParse` "..."+            parse colon "" ":" `shouldParse` ":"+            parse equals "" "=" `shouldParse` "="+            parse at "" "@" `shouldParse` '@'+            runBetween brackets `shouldSucceedOn` "[]"+            runBetween braces `shouldSucceedOn` "{}"+            parse pipe "" "|" `shouldParse` "|"++    context "Implementation tests" $ do+        it "lexes empty block strings" $+            parse blockString "" [r|""""""|] `shouldParse` ""+        it "lexes ampersand" $+            parse amp "" "&" `shouldParse` "&"++runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()+runBetween parser = parse (parser $ pure ()) ""

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Language.GraphQL.AST.ParserSpec+    ( spec+    ) where++import Language.GraphQL.AST.Parser+import Test.Hspec (Spec, describe, it)+import Test.Hspec.Megaparsec (shouldSucceedOn)+import Text.Megaparsec (parse)+import Text.RawString.QQ (r)++spec :: Spec+spec = describe "Parser" $ do+    it "accepts BOM header" $+        parse document "" `shouldSucceedOn` "\xfeff{foo}"++    it "accepts block strings as argument" $+        parse document "" `shouldSucceedOn` [r|{+              hello(text: """Argument""")+            }|]++    it "accepts strings as argument" $+        parse document "" `shouldSucceedOn` [r|{+              hello(text: "Argument")+            }|]++    it "accepts two required arguments" $+        parse document "" `shouldSucceedOn` [r|+            mutation auth($username: String!, $password: String!){+                test+            }|]

@@ -1,21 +0,0 @@-{-# 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` "\"\\\"\""

@@ -1,92 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-module Language.GraphQL.LexerSpec-    ( spec-    ) where--import Data.Text (Text)-import Data.Void (Void)-import Language.GraphQL.Lexer-import Test.Hspec (Spec, context, describe, it)-import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)-import Text.Megaparsec (ParseErrorBundle, parse)-import Text.RawString.QQ (r)--spec :: Spec-spec = describe "Lexer" $ do-    context "Reference tests" $ do-        it "accepts BOM header" $-            parse unicodeBOM "" `shouldSucceedOn` "\xfeff"--        it "lexes strings" $ do-            parse string "" [r|"simple"|] `shouldParse` "simple"-            parse string "" [r|" white space "|] `shouldParse` " white space "-            parse string "" [r|"quote \""|] `shouldParse` [r|quote "|]-            parse string "" [r|"escaped \n"|] `shouldParse` "escaped \n"-            parse string "" [r|"slashes \\ \/"|] `shouldParse` [r|slashes \ /|]-            parse string "" [r|"unicode \u1234\u5678\u90AB\uCDEF"|]-                `shouldParse` "unicode ሴ噸邫췯"--        it "lexes block string" $ do-            parse blockString "" [r|"""simple"""|] `shouldParse` "simple"-            parse blockString "" [r|""" white space """|]-                `shouldParse` " white space "-            parse blockString "" [r|"""contains " quote"""|]-                `shouldParse` [r|contains " quote|]-            parse blockString "" [r|"""contains \""" triplequote"""|]-                `shouldParse` [r|contains """ triplequote|]-            parse blockString "" "\"\"\"multi\nline\"\"\"" `shouldParse` "multi\nline"-            parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""-                `shouldParse` "multi\nline\nnormalized"-            parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""-                `shouldParse` "multi\nline\nnormalized"-            parse blockString "" [r|"""unescaped \n\r\b\t\f\u1234"""|]-                `shouldParse` [r|unescaped \n\r\b\t\f\u1234|]-            parse blockString "" [r|"""slashes \\ \/"""|]-                `shouldParse` [r|slashes \\ \/|]-            parse blockString "" [r|"""--                spans-                  multiple-                    lines--                """|] `shouldParse` "spans\n  multiple\n    lines"--        it "lexes numbers" $ do-            parse integer "" "4" `shouldParse` (4 :: Int)-            parse float "" "4.123" `shouldParse` 4.123-            parse integer "" "-4" `shouldParse` (-4 :: Int)-            parse integer "" "9" `shouldParse` (9 :: Int)-            parse integer "" "0" `shouldParse` (0 :: Int)-            parse float "" "-4.123" `shouldParse` (-4.123)-            parse float "" "0.123" `shouldParse` 0.123-            parse float "" "123e4" `shouldParse` 123e4-            parse float "" "123E4" `shouldParse` 123E4-            parse float "" "123e-4" `shouldParse` 123e-4-            parse float "" "123e+4" `shouldParse` 123e+4-            parse float "" "-1.123e4" `shouldParse` (-1.123e4)-            parse float "" "-1.123E4" `shouldParse` (-1.123E4)-            parse float "" "-1.123e-4" `shouldParse` (-1.123e-4)-            parse float "" "-1.123e+4" `shouldParse` (-1.123e+4)-            parse float "" "-1.123e4567" `shouldParse` (-1.123e4567)--        it "lexes punctuation" $ do-            parse bang "" "!" `shouldParse` '!'-            parse dollar "" "$" `shouldParse` '$'-            runBetween parens `shouldSucceedOn` "()"-            parse spread "" "..." `shouldParse` "..."-            parse colon "" ":" `shouldParse` ":"-            parse equals "" "=" `shouldParse` "="-            parse at "" "@" `shouldParse` '@'-            runBetween brackets `shouldSucceedOn` "[]"-            runBetween braces `shouldSucceedOn` "{}"-            parse pipe "" "|" `shouldParse` "|"--    context "Implementation tests" $ do-        it "lexes empty block strings" $-            parse blockString "" [r|""""""|] `shouldParse` ""-        it "lexes ampersand" $-            parse amp "" "&" `shouldParse` "&"--runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()-runBetween parser = parse (parser $ pure ()) ""

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

@@ -10,7 +10,13 @@ import Data.Text (Text) import Language.GraphQL import qualified Language.GraphQL.Schema as Schema-import Test.Hspec (Spec, describe, it, shouldBe, shouldNotSatisfy)+import Test.Hspec ( Spec+                  , describe+                  , it+                  , shouldBe+                  , shouldSatisfy+                  , shouldNotSatisfy+                  ) import Text.RawString.QQ (r)  size :: Schema.Resolver IO@@ -37,6 +43,10 @@   } }|] +hasErrors :: Value -> Bool+hasErrors (Object object') = HashMap.member "errors" object'+hasErrors _ = True+ spec :: Spec spec = describe "Inline fragment executor" $ do     it "chooses the first selection if the type matches" $ do@@ -92,6 +102,63 @@          actual <- graphql (size :| []) query         actual `shouldNotSatisfy` hasErrors-      where-        hasErrors (Object object') = HashMap.member "errors" object'-        hasErrors _ = True++    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

@@ -7,8 +7,8 @@ import qualified Data.Text.IO as Text.IO import qualified Data.Text.Lazy.IO as Text.Lazy.IO import qualified Data.Text.Lazy as Lazy (Text)-import qualified Language.GraphQL.Encoder as Encoder-import qualified Language.GraphQL.Parser as Parser+import qualified Language.GraphQL.AST.Encoder as Encoder+import qualified Language.GraphQL.AST.Parser as Parser import Paths_graphql (getDataFileName) import Test.Hspec (Spec, describe, it) import Test.Hspec.Megaparsec (parseSatisfies)

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

@@ -15,7 +15,7 @@ import Data.Maybe (catMaybes) import qualified Language.GraphQL.Schema as Schema import Language.GraphQL.Trans-import Language.GraphQL.Type+import qualified Language.GraphQL.Type as Type import Test.StarWars.Data  -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js@@ -26,23 +26,23 @@ hero :: MonadIO m => Schema.Resolver m hero = Schema.objectA "hero" $ \case   [] -> character artoo-  [Schema.Argument "episode" (Schema.ValueEnum "NEWHOPE")] -> character $ getHero 4-  [Schema.Argument "episode" (Schema.ValueEnum "EMPIRE" )] -> character $ getHero 5-  [Schema.Argument "episode" (Schema.ValueEnum "JEDI"   )] -> character $ getHero 6+  [Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4+  [Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5+  [Schema.Argument "episode" (Schema.Enum "JEDI"   )] -> character $ getHero 6   _ -> ActionT $ throwE "Invalid arguments."  human :: MonadIO m => Schema.Resolver m human = Schema.wrappedObjectA "human" $ \case-  [Schema.Argument "id" (Schema.ValueString i)] -> do+  [Schema.Argument "id" (Schema.String i)] -> do       humanCharacter <- lift $ return $ getHuman i >>= Just       case humanCharacter of-        Nothing -> return Null-        Just e -> Named <$> character e+        Nothing -> return Type.Null+        Just e -> Type.Named <$> character e   _ -> ActionT $ throwE "Invalid arguments."  droid :: MonadIO m => Schema.Resolver m droid = Schema.objectA "droid" $ \case-   [Schema.Argument "id" (Schema.ValueString i)] -> character =<< liftIO (getDroid i)+   [Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i)    _ -> ActionT $ throwE "Invalid arguments."  character :: MonadIO m => Character -> ActionT m [Schema.Resolver m]@@ -50,8 +50,8 @@     [ Schema.scalar "id" $ return $ id_ char     , Schema.scalar "name" $ return $ name char     , Schema.wrappedObject "friends"-        $ traverse character $ List $ Named <$> getFriends char-    , Schema.wrappedScalar "appearsIn" $ return . List+        $ traverse character $ Type.List $ Type.Named <$> getFriends char+    , Schema.wrappedScalar "appearsIn" $ return . Type.List         $ catMaybes (getEpisode <$> appearsIn char)     , Schema.scalar "secretBackstory" $ secretBackstory char     , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char