aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/AST/Core.hs4
-rw-r--r--src/Language/GraphQL/AST/Transform.hs9
-rw-r--r--src/Language/GraphQL/Encoder.hs367
-rw-r--r--src/Language/GraphQL/Execute.hs50
4 files changed, 278 insertions, 152 deletions
diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs
index 00072e0..87dced9 100644
--- a/src/Language/GraphQL/AST/Core.hs
+++ b/src/Language/GraphQL/AST/Core.hs
@@ -21,8 +21,8 @@ type Name = Text
type Document = NonEmpty Operation
-data Operation = Query (NonEmpty Field)
- | Mutation (NonEmpty Field)
+data Operation = Query (Maybe Text) (NonEmpty Field)
+ | Mutation (Maybe Text) (NonEmpty Field)
deriving (Eq,Show)
data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)
diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs
index 64670db..63a2c72 100644
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/src/Language/GraphQL/AST/Transform.hs
@@ -41,7 +41,6 @@ operations
-> Maybe Core.Document
operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
--- TODO: Replace Maybe by MonadThrow CustomError
operation
:: Schema.Subs
-> Fragmenter
@@ -50,10 +49,10 @@ operation
operation subs fr (Full.OperationSelectionSet sels) =
operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
-- TODO: Validate Variable definitions with substituter
-operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) =
- case ot of
- Full.Query -> Core.Query <$> node
- Full.Mutation -> Core.Mutation <$> node
+operation subs fr (Full.OperationDefinition operationType name _vars _dirs sels)
+ = case operationType of
+ Full.Query -> Core.Query name <$> node
+ Full.Mutation -> Core.Mutation name <$> node
where
node = traverse (hush . selection subs fr) sels
diff --git a/src/Language/GraphQL/Encoder.hs b/src/Language/GraphQL/Encoder.hs
index c315091..11115b1 100644
--- a/src/Language/GraphQL/Encoder.hs
+++ b/src/Language/GraphQL/Encoder.hs
@@ -1,156 +1,238 @@
{-# LANGUAGE OverloadedStrings #-}
--- | This module defines a printer for the @GraphQL@ language.
+{-# LANGUAGE ExplicitForAll #-}
+
+-- | This module defines a minifier and a printer for the @GraphQL@ language.
module Language.GraphQL.Encoder
- ( document
- , spaced
+ ( 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 (Text, cons, intercalate, pack, snoc)
+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
--- * Document
-
-document :: Document -> Text
-document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs
-
-definition :: Definition -> Text
-definition (DefinitionOperation x) = operationDefinition x
-definition (DefinitionFragment x) = fragmentDefinition x
-
-operationDefinition :: OperationDefinition -> Text
-operationDefinition (OperationSelectionSet sels) = selectionSet sels
-operationDefinition (OperationDefinition Query name vars dirs sels) =
- "query " <> node (fold name) vars dirs sels
-operationDefinition (OperationDefinition Mutation name vars dirs sels) =
- "mutation " <> node (fold name) vars dirs sels
-
-node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
-node name vars dirs sels =
- name
- <> optempty variableDefinitions vars
- <> optempty directives dirs
- <> selectionSet sels
-
-variableDefinitions :: [VariableDefinition] -> Text
-variableDefinitions = parensCommas variableDefinition
-
-variableDefinition :: VariableDefinition -> Text
-variableDefinition (VariableDefinition var ty dv) =
- variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
-
-defaultValue :: Value -> Text
-defaultValue val = "=" <> value val
+-- | 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
+ -> VariableDefinitions
+ -> Directives
+ -> 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 = "$" <> var
-
-selectionSet :: SelectionSet -> Text
-selectionSet = bracesCommas selection . NonEmpty.toList
-
-selectionSetOpt :: SelectionSetOpt -> Text
-selectionSetOpt = bracesCommas selection
-
-selection :: Selection -> Text
-selection (SelectionField x) = field x
-selection (SelectionInlineFragment x) = inlineFragment x
-selection (SelectionFragmentSpread x) = fragmentSpread x
-
-field :: Field -> Text
-field (Field alias name args dirs selso) =
- optempty (`snoc` ':') (fold alias)
- <> name
- <> optempty arguments args
- <> optempty directives dirs
- <> optempty selectionSetOpt selso
-
-arguments :: [Argument] -> Text
-arguments = parensCommas argument
-
-argument :: Argument -> Text
-argument (Argument name v) = name <> ":" <> value v
+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 :: FragmentSpread -> Text
-fragmentSpread (FragmentSpread name ds) =
- "..." <> name <> optempty directives ds
-
-inlineFragment :: InlineFragment -> Text
-inlineFragment (InlineFragment tc dirs sels) =
- "... on " <> fold tc
- <> directives dirs
- <> selectionSet sels
-
-fragmentDefinition :: FragmentDefinition -> Text
-fragmentDefinition (FragmentDefinition name tc dirs sels) =
- "fragment " <> name <> " on " <> tc
- <> optempty directives dirs
- <> selectionSet sels
-
--- * Values
-
-value :: Value -> Text
-value (ValueVariable x) = variable x
--- TODO: This will be replaced with `decimal` Builder
-value (ValueInt x) = pack $ show x
--- TODO: This will be replaced with `decimal` Builder
-value (ValueFloat x) = pack $ show x
-value (ValueBoolean x) = booleanValue x
-value ValueNull = mempty
-value (ValueString x) = stringValue x
-value (ValueEnum x) = x
-value (ValueList x) = listValue x
-value (ValueObject x) = objectValue x
+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 -> Directives -> 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"
--- TODO: Escape characters
stringValue :: Text -> Text
-stringValue = quotes
-
-listValue :: [Value] -> Text
-listValue = bracketsCommas value
-
-objectValue :: [ObjectField] -> Text
-objectValue = bracesCommas objectField
-
-objectField :: ObjectField -> Text
-objectField (ObjectField name v) = name <> ":" <> value v
-
--- * Directives
-
-directives :: [Directive] -> Text
-directives = spaces directive
-
-directive :: Directive -> Text
-directive (Directive name args) = "@" <> name <> optempty arguments args
-
--- * Type Reference
-
-type_ :: Type -> Text
-type_ (TypeNamed x) = x
-type_ (TypeList x) = listType x
-type_ (TypeNonNull x) = nonNullType x
+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)
+listType x = brackets (type' x)
nonNullType :: NonNullType -> Text
-nonNullType (NonNullTypeNamed x) = x <> "!"
+nonNullType (NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"
nonNullType (NonNullTypeList x) = listType x <> "!"
-- * Internal
-spaced :: Text -> Text
-spaced = cons '\SP'
-
between :: Char -> Char -> Text -> Text
-between open close = cons open . (`snoc` close)
+between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close)
parens :: Text -> Text
parens = between '(' ')'
@@ -164,17 +246,32 @@ braces = between '{' '}'
quotes :: Text -> Text
quotes = between '"' '"'
-spaces :: (a -> Text) -> [a] -> Text
-spaces f = intercalate "\SP" . fmap f
-
-parensCommas :: (a -> Text) -> [a] -> Text
-parensCommas f = parens . intercalate "," . fmap f
-
-bracketsCommas :: (a -> Text) -> [a] -> Text
-bracketsCommas f = brackets . intercalate "," . fmap f
-
-bracesCommas :: (a -> Text) -> [a] -> Text
-bracesCommas f = braces . intercalate "," . fmap f
+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
index 9dbfb36..5a815b8 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -4,12 +4,15 @@
-- according to a 'Schema'.
module Language.GraphQL.Execute
( execute
+ , executeWithName
) where
import Control.Monad.IO.Class (MonadIO)
+import qualified Data.Aeson as Aeson
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty((:|)))
-import qualified Data.Aeson as Aeson
+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
@@ -23,20 +26,47 @@ import qualified Language.GraphQL.Schema as Schema
--
-- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
-- errors wrapped in an /errors/ field.
-execute
- :: MonadIO m
- => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value
+execute :: MonadIO m
+ => Schema m
+ -> Schema.Subs
+ -> AST.Document
+ -> m Aeson.Value
execute schema subs doc =
- maybe transformError (document schema) $ Transform.document subs doc
+ maybe transformError (document schema Nothing) $ Transform.document subs doc
+ where
+ transformError = return $ singleError "Schema transformation error."
+
+-- | Takes a 'Schema', operation name, a variable substitution function ('Schema.Subs'),
+-- and a @GraphQL@ 'document'. The substitution is applied to the document using
+-- 'rootFields', and the 'Schema''s resolvers are applied to the resulting fields.
+--
+-- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
+-- errors wrapped in an /errors/ field.
+executeWithName :: MonadIO m
+ => Schema m
+ -> Text
+ -> Schema.Subs
+ -> AST.Document
+ -> m Aeson.Value
+executeWithName schema name subs doc =
+ maybe transformError (document schema $ Just name) $ Transform.document subs doc
where
transformError = return $ singleError "Schema transformation error."
-document :: MonadIO m => Schema m -> AST.Core.Document -> m Aeson.Value
-document schema (op :| []) = operation schema op
-document _ _ = return $ singleError "Multiple operations not supported yet."
+document :: MonadIO m => Schema m -> Maybe Text -> AST.Core.Document -> m Aeson.Value
+document schema Nothing (op :| []) = operation schema op
+document schema (Just name) operations = case NE.dropWhile matchingName operations of
+ [] -> return $ singleError
+ $ Text.unwords ["Operation", name, "couldn't be found in the document."]
+ (op:_) -> operation schema op
+ where
+ matchingName (AST.Core.Query (Just name') _) = name == name'
+ matchingName (AST.Core.Mutation (Just name') _) = name == name'
+ matchingName _ = False
+document _ _ _ = return $ singleError "Missing operation name."
operation :: MonadIO m => Schema m -> AST.Core.Operation -> m Aeson.Value
-operation schema (AST.Core.Query flds)
+operation schema (AST.Core.Query _ flds)
= runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
-operation schema (AST.Core.Mutation flds)
+operation schema (AST.Core.Mutation _ flds)
= runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:51:21 +0000