OSS/graphql
1
1
Fork 1
Code Issues 4 Pull Requests Actions Releases 22 Wiki Activity

Export sum type for all GraphQL types

Browse Source
This commit is contained in:
Eugen Wissner
2020-07-06 19:10:34 +02:00
parent a6f9cec413
commit b2d473de8d
11 changed files with 159 additions and 161 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
src/Language/GraphQL/Execute/Execution.hs
View File

@ -25,6 +25,7 @@ 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 Language.GraphQL.Type.Internal
import Language.GraphQL.Type.Schema
import Prelude hiding (null)
@ -108,12 +109,12 @@ executeField fieldDefinition prev fields = do
let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition
let (Transform.Field _ _ arguments' _ :| []) = fields
case coerceArgumentValues argumentDefinitions arguments' of
Nothing -> errmsg "Argument coercing failed."
Nothing -> addErrMsg "Argument coercing failed."
Just argumentValues -> do
answer <- lift $ resolveFieldValue prev argumentValues resolver
case answer of
Right result -> completeValue fieldType fields result
Left errorMessage -> errmsg errorMessage
Left errorMessage -> addErrMsg errorMessage
completeValue :: (Monad m, Serialize a)
=> Out.Type m
@ -136,7 +137,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers
then coerceResult outputType $ Enum enum
else errmsg "Value completion failed."
else addErrMsg "Value completion failed."
completeValue (Out.ObjectBaseType objectType) fields result =
executeSelectionSet result objectType $ mergeSelectionSets fields
completeValue (Out.InterfaceBaseType interfaceType) fields result
@ -146,7 +147,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
case concreteType of
Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields
Nothing -> errmsg "Value completion failed."
Nothing -> addErrMsg "Value completion failed."
completeValue (Out.UnionBaseType unionType) fields result
| Type.Object objectMap <- result = do
let abstractType = AbstractUnionType unionType
@ -154,8 +155,8 @@ completeValue (Out.UnionBaseType unionType) fields result
case concreteType of
Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields
Nothing -> errmsg "Value completion failed."
completeValue _ _ _ = errmsg "Value completion failed."
Nothing -> addErrMsg "Value completion failed."
completeValue _ _ _ = addErrMsg "Value completion failed."
mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m)
mergeSelectionSets = foldr forEach mempty
@ -163,16 +164,13 @@ mergeSelectionSets = foldr forEach mempty
forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
selectionSet <> fieldSelectionSet
errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
errmsg errorMessage = addErrMsg errorMessage >> pure null
coerceResult :: (Monad m, Serialize a)
=> Out.Type m
-> Output a
-> CollectErrsT m a
coerceResult outputType result
| Just serialized <- serialize outputType result = pure serialized
| otherwise = errmsg "Result coercion failed."
| otherwise = addErrMsg "Result coercion failed."
-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
-- each field to each 'Transform.Selection'. Resolves into a value containing

14
src/Language/GraphQL/Execute/Transform.hs
View File

@ -45,10 +45,10 @@ 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 Language.GraphQL.Type.Directive (Directive(..))
import qualified Language.GraphQL.Type.Directive as Directive
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
@ -285,7 +285,7 @@ selection (Full.Field alias name arguments' directives' selections) =
maybe (Left mempty) (Right . SelectionField) <$> do
fieldArguments <- foldM go HashMap.empty arguments'
fieldSelections <- appendSelection selections
fieldDirectives <- Directive.selection <$> directives directives'
fieldDirectives <- Definition.selection <$> directives directives'
let field' = Field alias name fieldArguments fieldSelections
pure $ field' <$ fieldDirectives
where
@ -294,7 +294,7 @@ selection (Full.Field alias name arguments' directives' selections) =
selection (Full.FragmentSpread name directives') =
maybe (Left mempty) (Right . SelectionFragment) <$> do
spreadDirectives <- Directive.selection <$> directives directives'
spreadDirectives <- Definition.selection <$> directives directives'
fragments' <- gets fragments
fragmentDefinitions' <- gets fragmentDefinitions
@ -308,7 +308,7 @@ selection (Full.FragmentSpread name directives') =
_ -> lift $ pure Nothing
| otherwise -> lift $ pure Nothing
selection (Full.InlineFragment type' directives' selections) = do
fragmentDirectives <- Directive.selection <$> directives directives'
fragmentDirectives <- Definition.selection <$> directives directives'
case fragmentDirectives of
Nothing -> pure $ Left mempty
_ -> do
@ -336,11 +336,11 @@ appendSelection = foldM go mempty
append acc (Left list) = list >< acc
append acc (Right one) = one <| acc
directives :: [Full.Directive] -> State (Replacement m) [Directive]
directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
directives = traverse directive
where
directive (Full.Directive directiveName directiveArguments)
= Directive directiveName . Type.Arguments
= Definition.Directive directiveName . Type.Arguments
<$> foldM go HashMap.empty directiveArguments
go arguments (Full.Argument name value') = do
substitutedValue <- value value'