diff options
Diffstat (limited to 'src/Language')
| -rw-r--r-- | src/Language/GraphQL/AST.hs | 30 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Encoder.hs | 43 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Lexer.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Parser.hs | 59 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 75 |
5 files changed, 99 insertions, 112 deletions
diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index 44bf969..537e870 100644 --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -8,10 +8,8 @@ module Language.GraphQL.AST , Definition(..) , Directive(..) , Document - , Field(..) + , ExecutableDefinition(..) , FragmentDefinition(..) - , FragmentSpread(..) - , InlineFragment(..) , Name , NonNullType(..) , ObjectField(..) @@ -35,6 +33,10 @@ import Data.Text (Text) -- | GraphQL document. type Document = NonEmpty Definition +-- | All kinds of definitions that can occur in a GraphQL document. +newtype Definition = ExecutableDefinition ExecutableDefinition + deriving (Eq, Show) + -- | Name type Name = Text @@ -44,7 +46,7 @@ data Directive = Directive Name [Argument] deriving (Eq, Show) -- * Operations -- | Top-level definition of a document, either an operation or a fragment. -data Definition +data ExecutableDefinition = DefinitionOperation OperationDefinition | DefinitionFragment FragmentDefinition deriving (Eq, Show) @@ -72,13 +74,6 @@ type SelectionSet = NonEmpty Selection -- | Field selection. type SelectionSetOpt = [Selection] --- | Single selection element. -data Selection - = SelectionField Field - | SelectionFragmentSpread FragmentSpread - | SelectionInlineFragment InlineFragment - deriving (Eq, Show) - -- * Field -- | Single GraphQL field. @@ -102,8 +97,10 @@ data Selection -- * "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 +data Selection = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt + | FragmentSpread Name [Directive] + | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet deriving (Eq, Show) -- | Alternative field name. @@ -133,15 +130,6 @@ type Alias = Name -- Here "id" is an argument for the field "user" and its value is 4. data Argument = Argument Name Value deriving (Eq,Show) --- * Fragments - --- | Fragment spread. -data FragmentSpread = FragmentSpread Name [Directive] deriving (Eq, Show) - --- | Inline fragment. -data InlineFragment = InlineFragment (Maybe TypeCondition) [Directive] SelectionSet - deriving (Eq, Show) - -- | Fragment definition. data FragmentDefinition = FragmentDefinition Name TypeCondition [Directive] SelectionSet diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 508212a..b7378dc 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -49,10 +49,11 @@ document formatter defs | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n' where - encodeDocument = NonEmpty.toList $ definition formatter <$> defs + encodeDocument = foldr executableDefinition [] defs + executableDefinition (Full.ExecutableDefinition x) acc = definition formatter x : acc -- | Converts a 'Full.Definition' into a string. -definition :: Formatter -> Full.Definition -> Lazy.Text +definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text definition formatter x | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n' | Minified <- formatter = encodeDefinition x @@ -116,11 +117,12 @@ indent indentation = Lazy.Text.replicate (fromIntegral indentation) " " selection :: Formatter -> Full.Selection -> Lazy.Text selection formatter = Lazy.Text.append indent' . encodeSelection where - encodeSelection (Full.SelectionField field') = field incrementIndent field' - encodeSelection (Full.SelectionInlineFragment fragment) = - inlineFragment incrementIndent fragment - encodeSelection (Full.SelectionFragmentSpread spread) = - fragmentSpread incrementIndent spread + encodeSelection (Full.Field alias name args directives' selections) = + field incrementIndent alias name args directives' selections + encodeSelection (Full.InlineFragment typeCondition directives' selections) = + inlineFragment incrementIndent typeCondition directives' selections + encodeSelection (Full.FragmentSpread name directives') = + fragmentSpread incrementIndent name directives' incrementIndent | Pretty indentation <- formatter = Pretty $ indentation + 1 | otherwise = Minified @@ -131,8 +133,14 @@ selection formatter = Lazy.Text.append indent' . encodeSelection colon :: Formatter -> Lazy.Text colon formatter = eitherFormat formatter ": " ":" -field :: Formatter -> Full.Field -> Lazy.Text -field formatter (Full.Field alias name args dirs set) +field :: Formatter -> + Maybe Full.Name -> + Full.Name -> + [Full.Argument] -> + [Full.Directive] -> + [Full.Selection] -> + Lazy.Text +field formatter alias name args dirs set = optempty prependAlias (fold alias) <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args @@ -154,13 +162,18 @@ argument formatter (Full.Argument name value') -- * Fragments -fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text -fragmentSpread formatter (Full.FragmentSpread name ds) - = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds +fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text +fragmentSpread formatter name directives' + = "..." <> Lazy.Text.fromStrict name + <> optempty (directives formatter) directives' -inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text -inlineFragment formatter (Full.InlineFragment tc dirs sels) - = "... on " +inlineFragment :: + Formatter -> + Maybe Full.TypeCondition -> + [Full.Directive] -> + Full.SelectionSet -> + Lazy.Text +inlineFragment formatter tc dirs sels = "... on " <> Lazy.Text.fromStrict (fold tc) <> directives formatter dirs <> eitherFormat formatter " " mempty diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index f95070c..80370d4 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -134,7 +134,7 @@ braces = between (symbol "{") (symbol "}") -- | Parser for strings. string :: Parser T.Text -string = between "\"" "\"" stringValue <* spaceConsumer +string = between "\"" "\"" stringValue <* spaceConsumer where stringValue = T.pack <$> many stringCharacter stringCharacter = satisfy isStringCharacter1 @@ -143,7 +143,7 @@ string = between "\"" "\"" stringValue <* spaceConsumer -- | Parser for block strings. blockString :: Parser T.Text -blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer +blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer where stringValue = do byLine <- sepBy (many blockStringCharacter) lineTerminator diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index 1505615..dfe1d4a 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -6,23 +6,19 @@ module Language.GraphQL.AST.Parser ( document ) where -import Control.Applicative ( Alternative(..) - , optional - ) +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 - , (<?>) - ) +import Text.Megaparsec (lookAhead, option, try, (<?>)) -- | Parser for the GraphQL documents. document :: Parser Document -document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition) +document = unicodeBOM + >> spaceConsumer + >> lexeme (manyNE $ ExecutableDefinition <$> definition) -definition :: Parser Definition +definition :: Parser ExecutableDefinition definition = DefinitionOperation <$> operationDefinition <|> DefinitionFragment <$> fragmentDefinition <?> "definition error!" @@ -50,19 +46,20 @@ selectionSetOpt :: Parser SelectionSetOpt selectionSetOpt = braces $ some selection selection :: Parser Selection -selection = SelectionField <$> field - <|> try (SelectionFragmentSpread <$> fragmentSpread) - <|> SelectionInlineFragment <$> inlineFragment - <?> "selection error!" +selection = field + <|> try fragmentSpread + <|> inlineFragment + <?> "selection error!" -- * Field -field :: Parser Field -field = Field <$> optional alias - <*> name - <*> opt arguments - <*> opt directives - <*> opt selectionSetOpt +field :: Parser Selection +field = Field + <$> optional alias + <*> name + <*> opt arguments + <*> opt directives + <*> opt selectionSetOpt alias :: Parser Alias alias = try $ name <* colon @@ -77,16 +74,18 @@ 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 +fragmentSpread :: Parser Selection +fragmentSpread = FragmentSpread + <$ spread + <*> fragmentName + <*> opt directives + +inlineFragment :: Parser Selection +inlineFragment = InlineFragment + <$ spread + <*> optional typeCondition + <*> opt directives + <*> selectionSet fragmentDefinition :: Parser FragmentDefinition fragmentDefinition = FragmentDefinition diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 882b324..8612381 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -42,9 +42,9 @@ document subs document' = $ Replacement HashMap.empty fragmentTable where (fragmentTable, operationDefinitions) = foldr defragment mempty document' - defragment (Full.DefinitionOperation definition) acc = + defragment (Full.ExecutableDefinition (Full.DefinitionOperation definition)) acc = (definition :) <$> acc - defragment (Full.DefinitionFragment definition) acc = + defragment (Full.ExecutableDefinition (Full.DefinitionFragment definition)) acc = let (Full.FragmentDefinition name _ _ _) = definition in first (HashMap.insert name definition) acc @@ -69,13 +69,35 @@ operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) = selection :: Full.Selection -> TransformT (Either (Seq Core.Selection) Core.Selection) -selection (Full.SelectionField field') = - maybe (Left mempty) (Right . Core.SelectionField) <$> field field' -selection (Full.SelectionFragmentSpread fragment) = - maybe (Left mempty) (Right . Core.SelectionFragment) - <$> fragmentSpread fragment -selection (Full.SelectionInlineFragment fragment) = - inlineFragment fragment +selection (Full.Field alias name arguments' directives' selections) = + maybe (Left mempty) (Right . Core.SelectionField) <$> do + fieldArguments <- traverse argument arguments' + fieldSelections <- appendSelection selections + fieldDirectives <- Directive.selection <$> directives directives' + let field' = Core.Field alias name fieldArguments fieldSelections + pure $ field' <$ fieldDirectives +selection (Full.FragmentSpread name directives') = + maybe (Left mempty) (Right . Core.SelectionFragment) <$> do + spreadDirectives <- Directive.selection <$> directives directives' + fragments' <- gets fragments + fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments') + pure $ fragment <$ spreadDirectives + where + lookupDefinition = do + fragmentDefinitions' <- gets fragmentDefinitions + found <- lift . lift $ HashMap.lookup name fragmentDefinitions' + fragmentDefinition found +selection (Full.InlineFragment type' directives' selections) = do + fragmentDirectives <- Directive.selection <$> directives directives' + case fragmentDirectives of + Nothing -> pure $ Left mempty + _ -> do + fragmentSelectionSet <- appendSelection selections + pure $ maybe Left selectionFragment type' fragmentSelectionSet + where + selectionFragment typeName = Right + . Core.SelectionFragment + . Core.Fragment typeName appendSelection :: Traversable t => @@ -104,33 +126,6 @@ collectFragments = do _ <- fragmentDefinition nextValue collectFragments -inlineFragment :: - Full.InlineFragment -> - TransformT (Either (Seq Core.Selection) Core.Selection) -inlineFragment (Full.InlineFragment type' directives' selectionSet) = do - fragmentDirectives <- Directive.selection <$> directives directives' - case fragmentDirectives of - Nothing -> pure $ Left mempty - _ -> do - fragmentSelectionSet <- appendSelection selectionSet - pure $ maybe Left selectionFragment type' fragmentSelectionSet - where - selectionFragment typeName = Right - . Core.SelectionFragment - . Core.Fragment typeName - -fragmentSpread :: Full.FragmentSpread -> TransformT (Maybe Core.Fragment) -fragmentSpread (Full.FragmentSpread name directives') = do - spreadDirectives <- Directive.selection <$> directives directives' - fragments' <- gets fragments - fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments') - pure $ fragment <$ spreadDirectives - where - lookupDefinition = do - fragmentDefinitions' <- gets fragmentDefinitions - found <- lift . lift $ HashMap.lookup name fragmentDefinitions' - fragmentDefinition found - fragmentDefinition :: Full.FragmentDefinition -> TransformT Core.Fragment @@ -147,14 +142,6 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do let newFragments = HashMap.insert name newValue fragments' in Replacement newFragments fragmentDefinitions' -field :: Full.Field -> TransformT (Maybe Core.Field) -field (Full.Field alias name arguments' directives' selections) = do - fieldArguments <- traverse argument arguments' - fieldSelections <- appendSelection selections - fieldDirectives <- Directive.selection <$> directives directives' - let field' = Core.Field alias name fieldArguments fieldSelections - pure $ field' <$ fieldDirectives - arguments :: [Full.Argument] -> TransformT Core.Arguments arguments = fmap Core.Arguments . foldM go HashMap.empty where |