aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/AST.hs40
-rw-r--r--src/Language/GraphQL/AST/Core.hs24
-rw-r--r--src/Language/GraphQL/AST/Transform.hs72
-rw-r--r--src/Language/GraphQL/Encoder.hs16
-rw-r--r--src/Language/GraphQL/Error.hs2
-rw-r--r--src/Language/GraphQL/Parser.hs8
-rw-r--r--src/Language/GraphQL/Schema.hs41
-rw-r--r--src/Language/GraphQL/Trans.hs1
8 files changed, 125 insertions, 79 deletions
diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs
index 8f40c10..6794ae3 100644
--- a/src/Language/GraphQL/AST.hs
+++ b/src/Language/GraphQL/AST.hs
@@ -35,6 +35,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Language.GraphQL.AST.Core ( Alias
, Name
+ , TypeCondition
)
-- * Document
@@ -45,18 +46,20 @@ type Document = NonEmpty Definition
-- * Operations
-- | Top-level definition of a document, either an operation or a fragment.
-data Definition = DefinitionOperation OperationDefinition
- | DefinitionFragment FragmentDefinition
- deriving (Eq, Show)
+data Definition
+ = DefinitionOperation OperationDefinition
+ | DefinitionFragment FragmentDefinition
+ deriving (Eq, Show)
-- | Operation definition.
-data OperationDefinition = OperationSelectionSet SelectionSet
- | OperationDefinition OperationType
- (Maybe Name)
- VariableDefinitions
- Directives
- SelectionSet
- deriving (Eq, Show)
+data OperationDefinition
+ = OperationSelectionSet SelectionSet
+ | OperationDefinition OperationType
+ (Maybe Name)
+ [VariableDefinition]
+ [Directive]
+ SelectionSet
+ deriving (Eq, Show)
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
--
@@ -68,11 +71,12 @@ data OperationType = Query | Mutation deriving (Eq, Show)
-- | "Top-level" selection, selection on a operation.
type SelectionSet = NonEmpty Selection
+-- | Field selection.
type SelectionSetOpt = [Selection]
-- | Single selection element.
data Selection
- = SelectionField Field
+ = SelectionField Field
| SelectionFragmentSpread FragmentSpread
| SelectionInlineFragment InlineFragment
deriving (Eq, Show)
@@ -81,12 +85,13 @@ data Selection
-- | GraphQL field.
data Field
- = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
+ = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
deriving (Eq, Show)
-- * Arguments
-- | Argument list.
+{-# DEPRECATED Arguments "Use [Argument] instead" #-}
type Arguments = [Argument]
-- | Argument.
@@ -95,23 +100,20 @@ data Argument = Argument Name Value deriving (Eq,Show)
-- * Fragments
-- | Fragment spread.
-data FragmentSpread = FragmentSpread Name Directives deriving (Eq, Show)
+data FragmentSpread = FragmentSpread Name [Directive] deriving (Eq, Show)
-- | Inline fragment.
-data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
+data InlineFragment = InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
deriving (Eq, Show)
-- | Fragment definition.
data FragmentDefinition
- = FragmentDefinition Name TypeCondition Directives SelectionSet
+ = FragmentDefinition Name TypeCondition [Directive] SelectionSet
deriving (Eq, Show)
{-# DEPRECATED FragmentName "Use Name instead" #-}
type FragmentName = Name
--- | Type condition.
-type TypeCondition = Name
-
-- * Input values
-- | Input value.
@@ -134,6 +136,7 @@ data ObjectField = ObjectField Name Value deriving (Eq, Show)
-- * Variables
-- | Variable definition list.
+{-# DEPRECATED VariableDefinitions "Use [VariableDefinition] instead" #-}
type VariableDefinitions = [VariableDefinition]
-- | Variable definition.
@@ -157,6 +160,7 @@ data NonNullType = NonNullTypeNamed Name
-- * Directives
-- | Directive list.
+{-# DEPRECATED Directives "Use [Directive] instead" #-}
type Directives = [Directive]
-- | Directive.
diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs
index 977153f..a2a53be 100644
--- a/src/Language/GraphQL/AST/Core.hs
+++ b/src/Language/GraphQL/AST/Core.hs
@@ -4,16 +4,18 @@ module Language.GraphQL.AST.Core
, Argument(..)
, Document
, Field(..)
+ , Fragment(..)
, Name
, ObjectField(..)
, Operation(..)
+ , Selection(..)
+ , TypeCondition
, Value(..)
) where
import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty)
import Data.String
-
import Data.Text (Text)
-- | Name
@@ -26,8 +28,8 @@ type Document = NonEmpty Operation
--
-- Currently only queries and mutations are supported.
data Operation
- = Query (Maybe Text) (NonEmpty Field)
- | Mutation (Maybe Text) (NonEmpty Field)
+ = Query (Maybe Text) (NonEmpty Selection)
+ | Mutation (Maybe Text) (NonEmpty Selection)
deriving (Eq, Show)
-- | A single GraphQL field.
@@ -51,7 +53,7 @@ data Operation
-- * "zuck" is an alias for "user". "id" and "name" have no aliases.
-- * "id: 4" is an argument for "name". "id" and "name don't have any
-- arguments.
-data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq, Show)
+data Field = Field (Maybe Alias) Name [Argument] [Selection] deriving (Eq, Show)
-- | Alternative field name.
--
@@ -100,3 +102,17 @@ instance IsString Value where
--
-- A list of 'ObjectField's represents a GraphQL object type.
data ObjectField = ObjectField Name Value deriving (Eq, Show)
+
+-- | Type condition.
+type TypeCondition = Name
+
+-- | Represents fragments and inline fragments.
+data Fragment
+ = Fragment TypeCondition (NonEmpty Selection)
+ deriving (Eq, Show)
+
+-- | Single selection element.
+data Selection
+ = SelectionFragment Fragment
+ | SelectionField Field
+ deriving (Eq, Show)
diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs
index 99e0f3e..3aa31b0 100644
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/src/Language/GraphQL/AST/Transform.hs
@@ -1,21 +1,25 @@
{-# LANGUAGE OverloadedStrings #-}
+
+-- | 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
( document
) where
import Control.Applicative (empty)
-import Control.Monad ((<=<))
import Data.Bifunctor (first)
import Data.Either (partitionEithers)
import Data.Foldable (fold, foldMap)
+import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Monoid (Alt(Alt,getAlt), (<>))
import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.AST.Core as Core
import qualified Language.GraphQL.Schema as Schema
--- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an
--- empty list is returned.
+-- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't
+-- match an empty list is returned.
type Fragmenter = Core.Name -> [Core.Field]
-- | Rewrites the original syntax tree into an intermediate representation used
@@ -40,34 +44,38 @@ operations
-> Fragmenter
-> [Full.OperationDefinition]
-> Maybe Core.Document
-operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
+operations subs fr = NonEmpty.nonEmpty . fmap (operation subs fr)
operation
:: Schema.Subs
-> Fragmenter
-> Full.OperationDefinition
- -> Maybe Core.Operation
+ -> Core.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 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
+operation subs fr (Full.OperationDefinition Full.Query name _vars _dirs sels) =
+ Core.Query name $ appendSelection subs fr sels
+operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
+ Core.Mutation name $ appendSelection subs fr sels
selection
:: Schema.Subs
-> Fragmenter
-> Full.Selection
- -> Either [Core.Field] Core.Field
-selection subs fr (Full.SelectionField fld) =
- Right $ field subs fr fld
-selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
- Left $ fr n
-selection _ _ (Full.SelectionInlineFragment _) =
- error "Inline fragments not supported yet"
+ -> Either [Core.Selection] Core.Selection
+selection subs fr (Full.SelectionField fld)
+ = Right $ Core.SelectionField $ field subs fr fld
+selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
+ = Left $ Core.SelectionField <$> fr name
+selection subs fr (Full.SelectionInlineFragment fragment)
+ | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
+ = Right
+ $ Core.SelectionFragment
+ $ Core.Fragment typeCondition
+ $ appendSelection subs fr selectionSet
+ | (Full.InlineFragment Nothing _ selectionSet) <- fragment
+ = Left $ NonEmpty.toList $ appendSelection subs fr selectionSet
-- * Fragment replacement
@@ -83,19 +91,22 @@ defrag subs (Full.DefinitionFragment fragDef) =
Left $ fragmentDefinition subs fragDef
fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter
-fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' =
- -- TODO: Support fragments within fragments. Fold instead of map.
- if name == name'
- then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels)
- else empty
+fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name'
+ | name == name' = selection' <$> do
+ selections <- NonEmpty.toList $ selection subs mempty <$> sels
+ either id pure selections
+ | otherwise = empty
+ where
+ selection' (Core.SelectionField field') = field'
+ selection' _ = error "Fragments within fragments are not supported yet"
field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
field subs fr (Full.Field a n args _dirs sels) =
Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
where
- go :: Full.Selection -> [Core.Field] -> [Core.Field]
- go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>)
- go sel = (either id pure (selection subs fr sel) <>)
+ go :: Full.Selection -> [Core.Selection] -> [Core.Selection]
+ go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> fr name) <>)
+ go sel = (either id pure (selection subs fr sel) <>)
argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
@@ -116,5 +127,10 @@ value subs (Full.ValueObject o) =
objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField
objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v
-hush :: Either a b -> Maybe b
-hush = either (const Nothing) Just
+appendSelection ::
+ Schema.Subs ->
+ Fragmenter ->
+ NonEmpty Full.Selection ->
+ NonEmpty Core.Selection
+appendSelection subs fr = NonEmpty.fromList
+ . foldr (either (++) (:) . selection subs fr) []
diff --git a/src/Language/GraphQL/Encoder.hs b/src/Language/GraphQL/Encoder.hs
index 11115b1..b3ec655 100644
--- a/src/Language/GraphQL/Encoder.hs
+++ b/src/Language/GraphQL/Encoder.hs
@@ -31,11 +31,11 @@ data Formatter
= Minified
| Pretty Word
--- Constructs a formatter for pretty printing.
+-- | Constructs a formatter for pretty printing.
pretty :: Formatter
pretty = Pretty 0
--- Constructs a formatter for minifying.
+-- | Constructs a formatter for minifying.
minified :: Formatter
minified = Minified
@@ -67,11 +67,11 @@ operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)
= "mutation " <> node formatter name vars dirs sels
node :: Formatter
- -> Maybe Name
- -> VariableDefinitions
- -> Directives
- -> SelectionSet
- -> Text
+ -> Maybe Name
+ -> [VariableDefinition]
+ -> [Directive]
+ -> SelectionSet
+ -> Text
node formatter name vars dirs sels
= Text.Lazy.fromStrict (fold name)
<> optempty (variableDefinitions formatter) vars
@@ -170,7 +170,7 @@ directive :: Formatter -> Directive -> Text
directive formatter (Directive name args)
= "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args
-directives :: Formatter -> Directives -> Text
+directives :: Formatter -> [Directive] -> Text
directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)
directives Minified = spaces (directive Minified)
diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs
index d0bc84d..41a2a9c 100644
--- a/src/Language/GraphQL/Error.hs
+++ b/src/Language/GraphQL/Error.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+
+-- | Error handling.
module Language.GraphQL.Error
( parseError
, CollectErrsT
diff --git a/src/Language/GraphQL/Parser.hs b/src/Language/GraphQL/Parser.hs
index 5ae71b2..bbe1de7 100644
--- a/src/Language/GraphQL/Parser.hs
+++ b/src/Language/GraphQL/Parser.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+
+-- | @GraphQL@ document parser.
module Language.GraphQL.Parser
( document
) where
@@ -67,7 +69,7 @@ alias = try $ name <* colon
-- * Arguments
-arguments :: Parser Arguments
+arguments :: Parser [Argument]
arguments = parens $ some argument
argument :: Parser Argument
@@ -133,7 +135,7 @@ objectField = ObjectField <$> name <* symbol ":" <*> value
-- * Variables
-variableDefinitions :: Parser VariableDefinitions
+variableDefinitions :: Parser [VariableDefinition]
variableDefinitions = parens $ some variableDefinition
variableDefinition :: Parser VariableDefinition
@@ -162,7 +164,7 @@ nonNullType = NonNullTypeNamed <$> name <* bang
-- * Directives
-directives :: Parser Directives
+directives :: Parser [Directive]
directives = some directive
directive :: Parser Directive
diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index 428b80e..112847f 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/src/Language/GraphQL/Schema.hs
@@ -28,9 +28,7 @@ module Language.GraphQL.Schema
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
-import Data.Foldable ( find
- , fold
- )
+import Data.Foldable (find, fold)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe)
import qualified Data.Aeson as Aeson
@@ -48,16 +46,13 @@ import Language.GraphQL.AST.Core
-- @m@ is usually expected to be an instance of 'MonadIO'.
type Schema m = NonEmpty (Resolver m)
--- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
--- (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO.
+-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
+-- information (if an error has occurred). @m@ is usually expected to be an
+-- instance of 'MonadIO'.
data Resolver m = Resolver
Text -- ^ Name
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
-type Fields = [Field]
-
-type Arguments = [Argument]
-
-- | Variable substitution function.
type Subs = Name -> Maybe Value
@@ -67,14 +62,14 @@ object name = objectA name . const
-- | Like 'object' but also taking 'Argument's.
objectA :: MonadIO m
- => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
+ => Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
objectA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
wrappedObjectA :: MonadIO m
- => Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m
+ => Name -> ([Argument] -> ActionT m (Wrapping [Resolver m])) -> Resolver m
wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ sels) resolver
@@ -91,14 +86,14 @@ scalar name = scalarA name . const
-- | Like 'scalar' but also taking 'Argument's.
scalarA :: (MonadIO m, Aeson.ToJSON a)
- => Name -> (Arguments -> ActionT m a) -> Resolver m
+ => Name -> ([Argument] -> ActionT m a) -> Resolver m
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld result = withField (return result) fld
-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
- => Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
+ => Name -> ([Argument] -> ActionT m (Wrapping a)) -> Resolver m
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld (Named result) = withField (return result) fld
@@ -116,14 +111,14 @@ enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
enum name = enumA name . const
{-# DEPRECATED enumA "Use scalarA instead" #-}
-enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
+enumA :: MonadIO m => Name -> ([Argument] -> ActionT m [Text]) -> Resolver m
enumA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld resolver = withField (return resolver) fld
{-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-}
wrappedEnumA :: MonadIO m
- => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
+ => Name -> ([Argument] -> ActionT m (Wrapping [Text])) -> Resolver m
wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld (Named resolver) = withField (return resolver) fld
@@ -158,11 +153,21 @@ withField v fld
-- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information.
resolve :: MonadIO m
- => [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
+ => [Resolver m] -> [Selection] -> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where
- tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
- compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
+ resolveTypeName (Resolver "__typename" f) = do
+ value <- f $ Field Nothing "__typename" mempty mempty
+ return $ HashMap.lookupDefault "" "__typename" value
+ resolveTypeName _ = return ""
+ 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
+ then fmap fold . traverse tryResolvers $ selections'
+ else return mempty
+ compareResolvers name (Resolver name' _) = name == name'
tryResolver fld (Resolver _ resolver) = resolver fld
errmsg fld@(Field _ name _ _) = do
addErrMsg $ T.unwords ["field", name, "not resolved."]
diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs
index d92aea7..eb78911 100644
--- a/src/Language/GraphQL/Trans.hs
+++ b/src/Language/GraphQL/Trans.hs
@@ -1,3 +1,4 @@
+-- | Monad transformer stack used by the @GraphQL@ resolvers.
module Language.GraphQL.Trans
( ActionT(..)
) where
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:51:36 +0000