From b2d473de8dac0f85f11a8f9985d1a9a4dfee03ab Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Mon, 6 Jul 2020 19:10:34 +0200 Subject: Export sum type for all GraphQL types --- src/Language/GraphQL/Type/Definition.hs | 51 +++++++++++++++++++- src/Language/GraphQL/Type/Directive.hs | 56 ---------------------- src/Language/GraphQL/Type/Internal.hs | 85 +++++++++++++++++++++++++++++++++ src/Language/GraphQL/Type/Schema.hs | 80 +------------------------------ 4 files changed, 136 insertions(+), 136 deletions(-) delete mode 100644 src/Language/GraphQL/Type/Directive.hs create mode 100644 src/Language/GraphQL/Type/Internal.hs (limited to 'src/Language/GraphQL/Type') diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index 40055e7..476fb3a 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -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' diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs deleted file mode 100644 index 6ff73d4..0000000 --- a/src/Language/GraphQL/Type/Directive.hs +++ /dev/null @@ -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' diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs new file mode 100644 index 0000000..07dabe6 --- /dev/null +++ b/src/Language/GraphQL/Type/Internal.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 4420cbb..8cf0383 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -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 -- cgit v1.2.3