aboutsummaryrefslogtreecommitdiff
path: root/src/Language
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language')
-rw-r--r--src/Language/GraphQL/AST/Core.hs10
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs243
-rw-r--r--src/Language/GraphQL/AST/Lexer.hs4
-rw-r--r--src/Language/GraphQL/Execute.hs2
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs (renamed from src/Language/GraphQL/AST/Transform.hs)120
-rw-r--r--src/Language/GraphQL/Schema.hs4
-rw-r--r--src/Language/GraphQL/Type/Directive.hs50
7 files changed, 279 insertions, 154 deletions
diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs
index f7a008f..7ba4830 100644
--- a/src/Language/GraphQL/AST/Core.hs
+++ b/src/Language/GraphQL/AST/Core.hs
@@ -2,6 +2,8 @@
module Language.GraphQL.AST.Core
( Alias
, Argument(..)
+ , Arguments(..)
+ , Directive(..)
, Document
, Field(..)
, Fragment(..)
@@ -39,6 +41,14 @@ data Field
-- | Single argument.
data Argument = Argument Name Value deriving (Eq, Show)
+-- | Argument list.
+newtype Arguments = Arguments (HashMap Name Value)
+ deriving (Eq, Show)
+
+-- | Directive.
+data Directive = Directive Name Arguments
+ deriving (Eq, Show)
+
-- | Represents fragments and inline fragments.
data Fragment
= Fragment TypeCondition (Seq Selection)
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index afc425f..508212a 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -13,13 +13,17 @@ module Language.GraphQL.AST.Encoder
, value
) where
+import Data.Char (ord)
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 qualified Data.List.NonEmpty as NonEmpty
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as Lazy (Text)
+import qualified Data.Text.Lazy as Lazy.Text
+import Data.Text.Lazy.Builder (Builder)
+import qualified Data.Text.Lazy.Builder as Builder
+import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
import qualified Language.GraphQL.AST as Full
@@ -40,17 +44,17 @@ minified :: Formatter
minified = Minified
-- | Converts a 'Full.Document' into a string.
-document :: Formatter -> Full.Document -> Text
+document :: Formatter -> Full.Document -> Lazy.Text
document formatter defs
- | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument
- | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n'
+ | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
+ | Minified <-formatter = Lazy.Text.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 -> Full.Definition -> Lazy.Text
definition formatter x
- | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n'
+ | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
| Minified <- formatter = encodeDefinition x
where
encodeDefinition (Full.DefinitionOperation operation)
@@ -58,7 +62,7 @@ definition formatter x
encodeDefinition (Full.DefinitionFragment fragment)
= fragmentDefinition formatter fragment
-operationDefinition :: Formatter -> Full.OperationDefinition -> Text
+operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
operationDefinition formatter (Full.OperationSelectionSet sels)
= selectionSet formatter sels
operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
@@ -66,99 +70,106 @@ operationDefinition formatter (Full.OperationDefinition Full.Query name vars dir
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 ->
+ Maybe Full.Name ->
+ [Full.VariableDefinition] ->
+ [Full.Directive] ->
+ Full.SelectionSet ->
+ Lazy.Text
node formatter name vars dirs sels
- = Text.Lazy.fromStrict (fold name)
+ = Lazy.Text.fromStrict (fold name)
<> optempty (variableDefinitions formatter) vars
<> optempty (directives formatter) dirs
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
-variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Text
+variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
variableDefinitions formatter
= parensCommas formatter $ variableDefinition formatter
-variableDefinition :: Formatter -> Full.VariableDefinition -> Text
+variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.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 -> Full.Value -> Lazy.Text
defaultValue formatter val
= eitherFormat formatter " = " "="
<> value formatter val
-variable :: Full.Name -> Text
-variable var = "$" <> Text.Lazy.fromStrict var
+variable :: Full.Name -> Lazy.Text
+variable var = "$" <> Lazy.Text.fromStrict var
-selectionSet :: Formatter -> Full.SelectionSet -> Text
+selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
selectionSet formatter
= bracesList formatter (selection formatter)
. NonEmpty.toList
-selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Text
+selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
selectionSetOpt formatter = bracesList formatter $ selection formatter
-selection :: Formatter -> Full.Selection -> Text
-selection formatter = Text.Lazy.append indent . f
+indent :: (Integral a) => a -> Lazy.Text
+indent indentation = Lazy.Text.replicate (fromIntegral indentation) " "
+
+selection :: Formatter -> Full.Selection -> Lazy.Text
+selection formatter = Lazy.Text.append indent' . encodeSelection
where
- f (Full.SelectionField x) = field incrementIndent x
- f (Full.SelectionInlineFragment x) = inlineFragment incrementIndent x
- f (Full.SelectionFragmentSpread x) = fragmentSpread incrementIndent x
+ encodeSelection (Full.SelectionField field') = field incrementIndent field'
+ encodeSelection (Full.SelectionInlineFragment fragment) =
+ inlineFragment incrementIndent fragment
+ encodeSelection (Full.SelectionFragmentSpread spread) =
+ fragmentSpread incrementIndent spread
incrementIndent
- | Pretty n <- formatter = Pretty $ n + 1
+ | Pretty indentation <- formatter = Pretty $ indentation + 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
+ indent'
+ | Pretty indentation <- formatter = indent $ indentation + 1
+ | otherwise = ""
+
+colon :: Formatter -> Lazy.Text
+colon formatter = eitherFormat formatter ": " ":"
+
+field :: Formatter -> Full.Field -> Lazy.Text
+field formatter (Full.Field alias name args dirs set)
+ = optempty prependAlias (fold alias)
+ <> Lazy.Text.fromStrict name
<> optempty (arguments formatter) args
<> optempty (directives formatter) dirs
- <> selectionSetOpt'
+ <> optempty selectionSetOpt' set
where
- colon = eitherFormat formatter ": " ":"
- selectionSetOpt'
- | null selso = mempty
- | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso
+ prependAlias aliasName = Lazy.Text.fromStrict aliasName <> colon formatter
+ selectionSetOpt' = (eitherFormat formatter " " "" <>)
+ . selectionSetOpt formatter
-arguments :: Formatter -> [Full.Argument] -> Text
+arguments :: Formatter -> [Full.Argument] -> Lazy.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
+argument :: Formatter -> Full.Argument -> Lazy.Text
+argument formatter (Full.Argument name value')
+ = Lazy.Text.fromStrict name
+ <> colon formatter
+ <> value formatter value'
-- * Fragments
-fragmentSpread :: Formatter -> Full.FragmentSpread -> Text
+fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text
fragmentSpread formatter (Full.FragmentSpread name ds)
- = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds
+ = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds
-inlineFragment :: Formatter -> Full.InlineFragment -> Text
+inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
inlineFragment formatter (Full.InlineFragment tc dirs sels)
= "... on "
- <> Text.Lazy.fromStrict (fold tc)
+ <> Lazy.Text.fromStrict (fold tc)
<> directives formatter dirs
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
-fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Text
+fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
- = "fragment " <> Text.Lazy.fromStrict name
- <> " on " <> Text.Lazy.fromStrict tc
+ = "fragment " <> Lazy.Text.fromStrict name
+ <> " on " <> Lazy.Text.fromStrict tc
<> optempty (directives formatter) dirs
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
@@ -166,108 +177,128 @@ fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
-- * Miscellaneous
-- | Converts a 'Full.Directive' into a string.
-directive :: Formatter -> Full.Directive -> Text
+directive :: Formatter -> Full.Directive -> Lazy.Text
directive formatter (Full.Directive name args)
- = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args
+ = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
-directives :: Formatter -> [Full.Directive] -> Text
-directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)
+directives :: Formatter -> [Full.Directive] -> Lazy.Text
directives Minified = spaces (directive Minified)
+directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
-- | Converts a 'Full.Value' into a string.
-value :: Formatter -> Full.Value -> Text
+value :: Formatter -> Full.Value -> Lazy.Text
value _ (Full.Variable x) = variable x
-value _ (Full.Int x) = toLazyText $ decimal x
-value _ (Full.Float x) = toLazyText $ realFloat x
+value _ (Full.Int x) = Builder.toLazyText $ decimal x
+value _ (Full.Float x) = Builder.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.String string) = stringValue formatter string
+value _ (Full.Enum x) = Lazy.Text.fromStrict x
value formatter (Full.List x) = listValue formatter x
value formatter (Full.Object x) = objectValue formatter x
-booleanValue :: Bool -> Text
+booleanValue :: Bool -> Lazy.Text
booleanValue True = "true"
booleanValue False = "false"
-stringValue :: Text -> Text
-stringValue
- = quotes
- . Text.Lazy.replace "\"" "\\\""
- . Text.Lazy.replace "\\" "\\\\"
+stringValue :: Formatter -> Text -> Lazy.Text
+stringValue Minified string = Builder.toLazyText
+ $ quote <> Text.foldr (mappend . escape') quote string
+ where
+ quote = Builder.singleton '\"'
+ escape' '\n' = Builder.fromString "\\n"
+ escape' char = escape char
+stringValue (Pretty indentation) string = byStringType $ Text.lines string
+ where
+ byStringType [] = "\"\""
+ byStringType [line] = Builder.toLazyText
+ $ quote <> Text.foldr (mappend . escape) quote line
+ byStringType lines' = "\"\"\"\n"
+ <> Lazy.Text.unlines (transformLine <$> lines')
+ <> indent indentation
+ <> "\"\"\""
+ transformLine = (indent (indentation + 1) <>)
+ . Lazy.Text.fromStrict
+ . Text.replace "\"\"\"" "\\\"\"\""
+ quote = Builder.singleton '\"'
+
+escape :: Char -> Builder
+escape char'
+ | char' == '\\' = Builder.fromString "\\\\"
+ | char' == '\"' = Builder.fromString "\\\""
+ | char' == '\b' = Builder.fromString "\\b"
+ | char' == '\f' = Builder.fromString "\\f"
+ | char' == '\r' = Builder.fromString "\\r"
+ | char' < '\x0010' = unicode "\\u000" char'
+ | char' < '\x0020' = unicode "\\u00" char'
+ | otherwise = Builder.singleton char'
+ where
+ unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
-listValue :: Formatter -> [Full.Value] -> Text
+listValue :: Formatter -> [Full.Value] -> Lazy.Text
listValue formatter = bracketsCommas formatter $ value formatter
-objectValue :: Formatter -> [Full.ObjectField] -> Text
+objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text
objectValue formatter = intercalate $ objectField formatter
where
intercalate f
= braces
- . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+ . Lazy.Text.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 = ":"
+objectField :: Formatter -> Full.ObjectField -> Lazy.Text
+objectField formatter (Full.ObjectField name value') =
+ Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
-- | Converts a 'Full.Type' a type into a string.
-type' :: Full.Type -> Text
-type' (Full.TypeNamed x) = Text.Lazy.fromStrict x
+type' :: Full.Type -> Lazy.Text
+type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
type' (Full.TypeList x) = listType x
type' (Full.TypeNonNull x) = nonNullType x
-listType :: Full.Type -> Text
+listType :: Full.Type -> Lazy.Text
listType x = brackets (type' x)
-nonNullType :: Full.NonNullType -> Text
-nonNullType (Full.NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"
+nonNullType :: Full.NonNullType -> Lazy.Text
+nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.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)
+between :: Char -> Char -> Lazy.Text -> Lazy.Text
+between open close = Lazy.Text.cons open . (`Lazy.Text.snoc` close)
-parens :: Text -> Text
+parens :: Lazy.Text -> Lazy.Text
parens = between '(' ')'
-brackets :: Text -> Text
+brackets :: Lazy.Text -> Lazy.Text
brackets = between '[' ']'
-braces :: Text -> Text
+braces :: Lazy.Text -> Lazy.Text
braces = between '{' '}'
-quotes :: Text -> Text
-quotes = between '"' '"'
-
-spaces :: forall a. (a -> Text) -> [a] -> Text
-spaces f = Text.Lazy.intercalate "\SP" . fmap f
+spaces :: forall a. (a -> Lazy.Text) -> [a] -> Lazy.Text
+spaces f = Lazy.Text.intercalate "\SP" . fmap f
-parensCommas :: forall a. Formatter -> (a -> Text) -> [a] -> Text
+parensCommas :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
parensCommas formatter f
= parens
- . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+ . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
. fmap f
-bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text
+bracketsCommas :: Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
bracketsCommas formatter f
= brackets
- . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+ . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
. fmap f
-bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text
+bracesList :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
bracesList (Pretty intendation) f xs
- = Text.Lazy.snoc (Text.Lazy.intercalate "\n" content) '\n'
- <> (Text.Lazy.snoc $ Text.Lazy.replicate (fromIntegral intendation) " ") '}'
+ = Lazy.Text.snoc (Lazy.Text.intercalate "\n" content) '\n'
+ <> (Lazy.Text.snoc $ Lazy.Text.replicate (fromIntegral intendation) " ") '}'
where
content = "{" : fmap f xs
-bracesList Minified f xs = braces $ Text.Lazy.intercalate "," $ fmap f xs
+bracesList Minified f xs = braces $ Lazy.Text.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
diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs
index e4d64ca..f95070c 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
+string = between "\"" "\"" stringValue <* spaceConsumer
where
stringValue = T.pack <$> many stringCharacter
stringCharacter = satisfy isStringCharacter1
@@ -143,7 +143,7 @@ string = between "\"" "\"" stringValue
-- | Parser for block strings.
blockString :: Parser T.Text
-blockString = between "\"\"\"" "\"\"\"" stringValue
+blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
where
stringValue = do
byLine <- sepBy (many blockStringCharacter) lineTerminator
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 59e85bf..74f33f9 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -15,7 +15,7 @@ import Data.Text (Text)
import qualified Data.Text as Text
import qualified Language.GraphQL.AST as AST
import qualified Language.GraphQL.AST.Core as AST.Core
-import qualified Language.GraphQL.AST.Transform as Transform
+import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
import qualified Language.GraphQL.Schema as Schema
diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 95cdfbb..882b324 100644
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -1,10 +1,10 @@
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TupleSections #-}
-- | After the document is parsed, before getting executed the AST is
-- transformed into a similar, simpler AST. This module is responsible for
-- this transformation.
-module Language.GraphQL.AST.Transform
+module Language.GraphQL.Execute.Transform
( document
) where
@@ -20,15 +20,19 @@ 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
+import qualified Language.GraphQL.Type.Directive as Directive
-- | Associates a fragment name with a list of 'Core.Field's.
data Replacement = Replacement
- { fragments :: HashMap Core.Name (Seq Core.Selection)
+ { fragments :: HashMap Core.Name Core.Fragment
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
}
type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
+liftJust :: forall a. a -> TransformT a
+liftJust = lift . lift . Just
+
-- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution.
document :: Schema.Subs -> Full.Document -> Maybe Core.Document
@@ -46,7 +50,6 @@ document subs document' =
-- * Operation
--- TODO: Replace Maybe by MonadThrow CustomError
operations :: [Full.OperationDefinition] -> TransformT Core.Document
operations operations' = do
coreOperations <- traverse operation operations'
@@ -61,27 +64,34 @@ operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =
operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
Core.Mutation name <$> appendSelection sels
+-- * Selection
+
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')
+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
+
+appendSelection ::
+ Traversable t =>
+ t Full.Selection ->
+ TransformT (Seq Core.Selection)
+appendSelection = foldM go mempty
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 selectionSet
- | (Full.InlineFragment Nothing _ selectionSet) <- fragment
- = Left <$> appendSelection selectionSet
+ go acc sel = append acc <$> selection sel
+ append acc (Left list) = list >< acc
+ append acc (Right one) = one <| acc
+
+directives :: [Full.Directive] -> TransformT [Core.Directive]
+directives = traverse directive
+ where
+ directive (Full.Directive directiveName directiveArguments) =
+ Core.Directive directiveName <$> arguments directiveArguments
-- * Fragment replacement
@@ -94,12 +104,40 @@ 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 (Seq Core.Selection)
-fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do
+ TransformT Core.Fragment
+fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
modify deleteFragmentDefinition
- newValue <- appendSelection selections
+ fragmentSelection <- appendSelection selections
+ let newValue = Core.Fragment type' fragmentSelection
modify $ insertFragment newValue
liftJust newValue
where
@@ -109,11 +147,20 @@ fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do
let newFragments = HashMap.insert name newValue fragments'
in Replacement newFragments fragmentDefinitions'
-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'
+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
+ go arguments' argument' = do
+ (Core.Argument name value') <- argument argument'
+ return $ HashMap.insert name value' arguments'
argument :: Full.Argument -> TransformT Core.Argument
argument (Full.Argument n v) = Core.Argument n <$> value v
@@ -134,17 +181,4 @@ value (Full.Object o) =
Core.Object . HashMap.fromList <$> traverse objectField o
objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
-objectField (Full.ObjectField n v) = (n,) <$> value v
-
-appendSelection ::
- 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
+objectField (Full.ObjectField name value') = (name,) <$> value value'
diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index afe068f..fa8bf78 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/src/Language/GraphQL/Schema.hs
@@ -131,8 +131,8 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
tryResolvers (SelectionField fld@(Field _ name _ _))
= maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
- that <- maybe (return "") resolveTypeName (find (compareResolvers "__typename") resolvers)
- if Aeson.String typeCondition == that
+ that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)
+ if maybe True (Aeson.String typeCondition ==) that
then fmap fold . traverse tryResolvers $ selections'
else return mempty
compareResolvers name (Resolver name' _) = name == name'
diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs
new file mode 100644
index 0000000..afd97da
--- /dev/null
+++ b/src/Language/GraphQL/Type/Directive.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.GraphQL.Type.Directive
+ ( selection
+ ) where
+
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL.AST.Core
+
+-- | Directive processing status.
+data Status
+ = Skip -- ^ Skip the selection and stop directive processing
+ | Include Directive -- ^ The directive was processed, try other handlers
+ | Continue Directive -- ^ Directive handler mismatch, try other handlers
+
+-- | Takes a list of directives, handles supported directives and excludes them
+-- from the result. If the selection should be skipped, returns 'Nothing'.
+selection :: [Directive] -> Maybe [Directive]
+selection = foldr go (Just [])
+ where
+ go directive' directives' =
+ case (skip . include) (Continue directive') of
+ (Include _) -> directives'
+ Skip -> Nothing
+ (Continue x) -> (x :) <$> directives'
+
+handle :: (Directive -> Status) -> Status -> Status
+handle _ Skip = Skip
+handle handler (Continue directive) = handler directive
+handle handler (Include directive) = handler directive
+
+-- * Directive implementations
+
+skip :: Status -> Status
+skip = handle skip'
+ where
+ skip' directive'@(Directive "skip" (Arguments arguments)) =
+ case HashMap.lookup "if" arguments of
+ (Just (Boolean True)) -> Skip
+ _ -> Include directive'
+ skip' directive' = Continue directive'
+
+include :: Status -> Status
+include = handle include'
+ where
+ include' directive'@(Directive "include" (Arguments arguments)) =
+ case HashMap.lookup "if" arguments of
+ (Just (Boolean True)) -> Include directive'
+ _ -> Skip
+ include' directive' = Continue directive'
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 09:36:23 +0000