aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/AST/Document.hs8
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs279
-rw-r--r--src/Language/GraphQL/Execute.hs11
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs76
4 files changed, 278 insertions, 96 deletions
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index ea640df..131285d 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -464,6 +464,14 @@ data SchemaExtension
newtype Description = Description (Maybe Text)
deriving (Eq, Show)
+instance Semigroup Description
+ where
+ Description lhs <> Description rhs = Description $ lhs <> rhs
+
+instance Monoid Description
+ where
+ mempty = Description mempty
+
-- ** Types
-- | Type definitions describe various user-defined types.
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index 54967ea..120fb64 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -14,10 +14,11 @@ module Language.GraphQL.AST.Encoder
, operationType
, pretty
, type'
+ , typeSystemDefinition
, value
) where
-import Data.Foldable (fold)
+import Data.Foldable (fold, Foldable (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as Text
@@ -28,6 +29,7 @@ import qualified Data.Text.Lazy.Builder as Builder
import Data.Text.Lazy.Builder.Int (decimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
import qualified Language.GraphQL.AST.Document as Full
+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
-- | Instructs the encoder whether the GraphQL document should be minified or
-- pretty printed.
@@ -54,7 +56,246 @@ document formatter defs
encodeDocument = foldr executableDefinition [] defs
executableDefinition (Full.ExecutableDefinition executableDefinition') acc =
definition formatter executableDefinition' : acc
- executableDefinition _ acc = acc
+ executableDefinition (Full.TypeSystemDefinition typeSystemDefinition' _location) acc =
+ typeSystemDefinition formatter typeSystemDefinition' : acc
+ executableDefinition (Full.TypeSystemExtension typeSystemExtension' _location) acc =
+ typeSystemExtension formatter typeSystemExtension' : acc
+
+directiveLocation :: DirectiveLocation.DirectiveLocation -> Lazy.Text
+directiveLocation = Lazy.Text.pack . show
+
+withLineBreak :: Formatter -> Lazy.Text.Text -> Lazy.Text.Text
+withLineBreak formatter encodeDefinition
+ | Pretty _ <- formatter = Lazy.Text.snoc encodeDefinition '\n'
+ | Minified <- formatter = encodeDefinition
+
+typeSystemExtension :: Formatter -> Full.TypeSystemExtension -> Lazy.Text
+typeSystemExtension formatter = \case
+ Full.SchemaExtension schemaExtension' ->
+ schemaExtension formatter schemaExtension'
+ Full.TypeExtension typeExtension' -> typeExtension formatter typeExtension'
+
+schemaExtension :: Formatter -> Full.SchemaExtension -> Lazy.Text
+schemaExtension formatter = \case
+ Full.SchemaOperationExtension operationDirectives operationTypeDefinitions' ->
+ withLineBreak formatter
+ $ "extend schema "
+ <> optempty (directives formatter) operationDirectives
+ <> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
+ Full.SchemaDirectivesExtension operationDirectives -> "extend schema "
+ <> optempty (directives formatter) (NonEmpty.toList operationDirectives)
+
+typeExtension :: Formatter -> Full.TypeExtension -> Lazy.Text
+typeExtension formatter = \case
+ Full.ScalarTypeExtension name' directives'
+ -> "extend scalar "
+ <> Lazy.Text.fromStrict name'
+ <> directives formatter (NonEmpty.toList directives')
+ Full.ObjectTypeFieldsDefinitionExtension name' ifaces' directives' fields'
+ -> "extend type "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (" " <>) (implementsInterfaces ifaces')
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')
+ Full.ObjectTypeDirectivesExtension name' ifaces' directives'
+ -> "extend type "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (" " <>) (implementsInterfaces ifaces')
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ Full.ObjectTypeImplementsInterfacesExtension name' ifaces'
+ -> "extend type "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (" " <>) (implementsInterfaces ifaces')
+ Full.InterfaceTypeFieldsDefinitionExtension name' directives' fields'
+ -> "extend interface "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (fieldDefinition nextFormatter) (NonEmpty.toList fields')
+ Full.InterfaceTypeDirectivesExtension name' directives'
+ -> "extend interface "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ Full.UnionTypeUnionMemberTypesExtension name' directives' members'
+ -> "extend union "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> unionMemberTypes formatter members'
+ Full.UnionTypeDirectivesExtension name' directives'
+ -> "extend union "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ Full.EnumTypeEnumValuesDefinitionExtension name' directives' members'
+ -> "extend enum "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (enumValueDefinition formatter) (NonEmpty.toList members')
+ Full.EnumTypeDirectivesExtension name' directives'
+ -> "extend enum "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ Full.InputObjectTypeInputFieldsDefinitionExtension name' directives' fields'
+ -> "extend input "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (inputValueDefinition nextFormatter) (NonEmpty.toList fields')
+ Full.InputObjectTypeDirectivesExtension name' directives'
+ -> "extend input "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) (NonEmpty.toList directives')
+ where
+ nextFormatter = incrementIndent formatter
+
+-- | Converts a t'Full.TypeSystemDefinition' into a string.
+typeSystemDefinition :: Formatter -> Full.TypeSystemDefinition -> Lazy.Text
+typeSystemDefinition formatter = \case
+ Full.SchemaDefinition operationDirectives operationTypeDefinitions' ->
+ withLineBreak formatter
+ $ "schema "
+ <> optempty (directives formatter) operationDirectives
+ <> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
+ Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
+ Full.DirectiveDefinition description' name' arguments' locations
+ -> description formatter description'
+ <> "@"
+ <> Lazy.Text.fromStrict name'
+ <> argumentsDefinition formatter arguments'
+ <> " on"
+ <> pipeList formatter (directiveLocation <$> locations)
+
+operationTypeDefinition :: Formatter -> Full.OperationTypeDefinition -> Lazy.Text.Text
+operationTypeDefinition formatter (Full.OperationTypeDefinition operationType' namedType')
+ = indentLine (incrementIndent formatter)
+ <> operationType formatter operationType'
+ <> colon formatter
+ <> Lazy.Text.fromStrict namedType'
+
+fieldDefinition :: Formatter -> Full.FieldDefinition -> Lazy.Text.Text
+fieldDefinition formatter fieldDefinition' =
+ let Full.FieldDefinition description' name' arguments' type'' directives' = fieldDefinition'
+ in optempty (description formatter) description'
+ <> indentLine formatter
+ <> Lazy.Text.fromStrict name'
+ <> argumentsDefinition formatter arguments'
+ <> colon formatter
+ <> type' type''
+ <> optempty (directives formatter) directives'
+
+argumentsDefinition :: Formatter -> Full.ArgumentsDefinition -> Lazy.Text.Text
+argumentsDefinition formatter (Full.ArgumentsDefinition arguments') =
+ parensCommas formatter (argumentDefinition formatter) arguments'
+
+argumentDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text
+argumentDefinition formatter definition' =
+ let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'
+ in optempty (description formatter) description'
+ <> Lazy.Text.fromStrict name'
+ <> colon formatter
+ <> type' type''
+ <> maybe mempty (defaultValue formatter . Full.node) defaultValue'
+ <> directives formatter directives'
+
+inputValueDefinition :: Formatter -> Full.InputValueDefinition -> Lazy.Text.Text
+inputValueDefinition formatter definition' =
+ let Full.InputValueDefinition description' name' type'' defaultValue' directives' = definition'
+ in optempty (description formatter) description'
+ <> indentLine formatter
+ <> Lazy.Text.fromStrict name'
+ <> colon formatter
+ <> type' type''
+ <> maybe mempty (defaultValue formatter . Full.node) defaultValue'
+ <> directives formatter directives'
+
+typeDefinition :: Formatter -> Full.TypeDefinition -> Lazy.Text
+typeDefinition formatter = \case
+ Full.ScalarTypeDefinition description' name' directives'
+ -> optempty (description formatter) description'
+ <> "scalar "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ Full.ObjectTypeDefinition description' name' ifaces' directives' fields'
+ -> optempty (description formatter) description'
+ <> "type "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (" " <>) (implementsInterfaces ifaces')
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (fieldDefinition nextFormatter) fields'
+ Full.InterfaceTypeDefinition description' name' directives' fields'
+ -> optempty (description formatter) description'
+ <> "interface "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (fieldDefinition nextFormatter) fields'
+ Full.UnionTypeDefinition description' name' directives' members'
+ -> optempty (description formatter) description'
+ <> "union "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> unionMemberTypes formatter members'
+ Full.EnumTypeDefinition description' name' directives' members'
+ -> optempty (description formatter) description'
+ <> "enum "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (enumValueDefinition formatter) members'
+ Full.InputObjectTypeDefinition description' name' directives' fields'
+ -> optempty (description formatter) description'
+ <> "input "
+ <> Lazy.Text.fromStrict name'
+ <> optempty (directives formatter) directives'
+ <> eitherFormat formatter " " ""
+ <> bracesList formatter (inputValueDefinition nextFormatter) fields'
+ where
+ nextFormatter = incrementIndent formatter
+
+implementsInterfaces :: Foldable t => Full.ImplementsInterfaces t -> Lazy.Text
+implementsInterfaces (Full.ImplementsInterfaces interfaces)
+ | null interfaces = mempty
+ | otherwise = Lazy.Text.fromStrict
+ $ Text.append "implements "
+ $ Text.intercalate " & "
+ $ toList interfaces
+
+unionMemberTypes :: Foldable t => Formatter -> Full.UnionMemberTypes t -> Lazy.Text
+unionMemberTypes formatter (Full.UnionMemberTypes memberTypes)
+ | null memberTypes = mempty
+ | otherwise = Lazy.Text.append "="
+ $ pipeList formatter
+ $ Lazy.Text.fromStrict
+ <$> toList memberTypes
+
+pipeList :: Foldable t => Formatter -> t Lazy.Text -> Lazy.Text
+pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList
+pipeList (Pretty _) = Lazy.Text.concat
+ . fmap (("\n" <> indentSymbol <> "| ") <>)
+ . toList
+
+enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text
+enumValueDefinition (Pretty _) enumValue =
+ let Full.EnumValueDefinition description' name' directives' = enumValue
+ formatter = Pretty 1
+ in description formatter description'
+ <> indentLine formatter
+ <> Lazy.Text.fromStrict name'
+ <> directives formatter directives'
+enumValueDefinition Minified enumValue =
+ let Full.EnumValueDefinition description' name' directives' = enumValue
+ in description Minified description'
+ <> Lazy.Text.fromStrict name'
+ <> directives Minified directives'
+
+description :: Formatter -> Full.Description -> Lazy.Text.Text
+description _formatter (Full.Description Nothing) = ""
+description formatter (Full.Description (Just description')) =
+ stringValue formatter description'
-- | Converts a t'Full.ExecutableDefinition' into a string.
definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
@@ -100,7 +341,7 @@ variableDefinition formatter variableDefinition' =
let Full.VariableDefinition variableName variableType defaultValue' _ =
variableDefinition'
in variable variableName
- <> eitherFormat formatter ": " ":"
+ <> colon formatter
<> type' variableType
<> maybe mempty (defaultValue formatter . Full.node) defaultValue'
@@ -127,20 +368,26 @@ indent :: (Integral a) => a -> Lazy.Text
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
selection :: Formatter -> Full.Selection -> Lazy.Text
-selection formatter = Lazy.Text.append indent' . encodeSelection
+selection formatter = Lazy.Text.append (indentLine formatter')
+ . encodeSelection
where
encodeSelection (Full.FieldSelection fieldSelection) =
- field incrementIndent fieldSelection
+ field formatter' fieldSelection
encodeSelection (Full.InlineFragmentSelection fragmentSelection) =
- inlineFragment incrementIndent fragmentSelection
+ inlineFragment formatter' fragmentSelection
encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =
- fragmentSpread incrementIndent fragmentSelection
- incrementIndent
- | Pretty indentation <- formatter = Pretty $ indentation + 1
- | otherwise = Minified
- indent'
- | Pretty indentation <- formatter = indent $ indentation + 1
- | otherwise = ""
+ fragmentSpread formatter' fragmentSelection
+ formatter' = incrementIndent formatter
+
+indentLine :: Formatter -> Lazy.Text
+indentLine formatter
+ | Pretty indentation <- formatter = indent indentation
+ | otherwise = ""
+
+incrementIndent :: Formatter -> Formatter
+incrementIndent formatter
+ | Pretty indentation <- formatter = Pretty $ indentation + 1
+ | otherwise = Minified
colon :: Formatter -> Lazy.Text
colon formatter = eitherFormat formatter ": " ":"
@@ -198,8 +445,10 @@ directive formatter (Full.Directive name args _)
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
directives :: Formatter -> [Full.Directive] -> Lazy.Text
-directives Minified = spaces (directive Minified)
-directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
+directives Minified values = spaces (directive Minified) values
+directives formatter values
+ | null values = ""
+ | otherwise = Lazy.Text.cons ' ' $ spaces (directive formatter) values
-- | Converts a 'Full.Value' into a string.
value :: Formatter -> Full.Value -> Lazy.Text
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 5ceb616..bbacdd2 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -39,6 +39,7 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
+import qualified Data.Vector as Vector
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (cast)
@@ -466,12 +467,12 @@ completeValue :: (MonadCatch m, Serialize a)
completeValue (Out.isNonNullType -> False) _ _ Type.Null =
pure null
completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)
- = foldM go (0, []) list >>= coerceResult outputType . List . snd
+ = foldM go Vector.empty list >>= coerceResult outputType . List . Vector.toList
where
- go (index, accumulator) listItem = do
- let updatedPath = Index index : errorPath
- completedValue <- completeValue listType fields updatedPath listItem
- pure (index + 1, completedValue : accumulator)
+ go accumulator listItem =
+ let updatedPath = Index (Vector.length accumulator) : errorPath
+ in Vector.snoc accumulator
+ <$> completeValue listType fields updatedPath listItem
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
coerceResult outputType $ Int int
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
index 4725d74..54fc1c1 100644
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@@ -5,14 +5,8 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE CPP #-}
-- | Types and functions used for input and result coercion.
---
--- JSON instances in this module are only available with the __json__
--- flag that is currently on by default, but will be disabled in the future.
--- Refer to the documentation in the 'Language.GraphQL' module and to
--- the __graphql-spice__ package.
module Language.GraphQL.Execute.Coerce
( Output(..)
, Serialize(..)
@@ -21,10 +15,6 @@ module Language.GraphQL.Execute.Coerce
, matchFieldValues
) where
-#ifdef WITH_JSON
-import qualified Data.Aeson as Aeson
-import Data.Scientific (toBoundedInteger, toRealFloat)
-#endif
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
@@ -232,69 +222,3 @@ instance Serialize Type.Value where
$ HashMap.fromList
$ OrderedMap.toList object
serialize _ _ = Nothing
-
-#ifdef WITH_JSON
-instance Serialize Aeson.Value where
- serialize (Out.ScalarBaseType scalarType) value
- | Type.ScalarType "Int" _ <- scalarType
- , Int int <- value = Just $ Aeson.toJSON int
- | Type.ScalarType "Float" _ <- scalarType
- , Float float <- value = Just $ Aeson.toJSON float
- | Type.ScalarType "String" _ <- scalarType
- , String string <- value = Just $ Aeson.String string
- | Type.ScalarType "ID" _ <- scalarType
- , String string <- value = Just $ Aeson.String string
- | Type.ScalarType "Boolean" _ <- scalarType
- , Boolean boolean <- value = Just $ Aeson.Bool boolean
- serialize _ (Enum enum) = Just $ Aeson.String enum
- serialize _ (List list) = Just $ Aeson.toJSON list
- serialize _ (Object object) = Just
- $ Aeson.object
- $ OrderedMap.toList
- $ Aeson.toJSON <$> object
- serialize _ _ = Nothing
- null = Aeson.Null
-
-instance VariableValue Aeson.Value where
- coerceVariableValue _ Aeson.Null = Just Type.Null
- coerceVariableValue (In.ScalarBaseType scalarType) value
- | (Aeson.String stringValue) <- value = Just $ Type.String stringValue
- | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
- | (Aeson.Number numberValue) <- value
- , (Type.ScalarType "Float" _) <- scalarType =
- Just $ Type.Float $ toRealFloat numberValue
- | (Aeson.Number numberValue) <- value = -- ID or Int
- Type.Int <$> toBoundedInteger numberValue
- coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
- Just $ Type.Enum stringValue
- coerceVariableValue (In.InputObjectBaseType objectType) value
- | (Aeson.Object objectValue) <- value = do
- let (In.InputObjectType _ _ inputFields) = objectType
- (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
- if HashMap.null newObjectValue
- then Just $ Type.Object resultMap
- else Nothing
- where
- foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
- $ Just (objectValue, HashMap.empty)
- matchFieldValues' _ _ Nothing = Nothing
- matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
- let (In.InputField _ fieldType _) = inputField
- insert = flip (HashMap.insert fieldName) resultMap
- newObjectValue = HashMap.delete fieldName objectValue
- in case HashMap.lookup fieldName objectValue of
- Just variableValue -> do
- coerced <- coerceVariableValue fieldType variableValue
- pure (newObjectValue, insert coerced)
- Nothing -> Just (objectValue, resultMap)
- coerceVariableValue (In.ListBaseType listType) value
- | (Aeson.Array arrayValue) <- value =
- Type.List <$> foldr foldVector (Just []) arrayValue
- | otherwise = coerceVariableValue listType value
- where
- foldVector _ Nothing = Nothing
- foldVector variableValue (Just list) = do
- coerced <- coerceVariableValue listType variableValue
- pure $ coerced : list
- coerceVariableValue _ _ = Nothing
-#endif
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 09:35:40 +0000