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

Export sum type for all GraphQL types

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CHANGELOG.md
View File

@ -12,6 +12,7 @@ and this project adheres to
- `Execute` reexports `Execute.Coerce`.
- `Error.Error` is an error representation with a message and source location.
- `Error.Response` represents a result of running a GraphQL query.
- `Type.Schema` exports `Type` which lists all types possible in the schema.
## Changed
- `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver`

6
graphql.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 7101732e7932f4605d0c6ecaf88fd11c1fb6cb8045e6e0f419858cad027f383a
-- hash: c06170c5fd3d1c3e42fb8c8fde8afd88bf3dd142f6cee1f83128e8d00d443f2d
name: graphql
version: 0.8.0.0
@ -50,12 +50,12 @@ library
Language.GraphQL.Type
Language.GraphQL.Type.In
Language.GraphQL.Type.Out
Language.GraphQL.Type.Schema
other-modules:
Language.GraphQL.Execute.Execution
Language.GraphQL.Execute.Transform
Language.GraphQL.Type.Definition
Language.GraphQL.Type.Directive
Language.GraphQL.Type.Schema
Language.GraphQL.Type.Internal
hs-source-dirs:
src
build-depends:

3
package.yaml
View File

@ -43,8 +43,7 @@ library:
- Language.GraphQL.Execute.Execution
- Language.GraphQL.Execute.Transform
- Language.GraphQL.Type.Definition
- Language.GraphQL.Type.Directive
- Language.GraphQL.Type.Schema
- Language.GraphQL.Type.Internal
tests:
tasty:

4
src/Language/GraphQL/Error.hs
View File

@ -79,8 +79,8 @@ singleError :: Serialize a => Text -> Response a
singleError message = Response null $ Seq.singleton $ makeErrorMessage message
-- | Convenience function for just wrapping an error message.
addErrMsg :: Monad m => Text -> CollectErrsT m ()
addErrMsg = addErr . makeErrorMessage
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
-- | @GraphQL@ error.
data Error = Error

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'

51
src/Language/GraphQL/Type/Definition.hs
View File

