Replace AST.Selection data constructors

CHANGELOG.md

@@ -1,6 +1,19 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 
+## [Unreleased]
+### Changed
+- Renamed `AST.Definition` into `AST.ExecutableDefinition`.
+  TypeSystemDefinition and TypeSystemExtension can also be definitions.
+- Defined `AST.Definition` as
+  `newtype Definition = ExecutableDefinition ExecutableDefinition` for now. It
+  should be soon extended to contain missing definition types.
+- Removed types `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`.
+  These types are only used in `AST.Selection` and `AST.Selection` contains now
+  3 corresponding data constructors, `Field`, `InlineFragment` and
+  `FragmentSpread`, instead of separate types. It simplifies pattern matching
+  and doesn't make the code less typesafe.
+
 ## [0.6.1.0] - 2019-12-23
 ### Fixed
 - Parsing multiple string arguments, such as
@@ -162,6 +175,7 @@ All notable changes to this project will be documented in this file.
 ### Added
 - Data types for the GraphQL language.
 
+[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...HEAD
 [0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0
 [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

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

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.Field alias name args directives' selections) =
-    encodeSelection (Full.SelectionInlineFragment fragment) =
+        field incrementIndent alias name args directives' selections
-        inlineFragment incrementIndent fragment
+    encodeSelection (Full.InlineFragment typeCondition directives' selections) =
-    encodeSelection (Full.SelectionFragmentSpread spread) =
+        inlineFragment incrementIndent typeCondition directives' selections
-        fragmentSpread incrementIndent spread
+    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 ->
-field formatter (Full.Field alias name args dirs set)
+    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.Name -> [Full.Directive] -> Lazy.Text
-fragmentSpread formatter (Full.FragmentSpread name ds)
+fragmentSpread formatter name directives'
-    = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds
+    = "..." <> Lazy.Text.fromStrict name
+    <> optempty (directives formatter) directives'
 
-inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
+inlineFragment ::
-inlineFragment formatter (Full.InlineFragment tc dirs sels)
+    Formatter ->
-    = "... on "
+    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

src/Language/GraphQL/AST/Parser.hs

@@ -6,23 +6,19 @@ module Language.GraphQL.AST.Parser
     ( document
     ) where
 
-import Control.Applicative ( Alternative(..)
+import Control.Applicative (Alternative(..), optional)
-                           , optional
-                           )
 import Data.List.NonEmpty (NonEmpty(..))
 import Language.GraphQL.AST
 import Language.GraphQL.AST.Lexer
-import Text.Megaparsec ( lookAhead
+import Text.Megaparsec (lookAhead, option, try, (<?>))
-                       , 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
+selection = field
-        <|> try (SelectionFragmentSpread <$> fragmentSpread)
+    <|> try fragmentSpread
-        <|> SelectionInlineFragment <$> inlineFragment
+    <|> inlineFragment
-        <?> "selection error!"
+    <?> "selection error!"
 
 -- * Field
 
-field :: Parser Field
+field :: Parser Selection
-field = Field <$> optional alias
+field = Field
-              <*> name
+    <$> optional alias
-              <*> opt arguments
+    <*> name
-              <*> opt directives
+    <*> opt arguments
-              <*> opt selectionSetOpt
+    <*> 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 :: Parser Selection
-fragmentSpread = FragmentSpread <$  spread
+fragmentSpread = FragmentSpread
-                                <*> fragmentName
+    <$ spread
-                                <*> opt directives
+    <*> fragmentName
+    <*> opt directives
 
-inlineFragment :: Parser InlineFragment
+inlineFragment :: Parser Selection
-inlineFragment = InlineFragment <$  spread
+inlineFragment = InlineFragment
-                                <*> optional typeCondition
+    <$ spread
-                                <*> opt directives
+    <*> optional typeCondition
-                                <*> selectionSet
+    <*> opt directives
+    <*> selectionSet
 
 fragmentDefinition :: Parser FragmentDefinition
 fragmentDefinition = FragmentDefinition

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') =
+selection (Full.Field alias name arguments' directives' selections) =
-    maybe (Left mempty) (Right . Core.SelectionField) <$> field field'
+    maybe (Left mempty) (Right . Core.SelectionField) <$> do
-selection (Full.SelectionFragmentSpread fragment) =
+        fieldArguments <- traverse argument arguments'
-    maybe (Left mempty) (Right . Core.SelectionFragment)
+        fieldSelections <- appendSelection selections
-    <$> fragmentSpread fragment
+        fieldDirectives <- Directive.selection <$> directives directives'
-selection (Full.SelectionInlineFragment fragment) =
+        let field' = Core.Field alias name fieldArguments fieldSelections
-    inlineFragment fragment
+        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

tests/Language/GraphQL/AST/EncoderSpec.hs

@@ -35,7 +35,7 @@ spec = do
         it "indents block strings in arguments" $
             let arguments = [Argument "message" (String "line1\nline2")]
                 field = Field Nothing "field" arguments [] []
-                set = OperationSelectionSet $ pure $ SelectionField field
+                set = OperationSelectionSet $ pure field
                 operation = DefinitionOperation set
              in definition pretty operation `shouldBe` [r|{
   field(message: """