diff options
| author | Eugen Wissner <belka@caraus.de> | 2020-05-27 23:18:35 +0200 |
|---|---|---|
| committer | Eugen Wissner <belka@caraus.de> | 2020-05-29 13:53:51 +0200 |
| commit | d12577ae717512979c7654191ca65f25fc877907 (patch) | |
| tree | 17eda8d92d92ef2773c439d614f00ea0e74ea969 /src/Language/GraphQL | |
| parent | c06d0b8e95ea4b87eab69da085cb32dbd052c1f0 (diff) | |
| download | graphql-d12577ae717512979c7654191ca65f25fc877907.tar.gz | |
Define resolvers on type fields
Returning resolvers from other resolvers isn't supported anymore. Since
we have a type system now, we define the resolvers in the object type
fields and pass an object with the previous result to them.
Diffstat (limited to 'src/Language/GraphQL')
| -rw-r--r-- | src/Language/GraphQL/AST/Core.hs | 44 | ||||
| -rw-r--r-- | src/Language/GraphQL/Error.hs | 50 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 32 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Coerce.hs | 61 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Execution.hs | 58 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 218 | ||||
| -rw-r--r-- | src/Language/GraphQL/Schema.hs | 133 | ||||
| -rw-r--r-- | src/Language/GraphQL/Trans.hs | 14 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Definition.hs | 24 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Directive.hs | 13 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/In.hs | 22 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Out.hs | 56 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Schema.hs | 11 |
13 files changed, 381 insertions, 355 deletions
diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index 6dcfb81..59d43eb 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -1,37 +1,15 @@ -- | This is the AST meant to be executed. module Language.GraphQL.AST.Core - ( Alias - , Arguments(..) - , Directive(..) - , Field(..) - , Fragment(..) + ( Arguments(..) , Name - , Operation(..) - , Selection(..) - , TypeCondition ) where import Data.HashMap.Strict (HashMap) -import Data.Sequence (Seq) -import Data.Text (Text) -import Language.GraphQL.AST (Alias, Name, TypeCondition) -import qualified Language.GraphQL.Type.In as In - --- | GraphQL has 3 operation types: queries, mutations and subscribtions. --- --- Currently only queries and mutations are supported. -data Operation - = Query (Maybe Text) (Seq Selection) - | Mutation (Maybe Text) (Seq Selection) - deriving (Eq, Show) - --- | Single GraphQL field. -data Field - = Field (Maybe Alias) Name Arguments (Seq Selection) - deriving (Eq, Show) +import Language.GraphQL.AST (Name) +import Language.GraphQL.Type.Definition -- | Argument list. -newtype Arguments = Arguments (HashMap Name In.Value) +newtype Arguments = Arguments (HashMap Name Value) deriving (Eq, Show) instance Semigroup Arguments where @@ -40,17 +18,3 @@ instance Semigroup Arguments where instance Monoid Arguments where mempty = Arguments mempty --- | Directive. -data Directive = Directive Name Arguments - deriving (Eq, Show) - --- | Represents fragments and inline fragments. -data Fragment - = Fragment TypeCondition (Seq Selection) - deriving (Eq, Show) - --- | Single selection element. -data Selection - = SelectionFragment Fragment - | SelectionField Field - deriving (Eq, Show) diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 91911b7..e41782d 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -5,21 +5,20 @@ module Language.GraphQL.Error ( parseError , CollectErrsT + , Resolution(..) , addErr , addErrMsg , runCollectErrs - , runAppendErrs , singleError ) where +import Control.Monad.Trans.State (StateT, modify, runStateT) import qualified Data.Aeson as Aeson +import Data.HashMap.Strict (HashMap) import Data.Text (Text) import Data.Void (Void) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State ( StateT - , modify - , runStateT - ) +import Language.GraphQL.AST.Document (Name) +import Language.GraphQL.Type.Schema import Text.Megaparsec ( ParseErrorBundle(..) , PosState(..) @@ -30,6 +29,11 @@ import Text.Megaparsec , unPos ) +data Resolution m = Resolution + { errors :: [Aeson.Value] + , types :: HashMap Name (Type m) + } + -- | Wraps a parse error into a list of errors. parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value parseError ParseErrorBundle{..} = @@ -46,11 +50,13 @@ parseError ParseErrorBundle{..} = in (errorObject x sourcePosition : result, newState) -- | A wrapper to pass error messages around. -type CollectErrsT m = StateT [Aeson.Value] m +type CollectErrsT m = StateT (Resolution m) m -- | Adds an error to the list of errors. addErr :: Monad m => Aeson.Value -> CollectErrsT m () -addErr v = modify (v :) +addErr v = modify appender + where + appender resolution@Resolution{..} = resolution{ errors = v : errors } makeErrorMessage :: Text -> Aeson.Value makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)] @@ -66,23 +72,17 @@ singleError message = Aeson.object addErrMsg :: Monad m => Text -> CollectErrsT m () addErrMsg = addErr . makeErrorMessage --- | Appends the given list of errors to the current list of errors. -appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m () -appendErrs errs = modify (errs ++) - -- | Runs the given query computation, but collects the errors into an error -- list, which is then sent back with the data. -runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value -runCollectErrs res = do - (dat, errs) <- runStateT res [] - if null errs +runCollectErrs :: Monad m + => HashMap Name (Type m) + -> CollectErrsT m Aeson.Value + -> m Aeson.Value +runCollectErrs types' res = do + (dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' } + if null errors then return $ Aeson.object [("data", dat)] - else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)] - --- | Runs the given computation, collecting the errors and appending them --- to the previous list of errors. -runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a -runAppendErrs f = do - (v, errs) <- lift $ runStateT f [] - appendErrs errs - return v + else return $ Aeson.object + [ ("data", dat) + , ("errors", Aeson.toJSON $ reverse errors) + ] diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 862e360..ee009db 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} - -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute ( execute @@ -8,14 +5,15 @@ module Language.GraphQL.Execute ) where import qualified Data.Aeson as Aeson +import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Sequence (Seq(..)) import Data.Text (Text) -import Language.GraphQL.AST.Document -import qualified Language.GraphQL.AST.Core as AST.Core +import Language.GraphQL.AST.Document (Document, Name) import Language.GraphQL.Execute.Coerce import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error +import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema @@ -56,22 +54,18 @@ executeRequest :: (Monad m, VariableValue a) executeRequest schema operationName subs document = case Transform.document schema operationName subs document of Left queryError -> pure $ singleError $ Transform.queryError queryError - Right (Transform.Document rootObjectType operation) - | (AST.Core.Query _ fields) <- operation -> - executeOperation rootObjectType fields - | (AST.Core.Mutation _ fields) <- operation -> - executeOperation rootObjectType fields + Right (Transform.Document types' rootObjectType operation) + | (Transform.Query _ fields) <- operation -> + executeOperation types' rootObjectType fields + | (Transform.Mutation _ fields) <- operation -> + executeOperation types' rootObjectType fields -- This is actually executeMutation, but we don't distinguish between queries -- and mutations yet. executeOperation :: Monad m - => Out.ObjectType m - -> Seq AST.Core.Selection + => HashMap Name (Type m) + -> Out.ObjectType m + -> Seq (Transform.Selection m) -> m Aeson.Value -executeOperation (Out.ObjectType _ _ _ objectFields) fields - = runCollectErrs - $ flip Schema.resolve fields - $ fmap getResolver - $ objectFields - where - getResolver (Out.Field _ _ _ resolver) = resolver +executeOperation types' objectType fields = + runCollectErrs types' $ Schema.resolve Null objectType fields diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 4a9218b..09375fd 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -16,7 +16,6 @@ import qualified Data.Text.Lazy.Builder.Int as Text.Builder import Data.Scientific (toBoundedInteger, toRealFloat) import Language.GraphQL.AST.Document (Name) import qualified Language.GraphQL.Type.In as In -import Language.GraphQL.Schema import Language.GraphQL.Type.Definition -- | Since variables are passed separately from the query, in an independent @@ -46,26 +45,26 @@ class VariableValue a where coerceVariableValue :: In.Type -- ^ Expected type (variable type given in the query). -> a -- ^ Variable value being coerced. - -> Maybe In.Value -- ^ Coerced value on success, 'Nothing' otherwise. + -> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise. instance VariableValue Aeson.Value where - coerceVariableValue _ Aeson.Null = Just In.Null + coerceVariableValue _ Aeson.Null = Just Null coerceVariableValue (In.ScalarBaseType scalarType) value - | (Aeson.String stringValue) <- value = Just $ In.String stringValue - | (Aeson.Bool booleanValue) <- value = Just $ In.Boolean booleanValue + | (Aeson.String stringValue) <- value = Just $ String stringValue + | (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue | (Aeson.Number numberValue) <- value , (ScalarType "Float" _) <- scalarType = - Just $ In.Float $ toRealFloat numberValue + Just $ Float $ toRealFloat numberValue | (Aeson.Number numberValue) <- value = -- ID or Int - In.Int <$> toBoundedInteger numberValue + Int <$> toBoundedInteger numberValue coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) = - Just $ In.Enum stringValue + Just $ 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 $ In.Object resultMap + then Just $ Object resultMap else Nothing where foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues @@ -81,7 +80,7 @@ instance VariableValue Aeson.Value where pure (newObjectValue, insert coerced) Nothing -> Just (objectValue, resultMap) coerceVariableValue (In.ListBaseType listType) value - | (Aeson.Array arrayValue) <- value = In.List + | (Aeson.Array arrayValue) <- value = List <$> foldr foldVector (Just []) arrayValue | otherwise = coerceVariableValue listType value where @@ -95,7 +94,7 @@ instance VariableValue Aeson.Value where -- corresponding types. coerceInputLiterals :: HashMap Name In.Type - -> HashMap Name In.Value + -> HashMap Name Value -> Maybe Subs coerceInputLiterals variableTypes variableValues = foldWithKey operator variableTypes @@ -105,34 +104,34 @@ coerceInputLiterals variableTypes variableValues = <$> (lookupVariable variableName >>= coerceInputLiteral variableType) <*> resultMap coerceInputLiteral (In.NamedScalarType type') value - | (In.String stringValue) <- value - , (ScalarType "String" _) <- type' = Just $ In.String stringValue - | (In.Boolean booleanValue) <- value - , (ScalarType "Boolean" _) <- type' = Just $ In.Boolean booleanValue - | (In.Int intValue) <- value - , (ScalarType "Int" _) <- type' = Just $ In.Int intValue - | (In.Float floatValue) <- value - , (ScalarType "Float" _) <- type' = Just $ In.Float floatValue - | (In.Int intValue) <- value + | (String stringValue) <- value + , (ScalarType "String" _) <- type' = Just $ String stringValue + | (Boolean booleanValue) <- value + , (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue + | (Int intValue) <- value + , (ScalarType "Int" _) <- type' = Just $ Int intValue + | (Float floatValue) <- value + , (ScalarType "Float" _) <- type' = Just $ Float floatValue + | (Int intValue) <- value , (ScalarType "Float" _) <- type' = - Just $ In.Float $ fromIntegral intValue - | (In.String stringValue) <- value - , (ScalarType "ID" _) <- type' = Just $ In.String stringValue - | (In.Int intValue) <- value + Just $ Float $ fromIntegral intValue + | (String stringValue) <- value + , (ScalarType "ID" _) <- type' = Just $ String stringValue + | (Int intValue) <- value , (ScalarType "ID" _) <- type' = Just $ decimal intValue - coerceInputLiteral (In.NamedEnumType type') (In.Enum enumValue) - | member enumValue type' = Just $ In.Enum enumValue - coerceInputLiteral (In.NamedInputObjectType type') (In.Object _) = + coerceInputLiteral (In.NamedEnumType type') (Enum enumValue) + | member enumValue type' = Just $ Enum enumValue + coerceInputLiteral (In.NamedInputObjectType type') (Object _) = let (In.InputObjectType _ _ inputFields) = type' - in In.Object <$> foldWithKey matchFieldValues inputFields + in Object <$> foldWithKey matchFieldValues inputFields coerceInputLiteral _ _ = Nothing member value (EnumType _ _ members) = Set.member value members matchFieldValues fieldName (In.InputField _ type' defaultValue) resultMap = case lookupVariable fieldName of - Just In.Null + Just Null | In.isNonNullType type' -> Nothing | otherwise -> - HashMap.insert fieldName In.Null <$> resultMap + HashMap.insert fieldName Null <$> resultMap Just variableValue -> HashMap.insert fieldName <$> coerceInputLiteral type' variableValue <*> resultMap @@ -144,7 +143,7 @@ coerceInputLiterals variableTypes variableValues = | otherwise -> resultMap lookupVariable = flip HashMap.lookup variableValues foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty) - decimal = In.String + decimal = String . Text.Lazy.toStrict . Text.Builder.toLazyText . Text.Builder.decimal diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs new file mode 100644 index 0000000..117df30 --- /dev/null +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.GraphQL.Execute.Execution + ( aliasOrName + , collectFields + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Language.GraphQL.AST.Document (Name) +import Language.GraphQL.Execute.Transform +import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Schema + +collectFields :: Monad m + => Out.ObjectType m + -> Seq (Selection m) + -> Map Name (Seq (Field m)) +collectFields objectType = foldl forEach Map.empty + where + forEach groupedFields (SelectionField field) = + let responseKey = aliasOrName field + in Map.insertWith (<>) responseKey (Seq.singleton field) groupedFields + forEach groupedFields (SelectionFragment selectionFragment) + | Fragment fragmentType fragmentSelectionSet <- selectionFragment + , doesFragmentTypeApply fragmentType objectType = + let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet + in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet + | otherwise = groupedFields + +aliasOrName :: forall m. Field m -> Name +aliasOrName (Field alias name _ _) = fromMaybe name alias + +doesFragmentTypeApply :: forall m + . CompositeType m + -> Out.ObjectType m + -> Bool +doesFragmentTypeApply (CompositeObjectType fragmentType) objectType = + let Out.ObjectType fragmentName _ _ _ = fragmentType + Out.ObjectType objectName _ _ _ = objectType + in fragmentName == objectName +doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType = + let Out.ObjectType _ _ interfaces _ = objectType + in foldr instanceOf False interfaces + where + instanceOf (Out.InterfaceType that _ interfaces _) acc = + let Out.InterfaceType this _ _ _ = fragmentType + in acc || foldr instanceOf (this == that) interfaces +doesFragmentTypeApply (CompositeUnionType fragmentType) objectType = + let Out.UnionType _ _ members = fragmentType + in foldr instanceOf False members + where + instanceOf (Out.ObjectType that _ _ _) acc = + let Out.ObjectType this _ _ _ = objectType + in acc || this == that diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 8233c73..fe517d9 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -12,12 +12,17 @@ -- replaced by the selection set they represent. Invalid (recursive and -- non-existing) fragments are skipped. The most fragments are inlined, so the -- executor doesn't have to perform additional lookups later. +-- * Evaluating directives (@\@include@ and @\@skip@). -- -- This module is also responsible for smaller rewrites that touch only parts of -- the original AST. module Language.GraphQL.Execute.Transform ( Document(..) + , Fragment(..) , QueryError(..) + , Operation(..) + , Selection(..) + , Field(..) , document , queryError ) where @@ -36,26 +41,48 @@ import Data.Sequence (Seq, (<|), (><)) import Data.Text (Text) import qualified Data.Text as Text import qualified Language.GraphQL.AST as Full -import qualified Language.GraphQL.AST.Core as Core +import Language.GraphQL.AST.Core import Language.GraphQL.Execute.Coerce -import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Type.Directive as Directive +import Language.GraphQL.Type.Definition (Subs, Value(..)) +import qualified Language.GraphQL.AST.Core as Core import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out +import qualified Language.GraphQL.Type.Directive as Core import Language.GraphQL.Type.Schema -- | Associates a fragment name with a list of 'Core.Field's. data Replacement m = Replacement - { fragments :: HashMap Core.Name Core.Fragment + { fragments :: HashMap Full.Name (Fragment m) , fragmentDefinitions :: FragmentDefinitions - , variableValues :: Schema.Subs + , variableValues :: Subs , types :: HashMap Full.Name (Type m) } type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition +-- | Represents fragments and inline fragments. +data Fragment m + = Fragment (CompositeType m) (Seq (Selection m)) + +-- | Single selection element. +data Selection m + = SelectionFragment (Fragment m) + | SelectionField (Field m) + +-- | GraphQL has 3 operation types: queries, mutations and subscribtions. +-- +-- Currently only queries and mutations are supported. +data Operation m + = Query (Maybe Text) (Seq (Selection m)) + | Mutation (Maybe Text) (Seq (Selection m)) + +-- | Single GraphQL field. +data Field m = Field (Maybe Full.Name) Full.Name Arguments (Seq (Selection m)) + -- | Contains the operation to be executed along with its root type. -data Document m = Document (Out.ObjectType m) Core.Operation +data Document m = Document + (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m) data OperationDefinition = OperationDefinition Full.OperationType @@ -131,7 +158,7 @@ coerceVariableValues :: VariableValue a . HashMap Full.Name (Type m) -> OperationDefinition -> HashMap.HashMap Full.Name a - -> Either QueryError Schema.Subs + -> Either QueryError Subs coerceVariableValues types operationDefinition variableValues' = let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition in maybe (Left CoercionError) Right @@ -149,23 +176,23 @@ coerceVariableValues types operationDefinition variableValues' = <*> coercedValues choose Nothing defaultValue variableType | Just _ <- defaultValue = defaultValue - | not (In.isNonNullType variableType) = Just In.Null + | not (In.isNonNullType variableType) = Just Null choose (Just value') _ variableType | Just coercedValue <- coerceVariableValue variableType value' - , not (In.isNonNullType variableType) || coercedValue /= In.Null = + , not (In.isNonNullType variableType) || coercedValue /= Null = Just coercedValue choose _ _ _ = Nothing -constValue :: Full.ConstValue -> In.Value -constValue (Full.ConstInt i) = In.Int i -constValue (Full.ConstFloat f) = In.Float f -constValue (Full.ConstString x) = In.String x -constValue (Full.ConstBoolean b) = In.Boolean b -constValue Full.ConstNull = In.Null -constValue (Full.ConstEnum e) = In.Enum e -constValue (Full.ConstList l) = In.List $ constValue <$> l +constValue :: Full.ConstValue -> Value +constValue (Full.ConstInt i) = Int i +constValue (Full.ConstFloat f) = Float f +constValue (Full.ConstString x) = String x +constValue (Full.ConstBoolean b) = Boolean b +constValue Full.ConstNull = Null +constValue (Full.ConstEnum e) = Enum e +constValue (Full.ConstList l) = List $ constValue <$> l constValue (Full.ConstObject o) = - In.Object $ HashMap.fromList $ constObjectField <$> o + Object $ HashMap.fromList $ constObjectField <$> o where constObjectField (Full.ObjectField key value') = (key, constValue value') @@ -193,12 +220,12 @@ document schema operationName subs ast = do } case chosenOperation of OperationDefinition Full.Query _ _ _ _ -> - pure $ Document (query schema) - $ operation (query schema) chosenOperation replacement + pure $ Document referencedTypes (query schema) + $ operation chosenOperation replacement OperationDefinition Full.Mutation _ _ _ _ | Just mutationType <- mutation schema -> - pure $ Document mutationType - $ operation mutationType chosenOperation replacement + pure $ Document referencedTypes mutationType + $ operation chosenOperation replacement _ -> Left UnsupportedRootOperation defragment @@ -227,72 +254,73 @@ defragment ast = -- * Operation -operation :: forall m - . Out.ObjectType m - -> OperationDefinition - -> Replacement m - -> Core.Operation -operation rootType operationDefinition replacement +operation :: OperationDefinition -> Replacement m -> Operation m +operation operationDefinition replacement = runIdentity - $ evalStateT (collectFragments rootType >> transform operationDefinition) replacement + $ evalStateT (collectFragments >> transform operationDefinition) replacement where transform (OperationDefinition Full.Query name _ _ sels) = - Core.Query name <$> appendSelection sels rootType + Query name <$> appendSelection sels transform (OperationDefinition Full.Mutation name _ _ sels) = - Core.Mutation name <$> appendSelection sels rootType + Mutation name <$> appendSelection sels -- * Selection -selection :: forall m - . Full.Selection - -> Out.ObjectType m - -> State (Replacement m) (Either (Seq Core.Selection) Core.Selection) -selection (Full.Field alias name arguments' directives' selections) objectType = - maybe (Left mempty) (Right . Core.SelectionField) <$> do +selection + :: Full.Selection + -> State (Replacement m) (Either (Seq (Selection m)) (Selection m)) +selection (Full.Field alias name arguments' directives' selections) = + maybe (Left mempty) (Right . SelectionField) <$> do fieldArguments <- arguments arguments' - fieldSelections <- appendSelection selections objectType + fieldSelections <- appendSelection selections fieldDirectives <- Directive.selection <$> directives directives' - let field' = Core.Field alias name fieldArguments fieldSelections + let field' = Field alias name fieldArguments fieldSelections pure $ field' <$ fieldDirectives -selection (Full.FragmentSpread name directives') objectType = - maybe (Left mempty) (Right . Core.SelectionFragment) <$> do +selection (Full.FragmentSpread name directives') = + maybe (Left mempty) (Right . SelectionFragment) <$> do spreadDirectives <- Directive.selection <$> directives directives' fragments' <- gets fragments fragmentDefinitions' <- gets fragmentDefinitions case HashMap.lookup name fragments' of Just definition -> lift $ pure $ definition <$ spreadDirectives - Nothing -> case HashMap.lookup name fragmentDefinitions' of - Just definition -> do - fragment <- fragmentDefinition definition objectType - lift $ pure $ fragment <$ spreadDirectives - Nothing -> lift $ pure Nothing -selection (Full.InlineFragment type' directives' selections) objectType = do + 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 +selection (Full.InlineFragment type' directives' selections) = do fragmentDirectives <- Directive.selection <$> directives directives' case fragmentDirectives of Nothing -> pure $ Left mempty _ -> do - fragmentSelectionSet <- appendSelection selections objectType - pure $ maybe Left selectionFragment type' fragmentSelectionSet + fragmentSelectionSet <- appendSelection selections + + case type' of + Nothing -> pure $ Left fragmentSelectionSet + Just typeName -> do + typeCondition' <- lookupTypeCondition typeName + case typeCondition' of + Just typeCondition -> pure $ + selectionFragment typeCondition fragmentSelectionSet + Nothing -> pure $ Left mempty where selectionFragment typeName = Right - . Core.SelectionFragment - . Core.Fragment typeName + . SelectionFragment + . Fragment typeName appendSelection :: Traversable t - => forall m - . t Full.Selection - -> Out.ObjectType m - -> State (Replacement m) (Seq Core.Selection) -appendSelection selectionSet objectType = foldM go mempty selectionSet + => t Full.Selection + -> State (Replacement m) (Seq (Selection m)) +appendSelection = foldM go mempty where - go acc sel = append acc <$> selection sel objectType + go acc sel = append acc <$> selection sel append acc (Left list) = list >< acc append acc (Right one) = one <| acc -directives :: forall m - . [Full.Directive] - -> State (Replacement m) [Core.Directive] +directives :: [Full.Directive] -> State (Replacement m) [Core.Directive] directives = traverse directive where directive (Full.Directive directiveName directiveArguments) = @@ -301,24 +329,40 @@ directives = traverse directive -- * Fragment replacement -- | Extract fragment definitions into a single 'HashMap'. -collectFragments :: forall m. Out.ObjectType m -> State (Replacement m) () -collectFragments objectType = do +collectFragments :: State (Replacement m) () +collectFragments = do fragDefs <- gets fragmentDefinitions let nextValue = head $ HashMap.elems fragDefs unless (HashMap.null fragDefs) $ do - _ <- fragmentDefinition nextValue objectType - collectFragments objectType - -fragmentDefinition :: forall m - . Full.FragmentDefinition - -> Out.ObjectType m - -> State (Replacement m) Core.Fragment -fragmentDefinition (Full.FragmentDefinition name type' _ selections) objectType = do + _ <- fragmentDefinition nextValue + collectFragments + +lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m)) +lookupTypeCondition type' = do + types' <- gets types + case HashMap.lookup type' types' of + Just (ObjectType objectType) -> + lift $ pure $ Just $ CompositeObjectType objectType + Just (UnionType unionType) -> + lift $ pure $ Just $ CompositeUnionType unionType + Just (InterfaceType interfaceType) -> + lift $ pure $ Just $ CompositeInterfaceType interfaceType + _ -> lift $ pure Nothing + +fragmentDefinition + :: Full.FragmentDefinition + -> State (Replacement m) (Maybe (Fragment m)) +fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do modify deleteFragmentDefinition - fragmentSelection <- appendSelection selections objectType - let newValue = Core.Fragment type' fragmentSelection - modify $ insertFragment newValue - lift $ pure newValue + fragmentSelection <- appendSelection selections + compositeType <- lookupTypeCondition type' + + case compositeType 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 @@ -327,27 +371,27 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) objectType let newFragments = HashMap.insert name newValue fragments in replacement{ fragments = newFragments } -arguments :: forall m. [Full.Argument] -> State (Replacement m) Core.Arguments +arguments :: [Full.Argument] -> State (Replacement m) Core.Arguments arguments = fmap Core.Arguments . foldM go HashMap.empty where go arguments' (Full.Argument name value') = do substitutedValue <- value value' return $ HashMap.insert name substitutedValue arguments' -value :: forall m. Full.Value -> State (Replacement m) In.Value +value :: Full.Value -> State (Replacement m) Value value (Full.Variable name) = - gets $ fromMaybe In.Null . HashMap.lookup name . variableValues -value (Full.Int i) = pure $ In.Int i -value (Full.Float f) = pure $ In.Float f -value (Full.String x) = pure $ In.String x -value (Full.Boolean b) = pure $ In.Boolean b -value Full.Null = pure In.Null -value (Full.Enum e) = pure $ In.Enum e -value (Full.List l) = In.List <$> traverse value l + gets $ fromMaybe Null . HashMap.lookup name . variableValues +value (Full.Int i) = pure $ Int i +value (Full.Float f) = pure $ Float f +value (Full.String x) = pure $ String x +value (Full.Boolean b) = pure $ Boolean b +value Full.Null = pure Null +value (Full.Enum e) = pure $ Enum e +value (Full.List l) = List <$> traverse value l value (Full.Object o) = - In.Object . HashMap.fromList <$> traverse objectField o + Object . HashMap.fromList <$> traverse objectField o -objectField :: forall m - . Full.ObjectField Full.Value - -> State (Replacement m) (Core.Name, In.Value) +objectField + :: Full.ObjectField Full.Value + -> State (Replacement m) (Full.Name, Value) objectField (Full.ObjectField name value') = (name,) <$> value value' diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 34abf10..734f070 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -5,27 +5,24 @@ -- functions for defining and manipulating schemas. module Language.GraphQL.Schema ( Resolver(..) - , Subs - , object , resolve - , resolversToMap ) where import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) -import Data.Foldable (fold, toList) -import Data.Maybe (fromMaybe) import qualified Data.Aeson as Aeson -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.Sequence (Seq) +import qualified Data.Map.Strict as Map +import Data.Sequence (Seq(..)) import Data.Text (Text) -import qualified Data.Text as T -import Language.GraphQL.AST.Core +import qualified Data.Text as Text +import Language.GraphQL.AST.Document (Name) import Language.GraphQL.Error +import Language.GraphQL.Execute.Execution +import Language.GraphQL.Execute.Transform import Language.GraphQL.Trans -import qualified Language.GraphQL.Type.In as In +import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.Out as Out -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error @@ -35,82 +32,74 @@ import qualified Language.GraphQL.Type.Out as Out -- Resolving a field can result in a leaf value or an object, which is -- represented as a list of nested resolvers, used to resolve the fields of that -- object. -data Resolver m = Resolver Name (ActionT m (Out.Value m)) +data Resolver m = Resolver Name (ActionT m Value) --- | Converts resolvers to a map. -resolversToMap :: (Foldable f, Functor f) - => forall m - . f (Resolver m) - -> HashMap Text (ActionT m (Out.Value m)) -resolversToMap = HashMap.fromList . toList . fmap toKV - where - toKV (Resolver name r) = (name, r) - --- | Contains variables for the query. The key of the map is a variable name, --- and the value is the variable value. -type Subs = HashMap Name In.Value - --- | Create a new 'Resolver' with the given 'Name' from the given --- Resolver's. -object :: Monad m => [Resolver m] -> Out.Value m -object = Out.Object . resolversToMap - -resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a) -resolveFieldValue field@(Field _ _ args _) = - flip runReaderT (Context {arguments=args, info=field}) +resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a) +resolveFieldValue result (Field _ _ args _) = + flip runReaderT (Context {arguments=args, values=result}) . runExceptT . runActionT -withField :: Monad m - => Field - -> ActionT m (Out.Value m) - -> CollectErrsT m Aeson.Object -withField field resolver = do - answer <- lift $ resolveFieldValue field resolver +executeField :: Monad m + => Value + -> Out.Field m + -> Field m + -> CollectErrsT m Aeson.Value +executeField prev (Out.Field _ fieldType _ resolver) field = do + answer <- lift $ resolveFieldValue prev field resolver case answer of - Right result -> HashMap.singleton (aliasOrName field) - <$> toJSON field result - Left errorMessage -> errmsg field errorMessage + Right result -> completeValue fieldType field result + Left errorMessage -> errmsg errorMessage -toJSON :: Monad m => Field -> Out.Value m -> CollectErrsT m Aeson.Value -toJSON _ Out.Null = pure Aeson.Null -toJSON _ (Out.Int integer) = pure $ Aeson.toJSON integer -toJSON _ (Out.Boolean boolean) = pure $ Aeson.Bool boolean -toJSON _ (Out.Float float) = pure $ Aeson.toJSON float -toJSON _ (Out.Enum enum) = pure $ Aeson.String enum -toJSON _ (Out.String string) = pure $ Aeson.String string -toJSON field (Out.List list) = Aeson.toJSON <$> traverse (toJSON field) list -toJSON (Field _ _ _ seqSelection) (Out.Object map') = - map' `resolve` seqSelection +completeValue :: Monad m + => Out.Type m + -> Field m + -> Value + -> CollectErrsT m Aeson.Value +completeValue _ _ Null = pure Aeson.Null +completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer +completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean' +completeValue _ _ (Float float') = pure $ Aeson.toJSON float' +completeValue _ _ (Enum enum) = pure $ Aeson.String enum +completeValue _ _ (String string') = pure $ Aeson.String string' +completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result = + resolve result objectType seqSelection +completeValue (Out.ListBaseType listType) selectionField (List list) = + Aeson.toJSON <$> traverse (completeValue listType selectionField) list +completeValue _ _ _ = errmsg "Value completion failed." -errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value) -errmsg field errorMessage = do - addErrMsg errorMessage - pure $ HashMap.singleton (aliasOrName field) Aeson.Null +errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value +errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null -- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information. -resolve :: Monad m - => HashMap Text (ActionT m (Out.Value m)) - -> Seq Selection +resolve :: Monad m -- executeSelectionSet + => Value + -> Out.ObjectType m + -> Seq (Selection m) -> CollectErrsT m Aeson.Value -resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers +resolve result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do + resolvedValues <- Map.traverseMaybeWithKey forEach + $ collectFields objectType selectionSet + pure $ Aeson.toJSON resolvedValues where + forEach _responseKey (field :<| _) = + tryResolvers field >>= lift . pure . pure + forEach _ _ = pure Nothing lookupResolver = flip HashMap.lookup resolvers - tryResolvers (SelectionField fld@(Field _ name _ _)) - | (Just resolver) <- lookupResolver name = withField fld resolver - | otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."] - tryResolvers (SelectionFragment (Fragment typeCondition selections')) - | Just resolver <- lookupResolver "__typename" = do - let fakeField = Field Nothing "__typename" mempty mempty - that <- lift $ resolveFieldValue fakeField resolver + tryResolvers fld@(Field _ name _ _) + | Just typeField <- lookupResolver name = + executeField result typeField fld + | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."] + {-tryResolvers (Out.SelectionFragment (Out.Fragment typeCondition selections')) + | Just (Out.Field _ _ _ resolver) <- lookupResolver "__typename" = do + let fakeField = Out.Field Nothing "__typename" mempty mempty + that <- lift $ resolveFieldValue result fakeField resolver case that of - Right (Out.String typeCondition') - | typeCondition' == typeCondition -> + Right (String typeCondition') + | (Out.CompositeObjectType (Out.ObjectType n _ _ _)) <- typeCondition + , typeCondition' == n -> fmap fold . traverse tryResolvers $ selections' _ -> pure mempty - | otherwise = fmap fold . traverse tryResolvers $ selections' - -aliasOrName :: Field -> Text -aliasOrName (Field alias name _ _) = fromMaybe name alias + | otherwise = fmap fold . traverse tryResolvers $ selections'-} diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs index 3c3ffa4..7dc5523 100644 --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -1,8 +1,8 @@ -- | Monad transformer stack used by the @GraphQL@ resolvers. module Language.GraphQL.Trans - ( ActionT(..) + ( argument + , ActionT(..) , Context(..) - , argument ) where import Control.Applicative (Alternative(..)) @@ -15,13 +15,13 @@ import qualified Data.HashMap.Strict as HashMap import Data.Maybe (fromMaybe) import Data.Text (Text) import Language.GraphQL.AST.Core -import qualified Language.GraphQL.Type.In as In +import Language.GraphQL.Type.Definition import Prelude hiding (lookup) -- | Resolution context holds resolver arguments. data Context = Context { arguments :: Arguments - , info :: Field + , values :: Value } -- | Monad transformer stack used by the resolvers to provide error handling @@ -56,11 +56,11 @@ instance Monad m => MonadPlus (ActionT m) where mplus = (<|>) -- | Retrieves an argument by its name. If the argument with this name couldn't --- be found, returns 'In.Null' (i.e. the argument is assumed to +-- be found, returns 'Null' (i.e. the argument is assumed to -- be optional then). -argument :: Monad m => Name -> ActionT m In.Value +argument :: Monad m => Name -> ActionT m Value argument argumentName = do argumentValue <- ActionT $ lift $ asks $ lookup . arguments - pure $ fromMaybe In.Null argumentValue + pure $ fromMaybe Null argumentValue where lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index aecb64a..0f92857 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -4,6 +4,8 @@ module Language.GraphQL.Type.Definition ( EnumType(..) , ScalarType(..) + , Subs + , Value(..) , boolean , float , id @@ -11,11 +13,33 @@ module Language.GraphQL.Type.Definition , string ) where +import Data.Int (Int32) +import Data.HashMap.Strict (HashMap) import Data.Set (Set) +import Data.String (IsString(..)) import Data.Text (Text) import Language.GraphQL.AST.Document (Name) import Prelude hiding (id) +-- | Represents accordingly typed GraphQL values. +data Value + = Int Int32 + | Float Double -- ^ GraphQL Float is double precision. + | String Text + | Boolean Bool + | Null + | Enum Name + | List [Value] -- ^ Arbitrary nested list. + | Object (HashMap Name Value) + deriving (Eq, Show) + +instance IsString Value where + fromString = String . fromString + +-- | Contains variables for the query. The key of the map is a variable name, +-- and the value is the variable value. +type Subs = HashMap Name Value + -- | Scalar type definition. -- -- The leaf values of any request and input values to arguments are Scalars (or diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs index 9675df8..261bf04 100644 --- a/src/Language/GraphQL/Type/Directive.hs +++ b/src/Language/GraphQL/Type/Directive.hs @@ -1,12 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} module Language.GraphQL.Type.Directive - ( selection + ( Directive(..) + , selection ) where import qualified Data.HashMap.Strict as HashMap import Language.GraphQL.AST.Core -import qualified Language.GraphQL.Type.In as In +import Language.GraphQL.Type.Definition + +-- | Directive. +data Directive = Directive Name Arguments + deriving (Eq, Show) -- | Directive processing status. data Status @@ -37,7 +42,7 @@ skip = handle skip' where skip' directive'@(Directive "skip" (Arguments arguments)) = case HashMap.lookup "if" arguments of - (Just (In.Boolean True)) -> Skip + (Just (Boolean True)) -> Skip _ -> Include directive' skip' directive' = Continue directive' @@ -46,6 +51,6 @@ include = handle include' where include' directive'@(Directive "include" (Arguments arguments)) = case HashMap.lookup "if" arguments of - (Just (In.Boolean True)) -> Include directive' + (Just (Boolean True)) -> Include directive' _ -> Skip include' directive' = Continue directive' diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs index c2e8ded..c662797 100644 --- a/src/Language/GraphQL/Type/In.hs +++ b/src/Language/GraphQL/Type/In.hs @@ -10,7 +10,6 @@ module Language.GraphQL.Type.In , InputField(..) , InputObjectType(..) , Type(..) - , Value(..) , isNonNullType , pattern EnumBaseType , pattern ListBaseType @@ -19,8 +18,6 @@ module Language.GraphQL.Type.In ) where import Data.HashMap.Strict (HashMap) -import Data.Int (Int32) -import Data.String (IsString(..)) import Data.Text (Text) import Language.GraphQL.AST.Document (Name) import Language.GraphQL.Type.Definition @@ -36,6 +33,10 @@ data InputObjectType = InputObjectType Name (Maybe Text) (HashMap Name InputField) -- | These types may be used as input types for arguments and directives. +-- +-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping +-- type can wrap other wrapping or named types. Wrapping types are lists and +-- Non-Null types (named types are nullable by default). data Type = NamedScalarType ScalarType | NamedEnumType EnumType @@ -46,21 +47,6 @@ data Type | NonNullInputObjectType InputObjectType | NonNullListType Type --- | Represents accordingly typed GraphQL values. -data Value - = Int Int32 - | Float Double -- ^ GraphQL Float is double precision - | String Text - | Boolean Bool - | Null - | Enum Name - | List [Value] - | Object (HashMap Name Value) - deriving (Eq, Show) - -instance IsString Value where - fromString = String . fromString - -- | Field argument definition. data Argument = Argument (Maybe Text) Type (Maybe Value) diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index fe2d4f2..4808d09 100644 --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} @@ -13,7 +12,6 @@ module Language.GraphQL.Type.Out , ObjectType(..) , Type(..) , UnionType(..) - , Value(..) , isNonNullType , pattern EnumBaseType , pattern InterfaceBaseType @@ -24,12 +22,8 @@ module Language.GraphQL.Type.Out ) where import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Int (Int32) -import Data.String (IsString(..)) import Data.Text (Text) -import qualified Data.Text as Text -import Language.GraphQL.AST.Document (Name) +import Language.GraphQL.AST.Core import Language.GraphQL.Trans import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.In as In @@ -60,9 +54,13 @@ data Field m = Field (Maybe Text) -- ^ Description. (Type m) -- ^ Field type. (HashMap Name In.Argument) -- ^ Arguments. - (ActionT m (Value m)) -- ^ Resolver. + (ActionT m Value) -- ^ Resolver. -- | These types may be used as output types as the result of fields. +-- +-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping +-- type can wrap other wrapping or named types. Wrapping types are lists and +-- Non-Null types (named types are nullable by default). data Type m = NamedScalarType ScalarType | NamedEnumType EnumType @@ -77,48 +75,6 @@ data Type m | NonNullUnionType (UnionType m) | NonNullListType (Type m) --- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping --- type can wrap other wrapping or named types. Wrapping types are lists and --- Non-Null types (named types are nullable by default). --- --- This 'Value' type doesn\'t reflect this distinction exactly but it is used --- in the resolvers to take into account that the returned value can be nullable --- or an (arbitrary nested) list. -data Value m - = Int Int32 - | Float Double - | String Text - | Boolean Bool - | Null - | Enum Name - | List [Value m] -- ^ Arbitrary nested list. - | Object (HashMap Name (ActionT m (Value m))) - -instance IsString (Value m) where - fromString = String . fromString - -instance Show (Value m) where - show (Int integer) = "Int " ++ show integer - show (Float float') = "Float " ++ show float' - show (String text) = Text.unpack $ "String " <> text - show (Boolean True) = "Boolean True" - show (Boolean False) = "Boolean False" - show Null = "Null" - show (Enum enum) = Text.unpack $ "Enum " <> enum - show (List list) = show list - show (Object object) = Text.unpack - $ "Object [" <> Text.intercalate ", " (HashMap.keys object) <> "]" - -instance Eq (Value m) where - (Int this) == (Int that) = this == that - (Float this) == (Float that) = this == that - (String this) == (String that) = this == that - (Boolean this) == (Boolean that) = this == that - (Enum this) == (Enum that) = this == that - (List this) == (List that) = this == that - (Object this) == (Object that) = HashMap.keys this == HashMap.keys that - _ == _ = False - -- | Matches either 'NamedScalarType' or 'NonNullScalarType'. pattern ScalarBaseType :: forall m. ScalarType -> Type m pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType) diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 74ab974..b6055c5 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -2,14 +2,15 @@ -- | Schema Definition. module Language.GraphQL.Type.Schema - ( Schema(..) + ( CompositeType(..) + , Schema(..) , Type(..) , collectReferencedTypes ) where import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Language.GraphQL.AST.Core (Name) +import Language.GraphQL.AST.Document (Name) import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out @@ -23,6 +24,12 @@ data Type m | InterfaceType (Out.InterfaceType m) | UnionType (Out.UnionType m) +-- | These types may describe the parent context of a selection set. +data CompositeType m + = CompositeUnionType (Out.UnionType m) + | CompositeObjectType (Out.ObjectType m) + | CompositeInterfaceType (Out.InterfaceType m) + -- | A Schema is created by supplying the root types of each type of operation, -- query and mutation (optional). A schema definition is then supplied to the -- validator and executor. |
