summaryrefslogtreecommitdiff
path: root/src/Language/GraphQL/Execute
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL/Execute')
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs253
-rw-r--r--src/Language/GraphQL/Execute/Subscribe.hs113
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs610
3 files changed, 252 insertions, 724 deletions
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
deleted file mode 100644
index 9ad4439..0000000
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ /dev/null
@@ -1,253 +0,0 @@
-{-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module Language.GraphQL.Execute.Execution
- ( coerceArgumentValues
- , collectFields
- , executeSelectionSet
- ) where
-
-import Control.Monad.Catch (Exception(..), MonadCatch(..))
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Reader (runReaderT)
-import Control.Monad.Trans.State (gets)
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Maybe (fromMaybe)
-import Data.Sequence (Seq(..))
-import qualified Data.Text as Text
-import qualified Language.GraphQL.AST as Full
-import Language.GraphQL.Error
-import Language.GraphQL.Execute.Coerce
-import Language.GraphQL.Execute.Internal
-import Language.GraphQL.Execute.OrderedMap (OrderedMap)
-import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
-import qualified Language.GraphQL.Execute.Transform as Transform
-import qualified Language.GraphQL.Type as Type
-import qualified Language.GraphQL.Type.In as In
-import qualified Language.GraphQL.Type.Out as Out
-import qualified Language.GraphQL.Type.Internal as Internal
-import Prelude hiding (null)
-
-resolveFieldValue :: MonadCatch m
- => Type.Value
- -> Type.Subs
- -> Type.Resolve m
- -> Full.Location
- -> CollectErrsT m Type.Value
-resolveFieldValue result args resolver location' =
- catch (lift $ runReaderT resolver context) handleFieldError
- where
- handleFieldError :: MonadCatch m
- => ResolverException
- -> CollectErrsT m Type.Value
- handleFieldError e
- = addError Type.Null
- $ Error (Text.pack $ displayException e) [location'] []
- context = Type.Context
- { Type.arguments = Type.Arguments args
- , Type.values = result
- }
-
-collectFields :: Monad m
- => Out.ObjectType m
- -> Seq (Transform.Selection m)
- -> OrderedMap (NonEmpty (Transform.Field m))
-collectFields objectType = foldl forEach OrderedMap.empty
- where
- forEach groupedFields (Transform.SelectionField field) =
- let responseKey = aliasOrName field
- in OrderedMap.insert responseKey (field :| []) groupedFields
- forEach groupedFields (Transform.SelectionFragment selectionFragment)
- | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
- , Internal.doesFragmentTypeApply fragmentType objectType =
- let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
- in groupedFields <> fragmentGroupedFieldSet
- | otherwise = groupedFields
-
-aliasOrName :: forall m. Transform.Field m -> Full.Name
-aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias
-
-resolveAbstractType :: Monad m
- => Internal.AbstractType m
- -> Type.Subs
- -> CollectErrsT m (Maybe (Out.ObjectType m))
-resolveAbstractType abstractType values'
- | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
- types' <- gets types
- case HashMap.lookup typeName types' of
- Just (Internal.ObjectType objectType) ->
- if Internal.instanceOf objectType abstractType
- then pure $ Just objectType
- else pure Nothing
- _ -> pure Nothing
- | otherwise = pure Nothing
-
-executeField :: (MonadCatch m, Serialize a)
- => Out.Resolver m
- -> Type.Value
- -> NonEmpty (Transform.Field m)
- -> CollectErrsT m a
-executeField fieldResolver prev fields
- | Out.ValueResolver fieldDefinition resolver <- fieldResolver =
- executeField' fieldDefinition resolver
- | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver =
- executeField' fieldDefinition resolver
- where
- executeField' fieldDefinition resolver = do
- let Out.Field _ fieldType argumentDefinitions = fieldDefinition
- let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields
- case coerceArgumentValues argumentDefinitions arguments' of
- Left [] ->
- let errorMessage = "Not all required arguments are specified."
- in addError null $ Error errorMessage [location'] []
- Left errorLocations -> addError null
- $ Error "Argument coercing failed." errorLocations []
- Right argumentValues -> do
- answer <- resolveFieldValue prev argumentValues resolver location'
- completeValue fieldType fields answer
-
-completeValue :: (MonadCatch m, Serialize a)
- => Out.Type m
- -> NonEmpty (Transform.Field m)
- -> Type.Value
- -> CollectErrsT m a
-completeValue (Out.isNonNullType -> False) _ Type.Null = pure null
-completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)
- = traverse (completeValue listType fields) list
- >>= coerceResult outputType (firstFieldLocation fields) . List
-completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) =
- coerceResult outputType (firstFieldLocation fields) $ Int int
-completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) =
- coerceResult outputType (firstFieldLocation fields) $ Boolean boolean
-completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) =
- coerceResult outputType (firstFieldLocation fields) $ Float float
-completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) =
- coerceResult outputType (firstFieldLocation fields) $ String string
-completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) =
- let Type.EnumType _ _ enumMembers = enumType
- location = firstFieldLocation fields
- in if HashMap.member enum enumMembers
- then coerceResult outputType location $ Enum enum
- else addError null $ Error "Enum value completion failed." [location] []
-completeValue (Out.ObjectBaseType objectType) fields result
- = executeSelectionSet result objectType (firstFieldLocation fields)
- $ mergeSelectionSets fields
-completeValue (Out.InterfaceBaseType interfaceType) fields result
- | Type.Object objectMap <- result = do
- let abstractType = Internal.AbstractInterfaceType interfaceType
- let location = firstFieldLocation fields
- concreteType <- resolveAbstractType abstractType objectMap
- case concreteType of
- Just objectType -> executeSelectionSet result objectType location
- $ mergeSelectionSets fields
- Nothing -> addError null
- $ Error "Interface value completion failed." [location] []
-completeValue (Out.UnionBaseType unionType) fields result
- | Type.Object objectMap <- result = do
- let abstractType = Internal.AbstractUnionType unionType
- let location = firstFieldLocation fields
- concreteType <- resolveAbstractType abstractType objectMap
- case concreteType of
- Just objectType -> executeSelectionSet result objectType
- location $ mergeSelectionSets fields
- Nothing -> addError null
- $ Error "Union value completion failed." [location] []
-completeValue _ (Transform.Field _ _ _ _ location :| _) _ =
- addError null $ Error "Value completion failed." [location] []
-
-mergeSelectionSets :: MonadCatch m
- => NonEmpty (Transform.Field m)
- -> Seq (Transform.Selection m)
-mergeSelectionSets = foldr forEach mempty
- where
- forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet =
- selectionSet <> fieldSelectionSet
-
-firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location
-firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation
-
-coerceResult :: (MonadCatch m, Serialize a)
- => Out.Type m
- -> Full.Location
- -> Output a
- -> CollectErrsT m a
-coerceResult outputType parentLocation result
- | Just serialized <- serialize outputType result = pure serialized
- | otherwise = addError null
- $ Error "Result coercion failed." [parentLocation] []
-
--- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
--- each field to each 'Transform.Selection'. Resolves into a value containing
--- the resolved 'Transform.Selection', or a null value and error information.
-executeSelectionSet :: (MonadCatch m, Serialize a)
- => Type.Value
- -> Out.ObjectType m
- -> Full.Location
- -> Seq (Transform.Selection m)
- -> CollectErrsT m a
-executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do
- let fields = collectFields objectType selectionSet
- resolvedValues <- OrderedMap.traverseMaybe forEach fields
- coerceResult (Out.NonNullObjectType objectType) objectLocation
- $ Object resolvedValues
- where
- forEach fields@(field :| _) =
- let Transform.Field _ name _ _ _ = field
- in traverse (tryResolver fields) $ lookupResolver name
- lookupResolver = flip HashMap.lookup resolvers
- tryResolver fields resolver =
- executeField resolver result fields >>= lift . pure
-
-coerceArgumentValues
- :: HashMap Full.Name In.Argument
- -> HashMap Full.Name (Full.Node Transform.Input)
- -> Either [Full.Location] Type.Subs
-coerceArgumentValues argumentDefinitions argumentNodes =
- HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions
- where
- forEach argumentName (In.Argument _ variableType defaultValue) = \case
- Right resultMap
- | Just matchedValues
- <- matchFieldValues' argumentName variableType defaultValue $ Just resultMap
- -> Right matchedValues
- | otherwise -> Left $ generateError argumentName []
- Left errorLocations
- | Just _
- <- matchFieldValues' argumentName variableType defaultValue $ pure mempty
- -> Left errorLocations
- | otherwise -> Left $ generateError argumentName errorLocations
- generateError argumentName errorLocations =
- case HashMap.lookup argumentName argumentNodes of
- Just (Full.Node _ errorLocation) -> [errorLocation]
- Nothing -> errorLocations
- matchFieldValues' = matchFieldValues coerceArgumentValue (Full.node <$> argumentNodes)
- coerceArgumentValue inputType (Transform.Int integer) =
- coerceInputLiteral inputType (Type.Int integer)
- coerceArgumentValue inputType (Transform.Boolean boolean) =
- coerceInputLiteral inputType (Type.Boolean boolean)
- coerceArgumentValue inputType (Transform.String string) =
- coerceInputLiteral inputType (Type.String string)
- coerceArgumentValue inputType (Transform.Float float) =
- coerceInputLiteral inputType (Type.Float float)
- coerceArgumentValue inputType (Transform.Enum enum) =
- coerceInputLiteral inputType (Type.Enum enum)
- coerceArgumentValue inputType Transform.Null
- | In.isNonNullType inputType = Nothing
- | otherwise = coerceInputLiteral inputType Type.Null
- coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
- let coerceItem = coerceInputLiteral inputType
- in Type.List <$> traverse coerceItem list
- coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
- | In.InputObjectType _ _ inputFields <- inputType =
- let go = forEachField object
- resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
- in Type.Object <$> resultMap
- coerceArgumentValue _ (Transform.Variable variable) = pure variable
- coerceArgumentValue _ _ = Nothing
- forEachField object variableName (In.InputField _ variableType defaultValue) =
- matchFieldValues coerceArgumentValue object variableName variableType defaultValue
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
deleted file mode 100644
index 5d8d294..0000000
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ /dev/null
@@ -1,113 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
- v. 2.0. If a copy of the MPL was not distributed with this file, You can
- obtain one at https://mozilla.org/MPL/2.0/. -}
-
-{-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Language.GraphQL.Execute.Subscribe
- ( subscribe
- ) where
-
-import Conduit
-import Control.Arrow (left)
-import Control.Monad.Catch (Exception(..), MonadCatch(..))
-import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.Sequence (Seq(..))
-import qualified Language.GraphQL.AST as Full
-import Language.GraphQL.Execute.Coerce
-import Language.GraphQL.Execute.Execution
-import Language.GraphQL.Execute.Internal
-import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
-import qualified Language.GraphQL.Execute.Transform as Transform
-import Language.GraphQL.Error
- ( Error(..)
- , ResolverException
- , Response
- , ResponseEventStream
- , runCollectErrs
- )
-import qualified Language.GraphQL.Type.Definition as Definition
-import qualified Language.GraphQL.Type as Type
-import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Schema
-
-subscribe :: (MonadCatch m, Serialize a)
- => HashMap Full.Name (Type m)
- -> Out.ObjectType m
- -> Full.Location
- -> Seq (Transform.Selection m)
- -> m (Either Error (ResponseEventStream m a))
-subscribe types' objectType objectLocation fields = do
- sourceStream <-
- createSourceEventStream types' objectType objectLocation fields
- let traverser =
- mapSourceToResponseEvent types' objectType objectLocation fields
- traverse traverser sourceStream
-
-mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
- => HashMap Full.Name (Type m)
- -> Out.ObjectType m
- -> Full.Location
- -> Seq (Transform.Selection m)
- -> Out.SourceEventStream m
- -> m (ResponseEventStream m a)
-mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream
- = pure
- $ sourceStream
- .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields)
-
-createSourceEventStream :: MonadCatch m
- => HashMap Full.Name (Type m)
- -> Out.ObjectType m
- -> Full.Location
- -> Seq (Transform.Selection m)
- -> m (Either Error (Out.SourceEventStream m))
-createSourceEventStream _types subscriptionType objectLocation fields
- | [fieldGroup] <- OrderedMap.elems groupedFieldSet
- , Transform.Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup
- , Out.ObjectType _ _ _ fieldTypes <- subscriptionType
- , resolverT <- fieldTypes HashMap.! fieldName
- , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
- , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
- case coerceArgumentValues argumentDefinitions arguments' of
- Left _ -> pure
- $ Left
- $ Error "Argument coercion failed." [errorLocation] []
- Right argumentValues -> left (singleError [errorLocation])
- <$> resolveFieldEventStream Type.Null argumentValues resolver
- | otherwise = pure
- $ Left
- $ Error "Subscription contains more than one field." [objectLocation] []
- where
- groupedFieldSet = collectFields subscriptionType fields
-
-resolveFieldEventStream :: MonadCatch m
- => Type.Value
- -> Type.Subs
- -> Out.Subscribe m
- -> m (Either String (Out.SourceEventStream m))
-resolveFieldEventStream result args resolver =
- catch (Right <$> runReaderT resolver context) handleEventStreamError
- where
- handleEventStreamError :: MonadCatch m
- => ResolverException
- -> m (Either String (Out.SourceEventStream m))
- handleEventStreamError = pure . Left . displayException
- context = Type.Context
- { Type.arguments = Type.Arguments args
- , Type.values = result
- }
-
-executeSubscriptionEvent :: (MonadCatch m, Serialize a)
- => HashMap Full.Name (Type m)
- -> Out.ObjectType m
- -> Full.Location
- -> Seq (Transform.Selection m)
- -> Definition.Value
- -> m (Response a)
-executeSubscriptionEvent types' objectType objectLocation fields initialValue
- = runCollectErrs types'
- $ executeSelectionSet initialValue objectType objectLocation fields
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 117b708..b2bd643 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -6,7 +6,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NamedFieldPuns #-}
-- | After the document is parsed, before getting executed, the AST is
-- transformed into a similar, simpler AST. Performed transformations include:
@@ -21,65 +21,84 @@
-- This module is also responsible for smaller rewrites that touch only parts of
-- the original AST.
module Language.GraphQL.Execute.Transform
- ( Document(..)
- , Field(..)
+ ( Field(..)
, Fragment(..)
, Input(..)
, Operation(..)
- , QueryError(..)
+ , Replacement(..)
, Selection(..)
+ , TransformT(..)
, document
+ , transform
) where
-import Control.Monad (foldM, unless)
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.State (State, evalStateT, gets, modify)
-import Data.Foldable (find)
-import Data.Functor.Identity (Identity(..))
+import Control.Monad (foldM)
+import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Reader (ReaderT(..), local)
+import qualified Control.Monad.Trans.Reader as Reader
+import Data.Bifunctor (first)
+import Data.Functor ((<&>))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HashSet
import Data.Int (Int32)
-import Data.Maybe (fromMaybe)
-import Data.List.NonEmpty (NonEmpty(..))
+import Data.List (intercalate)
import qualified Data.List.NonEmpty as NonEmpty
-import Data.Sequence (Seq, (<|), (><))
+import Data.Maybe (fromMaybe, isJust)
+import Data.Sequence (Seq, (><))
+import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
-import qualified Language.GraphQL.AST as Full
-import Language.GraphQL.AST (Name)
-import qualified Language.GraphQL.Execute.Coerce as Coerce
-import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.AST.Document as Full
+import Language.GraphQL.Type.Schema (Type)
import qualified Language.GraphQL.Type as Type
+import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Internal as Type
-import qualified Language.GraphQL.Type.Out as Out
-import qualified Language.GraphQL.Type.Schema as Schema
+import Numeric (showFloat)
--- | Associates a fragment name with a list of 'Field's.
data Replacement m = Replacement
- { fragments :: HashMap Full.Name (Fragment m)
- , fragmentDefinitions :: FragmentDefinitions
- , variableValues :: Type.Subs
- , types :: HashMap Full.Name (Schema.Type m)
+ { variableValues :: Type.Subs
+ , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+ , visitedFragments :: HashSet Full.Name
+ , types :: HashMap Full.Name (Type m)
}
-type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
+newtype TransformT m a = TransformT
+ { runTransformT :: ReaderT (Replacement m) m a
+ }
--- | Represents fragments and inline fragments.
-data Fragment m
- = Fragment (Type.CompositeType m) (Seq (Selection m))
+instance Functor m => Functor (TransformT m) where
+ fmap f = TransformT . fmap f . runTransformT
--- | Single selection element.
-data Selection m
- = SelectionFragment (Fragment m)
- | SelectionField (Field m)
+instance Applicative m => Applicative (TransformT m) where
+ pure = TransformT . pure
+ TransformT f <*> TransformT x = TransformT $ f <*> x
+
+instance Monad m => Monad (TransformT m) where
+ TransformT x >>= f = TransformT $ x >>= runTransformT . f
+
+instance MonadTrans TransformT where
+ lift = TransformT . lift
+
+instance MonadThrow m => MonadThrow (TransformT m) where
+ throwM = lift . throwM
+
+instance MonadCatch m => MonadCatch (TransformT m) where
+ catch (TransformT stack) handler =
+ TransformT $ catch stack $ runTransformT . handler
+
+asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a
+asks = TransformT . Reader.asks
--- | GraphQL has 3 operation types: queries, mutations and subscribtions.
data Operation m
- = Query (Maybe Text) (Seq (Selection m)) Full.Location
- | Mutation (Maybe Text) (Seq (Selection m)) Full.Location
- | Subscription (Maybe Text) (Seq (Selection m)) Full.Location
+ = Operation Full.OperationType (Seq (Selection m)) Full.Location
+
+data Selection m
+ = FieldSelection (Field m)
+ | FragmentSelection (Fragment m)
--- | Single GraphQL field.
data Field m = Field
(Maybe Full.Name)
Full.Name
@@ -87,339 +106,214 @@ data Field m = Field
(Seq (Selection m))
Full.Location
--- | Contains the operation to be executed along with its root type.
-data Document m = Document
- (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
-
-data OperationDefinition = OperationDefinition
- Full.OperationType
- (Maybe Full.Name)
- [Full.VariableDefinition]
- [Full.Directive]
- Full.SelectionSet
- Full.Location
-
--- | Query error types.
-data QueryError
- = OperationNotFound Text
- | OperationNameRequired
- | CoercionError
- | EmptyDocument
- | UnsupportedRootOperation
-
-instance Show QueryError where
- show (OperationNotFound operationName) = unwords
- ["Operation", Text.unpack operationName, "couldn't be found in the document."]
- show OperationNameRequired = "Missing operation name."
- show CoercionError = "Coercion error."
- show EmptyDocument =
- "The document doesn't contain any executable operations."
- show UnsupportedRootOperation =
- "Root operation type couldn't be found in the schema."
+data Fragment m = Fragment
+ (Type.CompositeType m) (Seq (Selection m)) Full.Location
data Input
- = Int Int32
+ = Variable Type.Value
+ | Int Int32
| Float Double
| String Text
| Boolean Bool
| Null
- | Enum Name
- | List [Type.Value]
- | Object (HashMap Name Input)
- | Variable Type.Value
- deriving (Eq, Show)
-
-getOperation
- :: Maybe Full.Name
- -> NonEmpty OperationDefinition
- -> Either QueryError OperationDefinition
-getOperation Nothing (operation' :| []) = pure operation'
-getOperation Nothing _ = Left OperationNameRequired
-getOperation (Just operationName) operations
- | Just operation' <- find matchingName operations = pure operation'
- | otherwise = Left $ OperationNotFound operationName
- where
- matchingName (OperationDefinition _ name _ _ _ _) =
- name == Just operationName
-
-coerceVariableValues :: Coerce.VariableValue a
- => forall m
- . HashMap Full.Name (Schema.Type m)
- -> OperationDefinition
- -> HashMap.HashMap Full.Name a
- -> Either QueryError Type.Subs
-coerceVariableValues types operationDefinition variableValues =
- let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition
- in maybe (Left CoercionError) Right
- $ foldr forEach (Just HashMap.empty) variableDefinitions
+ | Enum Full.Name
+ | List [Input]
+ | Object (HashMap Full.Name Input)
+ deriving Eq
+
+instance Show Input where
+ showList = mappend . showList'
+ where
+ showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"
+ show (Int integer) = show integer
+ show (Float float') = showFloat float' mempty
+ show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text
+ show (Boolean boolean') = show boolean'
+ show Null = "null"
+ show (Enum name) = Text.unpack name
+ show (List list) = show list
+ show (Object fields) = unwords
+ [ "{"
+ , intercalate ", " (HashMap.foldrWithKey showObject [] fields)
+ , "}"
+ ]
+ where
+ showObject key value accumulator =
+ concat [Text.unpack key, ": ", show value] : accumulator
+ show variableValue = show variableValue
+
+document :: Full.Document
+ -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition)
+document = foldr filterOperation ([], HashMap.empty)
where
- forEach variableDefinition coercedValues = do
- let Full.VariableDefinition variableName variableTypeName defaultValue _ =
- variableDefinition
- let defaultValue' = constValue . Full.node <$> defaultValue
- variableType <- Type.lookupInputType variableTypeName types
-
- Coerce.matchFieldValues
- coerceVariableValue'
- variableValues
- variableName
- variableType
- defaultValue'
- coercedValues
- coerceVariableValue' variableType value'
- = Coerce.coerceVariableValue variableType value'
- >>= Coerce.coerceInputLiteral variableType
-
-constValue :: Full.ConstValue -> Type.Value
-constValue (Full.ConstInt i) = Type.Int i
-constValue (Full.ConstFloat f) = Type.Float f
-constValue (Full.ConstString x) = Type.String x
-constValue (Full.ConstBoolean b) = Type.Boolean b
-constValue Full.ConstNull = Type.Null
-constValue (Full.ConstEnum e) = Type.Enum e
-constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list
-constValue (Full.ConstObject o) =
- Type.Object $ HashMap.fromList $ constObjectField <$> o
+ filterOperation (Full.ExecutableDefinition executableDefinition) accumulator
+ | Full.DefinitionOperation operationDefinition' <- executableDefinition =
+ first (operationDefinition' :) accumulator
+ | Full.DefinitionFragment fragmentDefinition <- executableDefinition
+ , Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition =
+ HashMap.insert fragmentName fragmentDefinition <$> accumulator
+ filterOperation _ accumulator = accumulator -- Type system definitions.
+
+transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)
+transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do
+ transformedSelections <- selectionSet selectionSet'
+ pure $ Operation operationType transformedSelections operationLocation
+transform (Full.SelectionSet selectionSet' operationLocation) = do
+ transformedSelections <- selectionSet selectionSet'
+ pure $ Operation Full.Query transformedSelections operationLocation
+
+selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m))
+selectionSet = selectionSetOpt . NonEmpty.toList
+
+selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m))
+selectionSetOpt = foldM go Seq.empty
where
- constObjectField Full.ObjectField{value = value', ..} =
- (name, constValue $ Full.node value')
-
--- | Rewrites the original syntax tree into an intermediate representation used
--- for query execution.
-document :: Coerce.VariableValue a
- => forall m
- . Type.Schema m
- -> Maybe Full.Name
- -> HashMap Full.Name a
- -> Full.Document
- -> Either QueryError (Document m)
-document schema operationName subs ast = do
- let referencedTypes = Schema.types schema
-
- (operations, fragmentTable) <- defragment ast
- chosenOperation <- getOperation operationName operations
- coercedValues <- coerceVariableValues referencedTypes chosenOperation subs
-
- let replacement = Replacement
- { fragments = HashMap.empty
- , fragmentDefinitions = fragmentTable
- , variableValues = coercedValues
- , types = referencedTypes
- }
- case chosenOperation of
- OperationDefinition Full.Query _ _ _ _ _ ->
- pure $ Document referencedTypes (Schema.query schema)
- $ operation chosenOperation replacement
- OperationDefinition Full.Mutation _ _ _ _ _
- | Just mutationType <- Schema.mutation schema ->
- pure $ Document referencedTypes mutationType
- $ operation chosenOperation replacement
- OperationDefinition Full.Subscription _ _ _ _ _
- | Just subscriptionType <- Schema.subscription schema ->
- pure $ Document referencedTypes subscriptionType
- $ operation chosenOperation replacement
- _ -> Left UnsupportedRootOperation
-
-defragment
- :: Full.Document
- -> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions)
-defragment ast =
- let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast
- nonEmptyOperations = NonEmpty.nonEmpty operations
- emptyDocument = Left EmptyDocument
- in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
+ go accumulatedSelections currentSelection =
+ selection currentSelection <&> (accumulatedSelections ><)
+
+selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m))
+selection (Full.FieldSelection field') =
+ maybeToSelectionSet FieldSelection $ field field'
+selection (Full.FragmentSpreadSelection fragmentSpread') =
+ maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread'
+selection (Full.InlineFragmentSelection inlineFragment') =
+ either id (pure . FragmentSelection) <$> inlineFragment inlineFragment'
+
+maybeToSelectionSet :: Monad m
+ => forall a
+ . (a -> Selection m)
+ -> TransformT m (Maybe a)
+ -> TransformT m (Seq (Selection m))
+maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType)
+
+directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Definition.Directive])
+directives = fmap Type.selection . traverse directive
+
+inlineFragment :: Monad m
+ => Full.InlineFragment
+ -> TransformT m (Either (Seq (Selection m)) (Fragment m))
+inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)
+ | Just typeCondition <- maybeCondition = do
+ transformedSelections <- selectionSet selectionSet'
+ transformedDirectives <- directives directives'
+ maybeFragmentType <- asks
+ $ Type.lookupTypeCondition typeCondition
+ . types
+ pure $ case transformedDirectives >> maybeFragmentType of
+ Just fragmentType -> Right
+ $ Fragment fragmentType transformedSelections location
+ Nothing -> Left Seq.empty
+ | otherwise = do
+ transformedSelections <- selectionSet selectionSet'
+ transformedDirectives <- directives directives'
+ pure $ if isJust transformedDirectives
+ then Left transformedSelections
+ else Left Seq.empty
+
+fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m))
+fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
+ transformedDirectives <- directives directives'
+ visitedFragment <- asks $ HashSet.member spreadName . visitedFragments
+ possibleFragmentDefinition <- asks
+ $ HashMap.lookup spreadName
+ . fragmentDefinitions
+ case transformedDirectives >> possibleFragmentDefinition of
+ Just (Full.FragmentDefinition _ typeCondition _ selections _)
+ | visitedFragment -> pure Nothing
+ | otherwise -> do
+ fragmentType <- asks
+ $ Type.lookupTypeCondition typeCondition
+ . types
+ traverse (traverseSelections selections) fragmentType
+ Nothing -> pure Nothing
where
- defragment' definition (operations, fragments')
- | (Full.ExecutableDefinition executable) <- definition
- , (Full.DefinitionOperation operation') <- executable =
- (transform operation' : operations, fragments')
- | (Full.ExecutableDefinition executable) <- definition
- , (Full.DefinitionFragment fragment) <- executable
- , (Full.FragmentDefinition name _ _ _ _) <- fragment =
- (operations, HashMap.insert name fragment fragments')
- defragment' _ acc = acc
- transform = \case
- Full.OperationDefinition type' name variables directives' selections location ->
- OperationDefinition type' name variables directives' selections location
- Full.SelectionSet selectionSet location ->
- OperationDefinition Full.Query Nothing mempty mempty selectionSet location
-
--- * Operation
-
-operation :: OperationDefinition -> Replacement m -> Operation m
-operation operationDefinition replacement
- = runIdentity
- $ evalStateT (collectFragments >> transform operationDefinition) replacement
+ traverseSelections selections typeCondition = do
+ transformedSelections <- TransformT
+ $ local fragmentInserter
+ $ runTransformT
+ $ selectionSet selections
+ pure $ Fragment typeCondition transformedSelections location
+ fragmentInserter replacement@Replacement{ visitedFragments } = replacement
+ { visitedFragments = HashSet.insert spreadName visitedFragments }
+
+field :: Monad m => Full.Field -> TransformT m (Maybe (Field m))
+field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
+ transformedSelections <- selectionSetOpt selectionSet'
+ transformedDirectives <- directives directives'
+ transformedArguments <- arguments arguments'
+ let transformedField = Field
+ alias'
+ name'
+ transformedArguments
+ transformedSelections
+ location'
+ pure $ transformedDirectives >> pure transformedField
+
+arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input))
+arguments = foldM go HashMap.empty
where
- transform (OperationDefinition Full.Query name _ _ sels location) =
- flip (Query name) location <$> appendSelection sels
- transform (OperationDefinition Full.Mutation name _ _ sels location) =
- flip (Mutation name) location <$> appendSelection sels
- transform (OperationDefinition Full.Subscription name _ _ sels location) =
- flip (Subscription name) location <$> appendSelection sels
-
--- * Selection
-
-selection
- :: Full.Selection
- -> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
-selection (Full.FieldSelection fieldSelection) =
- maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection
-selection (Full.FragmentSpreadSelection fragmentSelection)
- = maybe (Left mempty) (Right . SelectionFragment)
- <$> fragmentSpread fragmentSelection
-selection (Full.InlineFragmentSelection fragmentSelection) =
- inlineFragment fragmentSelection
-
-field :: Full.Field -> State (Replacement m) (Maybe (Field m))
-field (Full.Field alias name arguments' directives' selections location) = do
- fieldArguments <- foldM go HashMap.empty arguments'
- fieldSelections <- appendSelection selections
- fieldDirectives <- Definition.selection <$> directives directives'
- let field' = Field alias name fieldArguments fieldSelections location
- pure $ field' <$ fieldDirectives
+ go accumulator (Full.Argument name' valueNode argumentLocation) = do
+ let replaceLocation = flip Full.Node argumentLocation . Full.node
+ argumentValue <- fmap replaceLocation <$> node valueNode
+ pure $ insertIfGiven name' argumentValue accumulator
+
+directive :: Monad m => Full.Directive -> TransformT m Definition.Directive
+directive (Full.Directive name' arguments' _)
+ = Definition.Directive name'
+ . Type.Arguments
+ <$> foldM go HashMap.empty arguments'
where
- go arguments (Full.Argument name' (Full.Node value' _) location') = do
- objectFieldValue <- input value'
- case objectFieldValue of
- Just fieldValue ->
- let argumentNode = Full.Node fieldValue location'
- in pure $ HashMap.insert name' argumentNode arguments
- Nothing -> pure arguments
-
-fragmentSpread
- :: Full.FragmentSpread
- -> State (Replacement m) (Maybe (Fragment m))
-fragmentSpread (Full.FragmentSpread name directives' _) = do
- spreadDirectives <- Definition.selection <$> directives directives'
- fragments' <- gets fragments
-
- fragmentDefinitions' <- gets fragmentDefinitions
- case HashMap.lookup name fragments' of
- Just definition -> lift $ pure $ definition <$ spreadDirectives
- Nothing
- | Just definition <- HashMap.lookup name fragmentDefinitions' -> do
- fragDef <- fragmentDefinition definition
- case fragDef of
- Just fragment -> lift $ pure $ fragment <$ spreadDirectives
- _ -> lift $ pure Nothing
- | otherwise -> lift $ pure Nothing
-
-inlineFragment
- :: Full.InlineFragment
- -> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
-inlineFragment (Full.InlineFragment type' directives' selections _) = do
- fragmentDirectives <- Definition.selection <$> directives directives'
- case fragmentDirectives of
- Nothing -> pure $ Left mempty
- _ -> do
- fragmentSelectionSet <- appendSelection selections
-
- case type' of
- Nothing -> pure $ Left fragmentSelectionSet
- Just typeName -> do
- types' <- gets types
- case Type.lookupTypeCondition typeName types' of
- Just typeCondition -> pure $
- selectionFragment typeCondition fragmentSelectionSet
- Nothing -> pure $ Left mempty
+ go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do
+ transformedValue <- directiveValue node'
+ pure $ HashMap.insert argumentName transformedValue accumulator
+
+directiveValue :: Monad m => Full.Value -> TransformT m Type.Value
+directiveValue = \case
+ (Full.Variable name') -> asks
+ $ HashMap.lookupDefault Type.Null name'
+ . variableValues
+ (Full.Int integer) -> pure $ Type.Int integer
+ (Full.Float double) -> pure $ Type.Float double
+ (Full.String string) -> pure $ Type.String string
+ (Full.Boolean boolean) -> pure $ Type.Boolean boolean
+ Full.Null -> pure Type.Null
+ (Full.Enum enum) -> pure $ Type.Enum enum
+ (Full.List list) -> Type.List <$> traverse directiveNode list
+ (Full.Object objectFields) ->
+ Type.Object <$> foldM objectField HashMap.empty objectFields
where
- selectionFragment typeName = Right
- . SelectionFragment
- . Fragment typeName
-
-appendSelection :: Traversable t
- => t Full.Selection
- -> State (Replacement m) (Seq (Selection m))
-appendSelection = foldM go mempty
+ directiveNode Full.Node{ node = node'} = directiveValue node'
+ objectField accumulator Full.ObjectField{ name, value } = do
+ transformedValue <- directiveNode value
+ pure $ HashMap.insert name transformedValue accumulator
+
+input :: Monad m => Full.Value -> TransformT m (Maybe Input)
+input (Full.Variable name') =
+ asks (HashMap.lookup name' . variableValues) <&> fmap Variable
+input (Full.Int integer) = pure $ Just $ Int integer
+input (Full.Float double) = pure $ Just $ Float double
+input (Full.String string) = pure $ Just $ String string
+input (Full.Boolean boolean) = pure $ Just $ Boolean boolean
+input Full.Null = pure $ Just Null
+input (Full.Enum enum) = pure $ Just $ Enum enum
+input (Full.List list) = Just . List
+ <$> traverse (fmap (fromMaybe Null) . input . Full.node) list
+input (Full.Object objectFields) = Just . Object
+ <$> foldM objectField HashMap.empty objectFields
where
- go acc sel = append acc <$> selection sel
- append acc (Left list) = list >< acc
- append acc (Right one) = one <| acc
+ objectField accumulator Full.ObjectField{..} = do
+ objectFieldValue <- fmap Full.node <$> node value
+ pure $ insertIfGiven name objectFieldValue accumulator
+
+insertIfGiven :: forall a
+ . Full.Name
+ -> Maybe a
+ -> HashMap Full.Name a
+ -> HashMap Full.Name a
+insertIfGiven name (Just v) = HashMap.insert name v
+insertIfGiven _ _ = id
+
+node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input))
+node Full.Node{node = node', ..} =
+ traverse Full.Node <$> input node' <*> pure location
-directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
-directives = traverse directive
- where
- directive (Full.Directive directiveName directiveArguments _)
- = Definition.Directive directiveName . Type.Arguments
- <$> foldM go HashMap.empty directiveArguments
- go arguments (Full.Argument name (Full.Node value' _) _) = do
- substitutedValue <- value value'
- return $ HashMap.insert name substitutedValue arguments
-
--- * Fragment replacement
-
--- | Extract fragment definitions into a single 'HashMap'.
-collectFragments :: State (Replacement m) ()
-collectFragments = do
- fragDefs <- gets fragmentDefinitions
- let nextValue = head $ HashMap.elems fragDefs
- unless (HashMap.null fragDefs) $ do
- _ <- fragmentDefinition nextValue
- collectFragments
-
-fragmentDefinition
- :: Full.FragmentDefinition
- -> State (Replacement m) (Maybe (Fragment m))
-fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do
- modify deleteFragmentDefinition
- fragmentSelection <- appendSelection selections
- types' <- gets types
-
- case Type.lookupTypeCondition type' types' of
- Just compositeType -> do
- let newValue = Fragment compositeType fragmentSelection
- modify $ insertFragment newValue
- lift $ pure $ Just newValue
- _ -> lift $ pure Nothing
- where
- deleteFragmentDefinition replacement@Replacement{..} =
- let newDefinitions = HashMap.delete name fragmentDefinitions
- in replacement{ fragmentDefinitions = newDefinitions }
- insertFragment newValue replacement@Replacement{..} =
- let newFragments = HashMap.insert name newValue fragments
- in replacement{ fragments = newFragments }
-
-value :: forall m. Full.Value -> State (Replacement m) Type.Value
-value (Full.Variable name) =
- gets (fromMaybe Type.Null . HashMap.lookup name . variableValues)
-value (Full.Int int) = pure $ Type.Int int
-value (Full.Float float) = pure $ Type.Float float
-value (Full.String string) = pure $ Type.String string
-value (Full.Boolean boolean) = pure $ Type.Boolean boolean
-value Full.Null = pure Type.Null
-value (Full.Enum enum) = pure $ Type.Enum enum
-value (Full.List list) = Type.List <$> traverse (value . Full.node) list
-value (Full.Object object) =
- Type.Object . HashMap.fromList <$> traverse objectField object
- where
- objectField Full.ObjectField{value = value', ..} =
- (name,) <$> value (Full.node value')
-
-input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
-input (Full.Variable name) =
- gets (fmap Variable . HashMap.lookup name . variableValues)
-input (Full.Int int) = pure $ pure $ Int int
-input (Full.Float float) = pure $ pure $ Float float
-input (Full.String string) = pure $ pure $ String string
-input (Full.Boolean boolean) = pure $ pure $ Boolean boolean
-input Full.Null = pure $ pure Null
-input (Full.Enum enum) = pure $ pure $ Enum enum
-input (Full.List list) = pure . List <$> traverse (value . Full.node) list
-input (Full.Object object) = do
- objectFields <- foldM objectField HashMap.empty object
- pure $ pure $ Object objectFields
- where
- objectField resultMap Full.ObjectField{value = value', ..} =
- inputField resultMap name $ Full.node value'
-
-inputField :: forall m
- . HashMap Full.Name Input
- -> Full.Name
- -> Full.Value
- -> State (Replacement m) (HashMap Full.Name Input)
-inputField resultMap name value' = do
- objectFieldValue <- input value'
- case objectFieldValue of
- Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap
- Nothing -> pure resultMap
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-27 04:08:35 +0000