@ -3,6 +3,7 @@
-- | Types that can be used as both input and output types.
module Language.GraphQL.Type.Definition
( Arguments(..)
, Directive(..)
, EnumType(..)
, EnumValue(..)
, ScalarType(..)
@ -12,14 +13,16 @@ module Language.GraphQL.Type.Definition
, float
, id
, int
, selection
, string
) where
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.String (IsString(..))
import Data.Text (Text)
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.AST (Name)
import Prelude hiding (id)
-- | Represents accordingly typed GraphQL values.
@ -124,3 +127,49 @@ id = ScalarType "ID" (Just description)
\JSON response as a String; however, it is not intended to be \
\human-readable. When expected as an input type, any string (such as \
\`\"4\"`) or integer (such as `4`) input value will be accepted as an ID."
-- | Directive.
data Directive = Directive Name Arguments
deriving (Eq, Show)
-- | Directive processing status.
data Status
= Skip -- ^ Skip the selection and stop directive processing
| Include Directive -- ^ The directive was processed, try other handlers
| Continue Directive -- ^ Directive handler mismatch, try other handlers
-- | Takes a list of directives, handles supported directives and excludes them
-- from the result. If the selection should be skipped, returns 'Nothing'.
selection :: [Directive] -> Maybe [Directive]
selection = foldr go (Just [])
where
go directive' directives' =
case (skip . include) (Continue directive') of
(Include _) -> directives'
Skip -> Nothing
(Continue x) -> (x :) <$> directives'
handle :: (Directive -> Status) -> Status -> Status
handle _ Skip = Skip
handle handler (Continue directive) = handler directive
handle handler (Include directive) = handler directive
-- * Directive implementations
skip :: Status -> Status
skip = handle skip'
where
skip' directive'@(Directive "skip" (Arguments arguments)) =
case HashMap.lookup "if" arguments of
(Just (Boolean True)) -> Skip
_ -> Include directive'
skip' directive' = Continue directive'
include :: Status -> Status
include = handle include'
where
include' directive'@(Directive "include" (Arguments arguments)) =
case HashMap.lookup "if" arguments of
(Just (Boolean True)) -> Include directive'
_ -> Skip
include' directive' = Continue directive'

56
src/Language/GraphQL/Type/Directive.hs
View File

@ -1,56 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Type.Directive
( Directive(..)
, selection
) where
import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL.AST (Name)
import Language.GraphQL.Type.Definition
-- | Directive.
data Directive = Directive Name Arguments
deriving (Eq, Show)
-- | Directive processing status.
data Status
= Skip -- ^ Skip the selection and stop directive processing
| Include Directive -- ^ The directive was processed, try other handlers
| Continue Directive -- ^ Directive handler mismatch, try other handlers
-- | Takes a list of directives, handles supported directives and excludes them
-- from the result. If the selection should be skipped, returns 'Nothing'.
selection :: [Directive] -> Maybe [Directive]
selection = foldr go (Just [])
where
go directive' directives' =
case (skip . include) (Continue directive') of
(Include _) -> directives'
Skip -> Nothing
(Continue x) -> (x :) <$> directives'
handle :: (Directive -> Status) -> Status -> Status
handle _ Skip = Skip
handle handler (Continue directive) = handler directive
handle handler (Include directive) = handler directive
-- * Directive implementations
skip :: Status -> Status
skip = handle skip'
where
skip' directive'@(Directive "skip" (Arguments arguments)) =
case HashMap.lookup "if" arguments of
(Just (Boolean True)) -> Skip
_ -> Include directive'
skip' directive' = Continue directive'
include :: Status -> Status
include = handle include'
where
include' directive'@(Directive "include" (Arguments arguments)) =
case HashMap.lookup "if" arguments of
(Just (Boolean True)) -> Include directive'
_ -> Skip
include' directive' = Continue directive'

85
src/Language/GraphQL/Type/Internal.hs Normal file
View File

@ -0,0 +1,85 @@
{-# LANGUAGE ExplicitForAll #-}
module Language.GraphQL.Type.Internal
( AbstractType(..)
, CompositeType(..)
, collectReferencedTypes
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL.AST (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
import Language.GraphQL.Type.Schema
-- | 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)
deriving Eq
-- | These types may describe the parent context of a selection set.
data AbstractType m
= AbstractUnionType (Out.UnionType m)
| AbstractInterfaceType (Out.InterfaceType m)
deriving Eq
-- | Traverses the schema and finds all referenced types.
collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
collectReferencedTypes schema =
let queryTypes = traverseObjectType (query schema) HashMap.empty
in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
where
collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes
| otherwise = traverser $ HashMap.insert typeName element foundTypes
visitFields (Out.Field _ outputType arguments _) foundTypes
= traverseOutputType outputType
$ foldr visitArguments foundTypes arguments
visitArguments (In.Argument _ inputType _) = traverseInputType inputType
visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
traverseInputType (In.InputObjectBaseType objectType) =
let (In.InputObjectType typeName _ inputFields) = objectType
element = InputObjectType objectType
traverser = flip (foldr visitInputFields) inputFields
in collect traverser typeName element
traverseInputType (In.ListBaseType listType) =
traverseInputType listType
traverseInputType (In.ScalarBaseType scalarType) =
let (Definition.ScalarType typeName _) = scalarType
in collect Prelude.id typeName (ScalarType scalarType)
traverseInputType (In.EnumBaseType enumType) =
let (Definition.EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseOutputType (Out.ObjectBaseType objectType) =
traverseObjectType objectType
traverseOutputType (Out.InterfaceBaseType interfaceType) =
traverseInterfaceType interfaceType
traverseOutputType (Out.UnionBaseType unionType) =
let (Out.UnionType typeName _ types) = unionType
traverser = flip (foldr traverseObjectType) types
in collect traverser typeName (UnionType unionType)
traverseOutputType (Out.ListBaseType listType) =
traverseOutputType listType
traverseOutputType (Out.ScalarBaseType scalarType) =
let (Definition.ScalarType typeName _) = scalarType
in collect Prelude.id typeName (ScalarType scalarType)
traverseOutputType (Out.EnumBaseType enumType) =
let (Definition.EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseObjectType objectType foundTypes =
let (Out.ObjectType typeName _ interfaces fields) = objectType
element = ObjectType objectType
traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes =
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
element = InterfaceType interfaceType
traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
polymorphicTraverser interfaces fields
= flip (foldr visitFields) fields
. flip (foldr traverseInterfaceType) interfaces

80
src/Language/GraphQL/Type/Schema.hs
View File

@ -1,18 +1,10 @@
{-# LANGUAGE ExplicitForAll #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas.
module Language.GraphQL.Type.Schema
( AbstractType(..)
, CompositeType(..)
, Schema(..)
( Schema(..)
, Type(..)
, collectReferencedTypes
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
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
@ -27,19 +19,6 @@ data Type m
| UnionType (Out.UnionType m)
deriving Eq
-- | 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)
deriving Eq
-- | These types may describe the parent context of a selection set.
data AbstractType m
= AbstractUnionType (Out.UnionType m)
| AbstractInterfaceType (Out.InterfaceType m)
deriving Eq
-- | 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.
@ -51,60 +30,3 @@ data Schema m = Schema
{ query :: Out.ObjectType m
, mutation :: Maybe (Out.ObjectType m)
}
-- | Traverses the schema and finds all referenced types.
collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
collectReferencedTypes schema =
let queryTypes = traverseObjectType (query schema) HashMap.empty
in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
where
collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes
| otherwise = traverser $ HashMap.insert typeName element foundTypes
visitFields (Out.Field _ outputType arguments _) foundTypes
= traverseOutputType outputType
$ foldr visitArguments foundTypes arguments
visitArguments (In.Argument _ inputType _) = traverseInputType inputType
visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
traverseInputType (In.InputObjectBaseType objectType) =
let (In.InputObjectType typeName _ inputFields) = objectType
element = InputObjectType objectType
traverser = flip (foldr visitInputFields) inputFields
in collect traverser typeName element
traverseInputType (In.ListBaseType listType) =
traverseInputType listType
traverseInputType (In.ScalarBaseType scalarType) =
let (Definition.ScalarType typeName _) = scalarType
in collect Prelude.id typeName (ScalarType scalarType)
traverseInputType (In.EnumBaseType enumType) =
let (Definition.EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseOutputType (Out.ObjectBaseType objectType) =
traverseObjectType objectType
traverseOutputType (Out.InterfaceBaseType interfaceType) =
traverseInterfaceType interfaceType
traverseOutputType (Out.UnionBaseType unionType) =
let (Out.UnionType typeName _ types) = unionType
traverser = flip (foldr traverseObjectType) types
in collect traverser typeName (UnionType unionType)
traverseOutputType (Out.ListBaseType listType) =
traverseOutputType listType
traverseOutputType (Out.ScalarBaseType scalarType) =
let (Definition.ScalarType typeName _) = scalarType
in collect Prelude.id typeName (ScalarType scalarType)
traverseOutputType (Out.EnumBaseType enumType) =
let (Definition.EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseObjectType objectType foundTypes =
let (Out.ObjectType typeName _ interfaces fields) = objectType
element = ObjectType objectType
traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes =
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
element = InterfaceType interfaceType
traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
polymorphicTraverser interfaces fields
= flip (foldr visitFields) fields
. flip (foldr traverseInterfaceType) interfaces

2
stack.yaml
View File

@ -1,4 +1,4 @@
resolver: lts-16.3
resolver: lts-16.4
packages:
- .