diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/graphql.cabal b/graphql.cabal --- a/graphql.cabal +++ b/graphql.cabal @@ -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, diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -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) diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -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) diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -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 () diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/AST/Parser.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs --- a/src/Language/GraphQL/AST/Transform.hs +++ b/src/Language/GraphQL/AST/Transform.hs @@ -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 diff --git a/src/Language/GraphQL/Encoder.hs b/src/Language/GraphQL/Encoder.hs deleted file mode 100644 --- a/src/Language/GraphQL/Encoder.hs +++ /dev/null @@ -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 diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -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) diff --git a/src/Language/GraphQL/Lexer.hs b/src/Language/GraphQL/Lexer.hs deleted file mode 100644 --- a/src/Language/GraphQL/Lexer.hs +++ /dev/null @@ -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 () diff --git a/src/Language/GraphQL/Parser.hs b/src/Language/GraphQL/Parser.hs deleted file mode 100644 --- a/src/Language/GraphQL/Parser.hs +++ /dev/null @@ -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 diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -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 diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -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 diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -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 diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -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` "\"\\\"\"" diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/GraphQL/AST/LexerSpec.hs @@ -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 ()) "" diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -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 + }|] diff --git a/tests/Language/GraphQL/EncoderSpec.hs b/tests/Language/GraphQL/EncoderSpec.hs deleted file mode 100644 --- a/tests/Language/GraphQL/EncoderSpec.hs +++ /dev/null @@ -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` "\"\\\"\"" diff --git a/tests/Language/GraphQL/LexerSpec.hs b/tests/Language/GraphQL/LexerSpec.hs deleted file mode 100644 --- a/tests/Language/GraphQL/LexerSpec.hs +++ /dev/null @@ -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 ()) "" diff --git a/tests/Language/GraphQL/ParserSpec.hs b/tests/Language/GraphQL/ParserSpec.hs deleted file mode 100644 --- a/tests/Language/GraphQL/ParserSpec.hs +++ /dev/null @@ -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") - }|] diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -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 diff --git a/tests/Test/KitchenSinkSpec.hs b/tests/Test/KitchenSinkSpec.hs --- a/tests/Test/KitchenSinkSpec.hs +++ b/tests/Test/KitchenSinkSpec.hs @@ -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) diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -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 diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -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