From eb90a4091c1f2586640ee49d6f91fc83c05239f6 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 24 May 2020 13:51:00 +0200 Subject: [PATCH] Check point --- CHANGELOG.md | 17 ++-- src/Language/GraphQL/AST/Core.hs | 21 +---- src/Language/GraphQL/Execute/Coerce.hs | 63 +++++++------- src/Language/GraphQL/Execute/Transform.hs | 45 +++++----- src/Language/GraphQL/Schema.hs | 87 +++++++++----------- src/Language/GraphQL/Trans.hs | 7 +- src/Language/GraphQL/Type.hs | 63 -------------- src/Language/GraphQL/Type/Definition.hs | 20 ++--- src/Language/GraphQL/Type/Directive.hs | 5 +- src/Language/GraphQL/Type/In.hs | 26 ++++++ src/Language/GraphQL/Type/Out.hs | 58 +++++++++++++ tests/Language/GraphQL/Execute/CoerceSpec.hs | 35 ++++---- tests/Language/GraphQL/SchemaSpec.hs | 7 +- tests/Language/GraphQL/Type/OutSpec.hs | 15 ++++ tests/Test/DirectiveSpec.hs | 3 +- tests/Test/FragmentSpec.hs | 16 ++-- tests/Test/RootOperationSpec.hs | 11 ++- tests/Test/StarWars/Schema.hs | 53 ++++++------ 18 files changed, 281 insertions(+), 271 deletions(-) delete mode 100644 src/Language/GraphQL/Type.hs create mode 100644 src/Language/GraphQL/Type/In.hs create mode 100644 src/Language/GraphQL/Type/Out.hs create mode 100644 tests/Language/GraphQL/Type/OutSpec.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 66a3c5d..11e63bc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,27 +10,32 @@ and this project adheres to ### Fixed - The parser rejects variables when parsing defaultValue (DefaultValue). The specification defines default values as `Value` with `const` parameter and - constant cannot be variables. `AST.Document.ConstValue` was added, + constants cannot be variables. `AST.Document.ConstValue` was added, `AST.Document.ObjectField` was modified. - AST transformation should never fail. * Missing variable are assumed to be null. * Invalid (recusrive or non-existing) fragments should be skipped. ### Changed -- `Resolver` is now `Resolver Name FieldResolver` where `FieldResolver` can - contain a JSON value or another resolver, which is invoked during the - execution. `FieldResolver` is executed in `ActionT` and the current `Field` is - passed in the reader and not as an explicit argument. +- `Schema.Resolver` cannot return arbitrary JSON anymore, but only + `Type.Out.Value`. +- `Schema.object` takes an array of field resolvers (name, value pairs) and + returns a resolver (just the function). There is no need in special functions + to construct field resolvers anymore, they can be constructed with just + `Resolver "fieldName" $ pure $ object [...]`. - `Execute.Transform.operation` has the prior responsibility of `Execute.Transform.document`, but transforms only the chosen operation and not the whole document. `Execute.Transform.document` translates `AST.Document.Document` into `Execute.Transform.Document`. +- `AST.Core.Value` was moved into `Type.In`. Input values are used only in the + execution and type system, it is not a part of the parsing tree. ### Added - `Type.Definition` contains input and the most output types. - `Type.Schema` describes a schema. Both public functions that execute queries accept a `Schema` now instead of a `HashMap`. The execution fails if the root operation doesn't match the root Query type in the schema. +- `Type.In` and `Type.Out`. - `Execute.Coerce` defines a typeclass responsible for input, variable value coercion. It decouples us a bit from JSON since any format can be used to pass query variables. Execution functions accept (`HashMap Name a`) instead of @@ -45,6 +50,8 @@ and this project adheres to converted to JSON and JSON is not suitable as an internal representation for GraphQL. E.g. GraphQL distinguishes between Floats and Integersa and we need a way to represent objects as a "Field Name -> Resolver" map. +- `Schema.wrappedObject`. `Schema.object` creates now wrapped objects. +- `Type` module. Superseded by `Type.Out`. ## [0.7.0.0] - 2020-05-11 ### Fixed diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index d719912..6dcfb81 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -9,15 +9,13 @@ module Language.GraphQL.AST.Core , Operation(..) , Selection(..) , TypeCondition - , Value(..) ) where -import Data.Int (Int32) import Data.HashMap.Strict (HashMap) import Data.Sequence (Seq) -import Data.String (IsString(..)) 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. -- @@ -33,7 +31,7 @@ data Field deriving (Eq, Show) -- | Argument list. -newtype Arguments = Arguments (HashMap Name Value) +newtype Arguments = Arguments (HashMap Name In.Value) deriving (Eq, Show) instance Semigroup Arguments where @@ -56,18 +54,3 @@ data Selection = SelectionFragment Fragment | SelectionField Field deriving (Eq, Show) - --- | 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 diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 6997945..32c48fd 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -15,7 +15,8 @@ import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder.Int as Text.Builder import Data.Scientific (toBoundedInteger, toRealFloat) -import Language.GraphQL.AST.Core +import Language.GraphQL.AST.Document (Name) +import qualified Language.GraphQL.Type.In as In import Language.GraphQL.Schema import Language.GraphQL.Type.Definition @@ -46,26 +47,26 @@ class VariableValue a where coerceVariableValue :: InputType -- ^ Expected type (variable type given in the query). -> a -- ^ Variable value being coerced. - -> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise. + -> Maybe In.Value -- ^ Coerced value on success, 'Nothing' otherwise. instance VariableValue Aeson.Value where - coerceVariableValue _ Aeson.Null = Just Null + coerceVariableValue _ Aeson.Null = Just In.Null coerceVariableValue (ScalarInputTypeDefinition scalarType) value - | (Aeson.String stringValue) <- value = Just $ String stringValue - | (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue + | (Aeson.String stringValue) <- value = Just $ In.String stringValue + | (Aeson.Bool booleanValue) <- value = Just $ In.Boolean booleanValue | (Aeson.Number numberValue) <- value , (ScalarType "Float" _) <- scalarType = - Just $ Float $ toRealFloat numberValue + Just $ In.Float $ toRealFloat numberValue | (Aeson.Number numberValue) <- value = -- ID or Int - Int <$> toBoundedInteger numberValue + In.Int <$> toBoundedInteger numberValue coerceVariableValue (EnumInputTypeDefinition _) (Aeson.String stringValue) = - Just $ Enum stringValue + Just $ In.Enum stringValue coerceVariableValue (ObjectInputTypeDefinition objectType) value | (Aeson.Object objectValue) <- value = do let (InputObjectType _ _ inputFields) = objectType (newObjectValue, resultMap) <- foldWithKey objectValue inputFields if HashMap.null newObjectValue - then Just $ Object resultMap + then Just $ In.Object resultMap else Nothing where foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues @@ -81,7 +82,7 @@ instance VariableValue Aeson.Value where pure (newObjectValue, insert coerced) Nothing -> Just (objectValue, resultMap) coerceVariableValue (ListInputTypeDefinition listType) value - | (Aeson.Array arrayValue) <- value = List + | (Aeson.Array arrayValue) <- value = In.List <$> foldr foldVector (Just []) arrayValue | otherwise = coerceVariableValue listType value where @@ -95,7 +96,7 @@ instance VariableValue Aeson.Value where -- corresponding types. coerceInputLiterals :: HashMap Name InputType - -> HashMap Name Value + -> HashMap Name In.Value -> Maybe Subs coerceInputLiterals variableTypes variableValues = foldWithKey operator variableTypes @@ -105,34 +106,34 @@ coerceInputLiterals variableTypes variableValues = <$> (lookupVariable variableName >>= coerceInputLiteral variableType) <*> resultMap coerceInputLiteral (ScalarInputType type') 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 + | (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 , (ScalarType "Float" _) <- type' = - Just $ Float $ fromIntegral intValue - | (String stringValue) <- value - , (ScalarType "ID" _) <- type' = Just $ String stringValue - | (Int intValue) <- value + Just $ In.Float $ fromIntegral intValue + | (In.String stringValue) <- value + , (ScalarType "ID" _) <- type' = Just $ In.String stringValue + | (In.Int intValue) <- value , (ScalarType "ID" _) <- type' = Just $ decimal intValue - coerceInputLiteral (EnumInputType type') (Enum enumValue) - | member enumValue type' = Just $ Enum enumValue - coerceInputLiteral (ObjectInputType type') (Object _) = + coerceInputLiteral (EnumInputType type') (In.Enum enumValue) + | member enumValue type' = Just $ In.Enum enumValue + coerceInputLiteral (ObjectInputType type') (In.Object _) = let (InputObjectType _ _ inputFields) = type' - in Object <$> foldWithKey matchFieldValues inputFields + in In.Object <$> foldWithKey matchFieldValues inputFields coerceInputLiteral _ _ = Nothing member value (EnumType _ _ members) = Set.member value members matchFieldValues fieldName (InputField _ type' defaultValue) resultMap = case lookupVariable fieldName of - Just Null + Just In.Null | isNonNullInputType type' -> Nothing | otherwise -> - HashMap.insert fieldName Null <$> resultMap + HashMap.insert fieldName In.Null <$> resultMap Just variableValue -> HashMap.insert fieldName <$> coerceInputLiteral type' variableValue <*> resultMap @@ -144,7 +145,7 @@ coerceInputLiterals variableTypes variableValues = | otherwise -> resultMap lookupVariable = flip HashMap.lookup variableValues foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty) - decimal = String + decimal = In.String . Text.Lazy.toStrict . Text.Builder.toLazyText . Text.Builder.decimal diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index df64254..9768675 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -32,6 +32,7 @@ import Language.GraphQL.Execute.Coerce import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Directive as Directive +import qualified Language.GraphQL.Type.In as In import Language.GraphQL.Type.Schema -- | Associates a fragment name with a list of 'Core.Field's. @@ -136,23 +137,23 @@ coerceVariableValues schema operationDefinition variableValues' = <*> coercedValues choose Nothing defaultValue variableType | Just _ <- defaultValue = defaultValue - | not (isNonNullInputType variableType) = Just Core.Null + | not (isNonNullInputType variableType) = Just In.Null choose (Just value') _ variableType | Just coercedValue <- coerceVariableValue variableType value' - , not (isNonNullInputType variableType) || coercedValue /= Core.Null = + , not (isNonNullInputType variableType) || coercedValue /= In.Null = Just coercedValue choose _ _ _ = Nothing -constValue :: Full.ConstValue -> Core.Value -constValue (Full.ConstInt i) = Core.Int i -constValue (Full.ConstFloat f) = Core.Float f -constValue (Full.ConstString x) = Core.String x -constValue (Full.ConstBoolean b) = Core.Boolean b -constValue Full.ConstNull = Core.Null -constValue (Full.ConstEnum e) = Core.Enum e -constValue (Full.ConstList l) = Core.List $ constValue <$> l +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.ConstObject o) = - Core.Object $ HashMap.fromList $ constObjectField <$> o + In.Object $ HashMap.fromList $ constObjectField <$> o where constObjectField (Full.ObjectField key value') = (key, constValue value') @@ -294,19 +295,19 @@ arguments = fmap Core.Arguments . foldM go HashMap.empty substitutedValue <- value value' return $ HashMap.insert name substitutedValue arguments' -value :: Full.Value -> TransformT Core.Value +value :: Full.Value -> TransformT In.Value value (Full.Variable name) = - gets $ fromMaybe Core.Null . HashMap.lookup name . variableValues -value (Full.Int i) = pure $ Core.Int i -value (Full.Float f) = pure $ Core.Float f -value (Full.String x) = pure $ Core.String x -value (Full.Boolean b) = pure $ Core.Boolean b -value Full.Null = pure Core.Null -value (Full.Enum e) = pure $ Core.Enum e + 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) = - Core.List <$> traverse value l + In.List <$> traverse value l value (Full.Object o) = - Core.Object . HashMap.fromList <$> traverse objectField o + In.Object . HashMap.fromList <$> traverse objectField o -objectField :: Full.ObjectField Full.Value -> TransformT (Core.Name, Core.Value) +objectField :: Full.ObjectField Full.Value -> TransformT (Core.Name, In.Value) objectField (Full.ObjectField name value') = (name,) <$> value value' diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 69f697e..34abf10 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} -- | This module provides a representation of a @GraphQL@ Schema in addition to @@ -8,10 +9,6 @@ module Language.GraphQL.Schema , object , resolve , resolversToMap - , wrappedObject - -- * AST Reexports - , Field - , Value(..) ) where import Control.Monad.Trans.Class (lift) @@ -28,38 +25,35 @@ import qualified Data.Text as T import Language.GraphQL.AST.Core import Language.GraphQL.Error import Language.GraphQL.Trans -import qualified Language.GraphQL.Type.Definition as Definition -import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error --- information (if an error has occurred). @m@ is an arbitrary monad, usually --- 'IO'. -data Resolver m = Resolver Name (Definition.FieldResolver m) +-- information (if an error has occurred). @m@ is an arbitrary monad, usually +-- 'IO'. +-- +-- 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)) -- | Converts resolvers to a map. resolversToMap :: (Foldable f, Functor f) - => f (Resolver m) - -> HashMap Text (Definition.FieldResolver m) + => 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 Value +type Subs = HashMap Name In.Value --- | Like 'object' but can be null or a list of objects. -wrappedObject :: Monad m - => Name - -> ActionT m (Type.Wrapping (Definition.FieldResolver m)) - -> Resolver m -wrappedObject name = Resolver name . Definition.NestingResolver - --- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. -object :: Monad m - => [Resolver m] - -> Type.Wrapping (Definition.FieldResolver m) -object = Type.O . resolversToMap +-- | 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 _) = @@ -69,26 +63,25 @@ resolveFieldValue field@(Field _ _ args _) = withField :: Monad m => Field - -> Definition.FieldResolver m + -> ActionT m (Out.Value m) -> CollectErrsT m Aeson.Object -withField field (Definition.ValueResolver resolver) = do - answer <- lift $ resolveFieldValue field resolver - either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer -withField field (Definition.NestingResolver resolver) = do +withField field resolver = do answer <- lift $ resolveFieldValue field resolver case answer of - Right result -> HashMap.singleton (aliasOrName field) <$> toJSON field result + Right result -> HashMap.singleton (aliasOrName field) + <$> toJSON field result Left errorMessage -> errmsg field errorMessage -toJSON :: Monad m => Field -> Type.Wrapping (Definition.FieldResolver m) -> CollectErrsT m Aeson.Value -toJSON _ Type.Null = pure Aeson.Null -toJSON _ (Type.I i) = pure $ Aeson.toJSON i -toJSON _ (Type.B i) = pure $ Aeson.toJSON i -toJSON _ (Type.F i) = pure $ Aeson.toJSON i -toJSON _ (Type.E i) = pure $ Aeson.toJSON i -toJSON _ (Type.S i) = pure $ Aeson.toJSON i -toJSON field (Type.List list) = Aeson.toJSON <$> traverse (toJSON field) list -toJSON (Field _ _ _ seqSelection) (Type.O map') = map' `resolve` seqSelection +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 errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value) errmsg field errorMessage = do @@ -96,10 +89,10 @@ errmsg field errorMessage = do pure $ HashMap.singleton (aliasOrName field) 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. +-- 'Resolver' to each 'Field'. Resolves into a value containing the +-- resolved 'Field', or a null value and error information. resolve :: Monad m - => HashMap Text (Definition.FieldResolver m) + => HashMap Text (ActionT m (Out.Value m)) -> Seq Selection -> CollectErrsT m Aeson.Value resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers @@ -109,17 +102,11 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers | (Just resolver) <- lookupResolver name = withField fld resolver | otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."] tryResolvers (SelectionFragment (Fragment typeCondition selections')) - | Just (Definition.ValueResolver resolver) <- lookupResolver "__typename" = do - let fakeField = Field Nothing "__typename" mempty mempty - that <- lift $ resolveFieldValue fakeField resolver - if Right (Aeson.String typeCondition) == that - then fmap fold . traverse tryResolvers $ selections' - else pure mempty - | Just (Definition.NestingResolver resolver) <- lookupResolver "__typename" = do + | Just resolver <- lookupResolver "__typename" = do let fakeField = Field Nothing "__typename" mempty mempty that <- lift $ resolveFieldValue fakeField resolver case that of - Right (Type.S typeCondition') + Right (Out.String typeCondition') | typeCondition' == typeCondition -> fmap fold . traverse tryResolvers $ selections' _ -> pure mempty diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs index f09a8a0..3c3ffa4 100644 --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -15,6 +15,7 @@ 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 Prelude hiding (lookup) -- | Resolution context holds resolver arguments. @@ -55,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 'Value.Null' (i.e. the argument is assumed to +-- be found, returns 'In.Null' (i.e. the argument is assumed to -- be optional then). -argument :: Monad m => Name -> ActionT m Value +argument :: Monad m => Name -> ActionT m In.Value argument argumentName = do argumentValue <- ActionT $ lift $ asks $ lookup . arguments - pure $ fromMaybe Null argumentValue + pure $ fromMaybe In.Null argumentValue where lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs deleted file mode 100644 index 12b38dc..0000000 --- a/src/Language/GraphQL/Type.hs +++ /dev/null @@ -1,63 +0,0 @@ --- | Definitions for @GraphQL@ input types. -module Language.GraphQL.Type - ( Wrapping(..) - ) where - -import Data.HashMap.Strict (HashMap) -import Data.Text (Text) -import Language.GraphQL.AST.Document (Name) - --- | 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 'Wrapping' 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 Wrapping a - = List [Wrapping a] -- ^ Arbitrary nested list --- | Named a -- ^ Named type without further wrapping - | Null -- ^ Null - | O (HashMap Name a) - | I Int - | B Bool - | F Float - | E Text - | S Text - deriving (Eq, Show) - -instance Functor Wrapping where - fmap f (List list) = List $ fmap (fmap f) list - fmap f (O map') = O $ f <$> map' - fmap _ Null = Null - fmap _ (I i) = I i - fmap _ (B i) = B i - fmap _ (F i) = F i - fmap _ (E i) = E i - fmap _ (S i) = S i - - {-instance Foldable Wrapping where - foldr f acc (List list) = foldr (flip $ foldr f) acc list - foldr f acc (O map') = foldr f acc map' - foldr _ acc _ = acc -} - - {-instance Traversable Wrapping where - traverse f (List list) = List <$> traverse (traverse f) list - traverse f (Named named) = Named <$> f named - traverse _ Null = pure Null - traverse f (O map') = O <$> traverse f map'-} - -{-instance Applicative Wrapping where - pure = Named - Null <*> _ = Null - _ <*> Null = Null - (Named f) <*> (Named x) = Named $ f x - (List fs) <*> (List xs) = List $ (<*>) <$> fs <*> xs - (Named f) <*> list = f <$> list - (List fs) <*> named = List $ (<*> named) <$> fs - -instance Monad Wrapping where - return = pure - Null >>= _ = Null - (Named x) >>= f = f x - (List xs) >>= f = List $ fmap (>>= f) xs-} diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index 559611b..54eac85 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -8,7 +8,6 @@ module Language.GraphQL.Type.Definition ( Argument(..) , EnumType(..) , Field(..) - , FieldResolver(..) , InputField(..) , InputObjectType(..) , InputType(..) @@ -31,13 +30,13 @@ module Language.GraphQL.Type.Definition , string ) where -import qualified Data.Aeson as Aeson import Data.HashMap.Strict (HashMap) import Data.Set (Set) import Data.Text (Text) -import Language.GraphQL.AST.Core (Name, Value) +import Language.GraphQL.AST.Document (Name) import Language.GraphQL.Trans -import qualified Language.GraphQL.Type as Type +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out import Prelude hiding (id) -- | Object type definition. @@ -51,17 +50,10 @@ data Field m = Field (Maybe Text) -- ^ Description. (OutputType m) -- ^ Field type. (HashMap Name Argument) -- ^ Arguments. - (FieldResolver m) -- ^ Resolver. - --- | 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 FieldResolver m - = ValueResolver (ActionT m Aeson.Value) - | NestingResolver (ActionT m (Type.Wrapping (FieldResolver m))) + (ActionT m (Out.Value m)) -- ^ Resolver. -- | Field argument definition. -data Argument = Argument (Maybe Text) InputType (Maybe Value) +data Argument = Argument (Maybe Text) InputType (Maybe In.Value) -- | Scalar type definition. -- @@ -77,7 +69,7 @@ data ScalarType = ScalarType Name (Maybe Text) data EnumType = EnumType Name (Maybe Text) (Set Text) -- | Single field of an 'InputObjectType'. -data InputField = InputField (Maybe Text) InputType (Maybe Value) +data InputField = InputField (Maybe Text) InputType (Maybe In.Value) -- | Input object type definition. -- diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs index afd97da..9675df8 100644 --- a/src/Language/GraphQL/Type/Directive.hs +++ b/src/Language/GraphQL/Type/Directive.hs @@ -6,6 +6,7 @@ module Language.GraphQL.Type.Directive import qualified Data.HashMap.Strict as HashMap import Language.GraphQL.AST.Core +import qualified Language.GraphQL.Type.In as In -- | Directive processing status. data Status @@ -36,7 +37,7 @@ skip = handle skip' where skip' directive'@(Directive "skip" (Arguments arguments)) = case HashMap.lookup "if" arguments of - (Just (Boolean True)) -> Skip + (Just (In.Boolean True)) -> Skip _ -> Include directive' skip' directive' = Continue directive' @@ -45,6 +46,6 @@ include = handle include' where include' directive'@(Directive "include" (Arguments arguments)) = case HashMap.lookup "if" arguments of - (Just (Boolean True)) -> Include directive' + (Just (In.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 new file mode 100644 index 0000000..a6d35e2 --- /dev/null +++ b/src/Language/GraphQL/Type/In.hs @@ -0,0 +1,26 @@ +-- | This module is intended to be imported qualified, to avoid name clashes +-- with 'Language.GraphQL.Type.Out'. +module Language.GraphQL.Type.In + ( Value(..) + ) where + +import Data.HashMap.Strict (HashMap) +import Data.Int (Int32) +import Data.String (IsString(..)) +import Data.Text (Text) +import Language.GraphQL.AST.Document (Name) + +-- | 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 diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs new file mode 100644 index 0000000..96bc9cf --- /dev/null +++ b/src/Language/GraphQL/Type/Out.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This module is intended to be imported qualified, to avoid name clashes +-- with 'Language.GraphQL.Type.In'. +module Language.GraphQL.Type.Out + ( Value(..) + ) 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.Trans + +-- | 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 diff --git a/tests/Language/GraphQL/Execute/CoerceSpec.hs b/tests/Language/GraphQL/Execute/CoerceSpec.hs index 2ddab0c..57f740b 100644 --- a/tests/Language/GraphQL/Execute/CoerceSpec.hs +++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs @@ -15,6 +15,7 @@ import Language.GraphQL.AST.Core import Language.GraphQL.Execute.Coerce import Language.GraphQL.Schema import Language.GraphQL.Type.Definition +import qualified Language.GraphQL.Type.In as In import Prelude hiding (id) import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) @@ -22,12 +23,12 @@ direction :: EnumType direction = EnumType "Direction" Nothing $ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"] -coerceInputLiteral :: InputType -> Value -> Maybe Subs +coerceInputLiteral :: InputType -> In.Value -> Maybe Subs coerceInputLiteral input value = coerceInputLiterals (HashMap.singleton "variableName" input) (HashMap.singleton "variableName" value) -lookupActual :: Maybe (HashMap Name Value) -> Maybe Value +lookupActual :: Maybe (HashMap Name In.Value) -> Maybe In.Value lookupActual = (HashMap.lookup "variableName" =<<) singletonInputObject :: InputType @@ -41,22 +42,22 @@ spec :: Spec spec = do describe "ToGraphQL Aeson" $ do it "coerces strings" $ - let expected = Just (String "asdf") + let expected = Just (In.String "asdf") actual = coerceVariableValue (ScalarInputType string) (Aeson.String "asdf") in actual `shouldBe` expected it "coerces non-null strings" $ - let expected = Just (String "asdf") + let expected = Just (In.String "asdf") actual = coerceVariableValue (NonNullScalarInputType string) (Aeson.String "asdf") in actual `shouldBe` expected it "coerces booleans" $ - let expected = Just (Boolean True) + let expected = Just (In.Boolean True) actual = coerceVariableValue (ScalarInputType boolean) (Aeson.Bool True) in actual `shouldBe` expected it "coerces zero to an integer" $ - let expected = Just (Int 0) + let expected = Just (In.Int 0) actual = coerceVariableValue (ScalarInputType int) (Aeson.Number 0) in actual `shouldBe` expected @@ -65,24 +66,24 @@ spec = do (ScalarInputType int) (Aeson.Number $ scientific 14 (-1)) in actual `shouldSatisfy` isNothing it "coerces float numbers" $ - let expected = Just (Float 1.4) + let expected = Just (In.Float 1.4) actual = coerceVariableValue (ScalarInputType float) (Aeson.Number $ scientific 14 (-1)) in actual `shouldBe` expected it "coerces IDs" $ - let expected = Just (String "1234") + let expected = Just (In.String "1234") actual = coerceVariableValue (ScalarInputType id) (Aeson.String "1234") in actual `shouldBe` expected it "coerces input objects" $ let actual = coerceVariableValue singletonInputObject $ Aeson.object ["field" .= ("asdf" :: Aeson.Value)] - expected = Just $ Object $ HashMap.singleton "field" "asdf" + expected = Just $ In.Object $ HashMap.singleton "field" "asdf" in actual `shouldBe` expected it "skips the field if it is missing in the variables" $ let actual = coerceVariableValue singletonInputObject Aeson.emptyObject - expected = Just $ Object HashMap.empty + expected = Just $ In.Object HashMap.empty in actual `shouldBe` expected it "fails if input object value contains extra fields" $ let actual = coerceVariableValue singletonInputObject @@ -94,25 +95,25 @@ spec = do in actual `shouldSatisfy` isNothing it "preserves null" $ let actual = coerceVariableValue (ScalarInputType id) Aeson.Null - in actual `shouldBe` Just Null + in actual `shouldBe` Just In.Null it "preserves list order" $ let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"] listType = (ListInputType $ ScalarInputType string) actual = coerceVariableValue listType list - expected = Just $ List [String "asdf", String "qwer"] + expected = Just $ In.List [In.String "asdf", In.String "qwer"] in actual `shouldBe` expected describe "coerceInputLiterals" $ do it "coerces enums" $ - let expected = Just (Enum "NORTH") + let expected = Just (In.Enum "NORTH") actual = coerceInputLiteral - (EnumInputType direction) (Enum "NORTH") + (EnumInputType direction) (In.Enum "NORTH") in lookupActual actual `shouldBe` expected it "fails with non-existing enum value" $ let actual = coerceInputLiteral - (EnumInputType direction) (Enum "NORTH_EAST") + (EnumInputType direction) (In.Enum "NORTH_EAST") in actual `shouldSatisfy` isNothing it "coerces integers to IDs" $ - let expected = Just (String "1234") - actual = coerceInputLiteral (ScalarInputType id) (Int 1234) + let expected = Just (In.String "1234") + actual = coerceInputLiteral (ScalarInputType id) (In.Int 1234) in lookupActual actual `shouldBe` expected diff --git a/tests/Language/GraphQL/SchemaSpec.hs b/tests/Language/GraphQL/SchemaSpec.hs index a5d37c0..9bc5530 100644 --- a/tests/Language/GraphQL/SchemaSpec.hs +++ b/tests/Language/GraphQL/SchemaSpec.hs @@ -10,16 +10,15 @@ import qualified Data.Sequence as Sequence import Language.GraphQL.AST.Core import Language.GraphQL.Error import Language.GraphQL.Schema -import qualified Language.GraphQL.Type as Type -import Language.GraphQL.Type.Definition +import qualified Language.GraphQL.Type.Out as Out import Test.Hspec (Spec, describe, it, shouldBe) spec :: Spec spec = describe "resolve" $ it "ignores invalid __typename" $ do - let resolver = NestingResolver $ pure $ object - [ wrappedObject "field" $ pure $ Type.S "T" + let resolver = pure $ object + [ Resolver "field" $ pure $ Out.String "T" ] schema = HashMap.singleton "__typename" resolver fields = Sequence.singleton diff --git a/tests/Language/GraphQL/Type/OutSpec.hs b/tests/Language/GraphQL/Type/OutSpec.hs new file mode 100644 index 0000000..48b7fa4 --- /dev/null +++ b/tests/Language/GraphQL/Type/OutSpec.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.GraphQL.Type.OutSpec + ( spec + ) where + +import Data.Functor.Identity (Identity) +import qualified Language.GraphQL.Type.Out as Out +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = + describe "Value" $ + it "supports overloaded strings" $ + let string = "Goldstaub abblasen." :: (Out.Value Identity) + in string `shouldBe` Out.String "Goldstaub abblasen." diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 74167c9..250ef6e 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -8,6 +8,7 @@ import Data.Aeson (Value(..), object, (.=)) import qualified Data.HashMap.Strict as HashMap import Language.GraphQL import Language.GraphQL.Type.Definition +import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema (Schema(..)) import Test.Hspec (Spec, describe, it, shouldBe) import Text.RawString.QQ (r) @@ -15,7 +16,7 @@ import Text.RawString.QQ (r) experimentalResolver :: Schema IO experimentalResolver = Schema { query = queryType, mutation = Nothing } where - resolver = ValueResolver $ pure $ Number 5 + resolver = pure $ Out.Int 5 queryType = ObjectType "Query" Nothing $ HashMap.singleton "experimentalField" $ Field Nothing (ScalarOutputType int) mempty resolver diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 1616865..5ebecab 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -9,7 +9,9 @@ import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Language.GraphQL import qualified Language.GraphQL.Schema as Schema -import qualified Language.GraphQL.Type as Type +import Language.GraphQL.Type.Definition +import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Schema import Test.Hspec ( Spec , describe @@ -17,21 +19,19 @@ import Test.Hspec , shouldBe , shouldNotSatisfy ) -import Language.GraphQL.Type.Definition -import Language.GraphQL.Type.Schema import Text.RawString.QQ (r) size :: Schema.Resolver IO -size = Schema.wrappedObject "size" $ pure $ Type.S "L" +size = Schema.Resolver "size" $ pure $ Out.String "L" circumference :: Schema.Resolver IO -circumference = Schema.wrappedObject "circumference" $ pure $ Type.I 60 +circumference = Schema.Resolver "circumference" $ pure $ Out.Int 60 garment :: Text -> Schema.Resolver IO -garment typeName = Schema.wrappedObject "garment" +garment typeName = Schema.Resolver "garment" $ pure $ Schema.object [ if typeName == "Hat" then circumference else size - , Schema.wrappedObject "__typename" $ pure $ Type.S typeName + , Schema.Resolver "__typename" $ pure $ Out.String typeName ] inlineQuery :: Text @@ -107,7 +107,7 @@ spec = do } } }|] - resolvers = Schema.wrappedObject "garment" + resolvers = Schema.Resolver "garment" $ pure $ Schema.object [circumference, size] actual <- graphql (toSchema resolvers) sourceQuery diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 935b96d..7e20e64 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -11,8 +11,8 @@ import qualified Language.GraphQL.Schema as Schema import Test.Hspec (Spec, describe, it, shouldBe) import Text.RawString.QQ (r) import Language.GraphQL.Type.Definition +import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema -import qualified Language.GraphQL.Type as Type hatType :: ObjectType IO hatType = ObjectType "Hat" Nothing @@ -20,20 +20,19 @@ hatType = ObjectType "Hat" Nothing $ Field Nothing (ScalarOutputType int) mempty resolve where (Schema.Resolver resolverName resolve) = - Schema.wrappedObject "circumference" $ pure $ Type.I 60 + Schema.Resolver "circumference" $ pure $ Out.Int 60 schema :: Schema IO schema = Schema (ObjectType "Query" Nothing hatField) (Just $ ObjectType "Mutation" Nothing incrementField) where - garment = NestingResolver - $ pure $ Schema.object - [ Schema.wrappedObject "circumference" $ pure $ Type.I 60 + garment = pure $ Schema.object + [ Schema.Resolver "circumference" $ pure $ Out.Int 60 ] incrementField = HashMap.singleton "incrementCircumference" $ Field Nothing (ScalarOutputType int) mempty - $ NestingResolver $ pure $ Type.I 61 + $ pure $ Out.Int 61 hatField = HashMap.singleton "garment" $ Field Nothing (ObjectOutputType hatType) mempty garment diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 5e702e0..993672c 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -15,7 +15,8 @@ import Data.Maybe (catMaybes) import qualified Language.GraphQL.Schema as Schema import Language.GraphQL.Trans import Language.GraphQL.Type.Definition -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.Schema import Test.StarWars.Data @@ -30,45 +31,45 @@ schema = Schema { query = queryType, mutation = Nothing } , ("droid", Field Nothing (ScalarOutputType string) mempty droid) ] -hero :: FieldResolver Identity -hero = NestingResolver $ do +hero :: ActionT Identity (Out.Value Identity) +hero = do episode <- argument "episode" pure $ character $ case episode of - Schema.Enum "NEWHOPE" -> getHero 4 - Schema.Enum "EMPIRE" -> getHero 5 - Schema.Enum "JEDI" -> getHero 6 + In.Enum "NEWHOPE" -> getHero 4 + In.Enum "EMPIRE" -> getHero 5 + In.Enum "JEDI" -> getHero 6 _ -> artoo -human :: FieldResolver Identity -human = NestingResolver $ do +human :: ActionT Identity (Out.Value Identity) +human = do id' <- argument "id" case id' of - Schema.String i -> do + In.String i -> do humanCharacter <- lift $ return $ getHuman i >>= Just case humanCharacter of - Nothing -> pure Type.Null + Nothing -> pure Out.Null Just e -> pure $ character e _ -> ActionT $ throwE "Invalid arguments." -droid :: FieldResolver Identity -droid = NestingResolver $ do +droid :: ActionT Identity (Out.Value Identity) +droid = do id' <- argument "id" case id' of - Schema.String i -> getDroid i >>= pure . character + In.String i -> getDroid i >>= pure . character _ -> ActionT $ throwE "Invalid arguments." -character :: Character -> Type.Wrapping (FieldResolver Identity) +character :: Character -> Out.Value Identity character char = Schema.object - [ Schema.wrappedObject "id" $ pure $ Type.S $ id_ char - , Schema.wrappedObject "name" $ pure $ Type.S $ name_ char - , Schema.wrappedObject "friends" - $ pure - $ Type.List - $ fmap character - $ getFriends char - , Schema.wrappedObject "appearsIn" $ pure - $ Type.List $ Type.E <$> catMaybes (getEpisode <$> appearsIn char) - , Schema.wrappedObject "secretBackstory" $ Type.S <$> secretBackstory char - , Schema.wrappedObject "homePlanet" $ pure $ Type.S $ either mempty homePlanet char - , Schema.wrappedObject "__typename" $ pure $ Type.S $ typeName char + [ Schema.Resolver "id" $ pure $ Out.String $ id_ char + , Schema.Resolver "name" $ pure $ Out.String $ name_ char + , Schema.Resolver "friends" + $ pure $ Out.List $ fmap character $ getFriends char + , Schema.Resolver "appearsIn" $ pure + $ Out.List $ Out.Enum <$> catMaybes (getEpisode <$> appearsIn char) + , Schema.Resolver "secretBackstory" $ Out.String + <$> secretBackstory char + , Schema.Resolver "homePlanet" $ pure $ Out.String + $ either mempty homePlanet char + , Schema.Resolver "__typename" $ pure $ Out.String + $ typeName char ]