Don't fail on invalid fragments and variables

CHANGELOG.md

@@ -12,6 +12,9 @@ and this project adheres to
   specification defines default values as `Value` with `const` parameter and
   constant 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
@@ -36,9 +39,12 @@ and this project adheres to
 ### Removed
 - `AST.Core.Document`. Transforming the whole document is probably not
   reasonable since a document can define multiple operations and we're
-  interested only in one of them. Therefore `Document` was modified and moved to
-  `Execute.Transform`. It contains only slightly modified AST used to pick the
-  operation.
+  interested only in one of them. Therefore `Document` was modified, moved to
+  `Execute.Transform` and made private.
+- `Schema.scalar`, `Schema.wrappedScalar`. They accepted everything can be
+  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.
 
 ## [0.7.0.0] - 2020-05-11
 ### Fixed

docs/tutorial/tutorial.lhs

@@ -17,14 +17,15 @@ Since this file is a literate haskell file, we start by importing some dependenc
 > import Control.Monad.IO.Class (liftIO)
 > import Data.Aeson (encode)
 > import Data.ByteString.Lazy.Char8 (putStrLn)
-> import Data.List.NonEmpty (NonEmpty(..))
+> import qualified Data.HashMap.Strict as HashMap
 > import Data.Text (Text)
+> import qualified Data.Text as Text
 > import Data.Time (getCurrentTime)
 >
 > import Language.GraphQL
-> import qualified Language.GraphQL.Schema as Schema
 > import Language.GraphQL.Type.Definition
 > import Language.GraphQL.Type.Schema
+> import qualified Language.GraphQL.Type as Type
 >
 > import Prelude hiding (putStrLn)
 
@@ -39,12 +40,12 @@ First we build a GraphQL schema.
 > schema1 = Schema queryType Nothing
 >
 > queryType :: ObjectType IO
-> queryType = ObjectType "Query"
->   $ Field Nothing (ScalarOutputType string) mempty
->   <$> Schema.resolversToMap (hello :| [])
+> queryType = ObjectType "Query" Nothing
+>   $ HashMap.singleton "hello"
+>   $ Field Nothing (ScalarOutputType string) mempty hello
 >
-> hello :: Schema.Resolver IO
-> hello = Schema.scalar "hello" (return ("it's me" :: Text))
+> hello :: FieldResolver IO
+> hello = NestingResolver $ pure $ Type.S "it's me"
 
 This defines a simple schema with one type and one field, that resolves to a fixed value.
 
@@ -74,14 +75,14 @@ For this example, we're going to be using time.
 > schema2 = Schema queryType2 Nothing
 >
 > queryType2 :: ObjectType IO
-> queryType2 = ObjectType "Query"
->   $ Field Nothing (ScalarOutputType string) mempty
->   <$> Schema.resolversToMap (time :| [])
+> queryType2 = ObjectType "Query" Nothing
+>   $ HashMap.singleton "time"
+>   $ Field Nothing (ScalarOutputType string) mempty time
 >
-> time :: Schema.Resolver IO
-> time = Schema.scalar "time" $ do
+> time :: FieldResolver IO
+> time = NestingResolver $ do
 >   t <- liftIO getCurrentTime
->   return $ show t
+>   pure $ Type.S $ Text.pack $ show t
 
 This defines a simple schema with one type and one field,
 which resolves to the current time.
@@ -138,9 +139,10 @@ Now that we have two resolvers, we can define a schema which uses them both.
 > schema3 = Schema queryType3 Nothing
 >
 > queryType3 :: ObjectType IO
-> queryType3 = ObjectType "Query"
->   $ Field Nothing (ScalarOutputType string) mempty
->   <$> Schema.resolversToMap (hello :| [time])
+> queryType3 = ObjectType "Query" Nothing $ HashMap.fromList
+>   [ ("hello", Field Nothing (ScalarOutputType string) mempty hello)
+>   , ("time", Field Nothing (ScalarOutputType string) mempty time)
+>   ]
 >
 > query3 :: Text
 > query3 = "query timeAndHello { time hello }"

package.yaml

@@ -35,6 +35,7 @@ dependencies:
 - text
 - transformers
 - unordered-containers
+- vector
 
 library:
   source-dirs: src

src/Language/GraphQL/Execute.hs

@@ -54,7 +54,7 @@ document :: (Monad m, VariableValue a)
 document schema operationName subs document' =
     case Transform.document schema operationName subs document' of
         Left queryError -> pure $ singleError $ Transform.queryError queryError
-        Right (Transform.Document op _) -> operation schema op
+        Right (Transform.Document operation') -> operation schema operation'
 
 operation :: Monad m
     => Schema m
@@ -65,7 +65,8 @@ operation = schemaOperation
     resolve queryFields = runCollectErrs
         . flip Schema.resolve queryFields
         . fmap getResolver
-        . Definition.fields
+        . fields
+    fields (Definition.ObjectType _ _ objectFields) = objectFields
     lookupError = pure
         $ singleError "Root operation type couldn't be found in the schema."
     schemaOperation Schema {query} (AST.Core.Query _ fields') =

src/Language/GraphQL/Execute/Coerce.hs

@@ -4,6 +4,7 @@
 module Language.GraphQL.Execute.Coerce
     ( VariableValue(..)
     , coerceInputLiterals
+    , isNonNullInputType
     ) where
 
 import qualified Data.Aeson as Aeson
@@ -148,6 +149,7 @@ coerceInputLiterals variableTypes variableValues =
         . Text.Builder.toLazyText
         . Text.Builder.decimal
 
+-- | Checks whether the given input type is a non-null type.
 isNonNullInputType :: InputType -> Bool
 isNonNullInputType (NonNullScalarInputType _) = True
 isNonNullInputType (NonNullEnumInputType _) = True

src/Language/GraphQL/Execute/Transform.hs

@@ -15,11 +15,12 @@ module Language.GraphQL.Execute.Transform
 
 import Control.Monad (foldM, unless)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
-import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
+import Control.Monad.Trans.State (State, evalStateT, gets, modify)
 import Data.Foldable (find)
+import Data.Functor.Identity (Identity(..))
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe (fromMaybe)
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq, (<|), (><))
@@ -37,17 +38,13 @@ import Language.GraphQL.Type.Schema
 data Replacement = Replacement
     { fragments :: HashMap Core.Name Core.Fragment
     , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+    , variableValues :: Schema.Subs
     }
 
-type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
-
-liftJust :: forall a. a -> TransformT a
-liftJust = lift . lift . Just
+type TransformT a = State Replacement a
 
 -- | GraphQL document is a non-empty list of operations.
-data Document = Document
-    Core.Operation
-    (HashMap Full.Name Full.FragmentDefinition)
+newtype Document = Document Core.Operation
 
 data OperationDefinition = OperationDefinition
     Full.OperationType
@@ -120,18 +117,44 @@ coerceVariableValues :: (Monad m, VariableValue a)
     -> OperationDefinition
     -> HashMap.HashMap Full.Name a
     -> Either QueryError Schema.Subs
-coerceVariableValues schema (OperationDefinition _ _ variables _ _) values =
+coerceVariableValues schema operationDefinition variableValues' =
     let referencedTypes = collectReferencedTypes schema
+        OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
+        coerceValue' = coerceValue referencedTypes
      in maybe (Left CoercionError) Right
-        $ foldr (coerceValue referencedTypes) (Just HashMap.empty) variables
+        $ foldr coerceValue' (Just HashMap.empty) variableDefinitions
   where
     coerceValue referencedTypes variableDefinition coercedValues = do
-        let Full.VariableDefinition variableName variableTypeName _defaultValue =
+        let Full.VariableDefinition variableName variableTypeName defaultValue =
                 variableDefinition
+        let defaultValue' = constValue <$> defaultValue
+        let value' = HashMap.lookup variableName variableValues'
+
         variableType <- lookupInputType variableTypeName referencedTypes
-        value' <- HashMap.lookup variableName values
-        coercedValue <- coerceVariableValue variableType value'
-        HashMap.insert variableName coercedValue <$> coercedValues
+        HashMap.insert variableName
+            <$> choose value' defaultValue' variableType
+            <*> coercedValues
+    choose Nothing defaultValue variableType
+        | Just _ <- defaultValue = defaultValue
+        | not (isNonNullInputType variableType) = Just Core.Null
+    choose (Just value') _ variableType
+        | Just coercedValue <- coerceVariableValue variableType value'
+        , not (isNonNullInputType variableType) || coercedValue /= Core.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.ConstObject o) =
+    Core.Object $ HashMap.fromList $ constObjectField <$> o
+  where
+    constObjectField (Full.ObjectField key value') = (key, constValue value')
 
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
@@ -148,10 +171,8 @@ document schema operationName subs ast = do
     chosenOperation <- getOperation operationName nonEmptyOperations
     coercedValues <- coerceVariableValues schema chosenOperation subs
 
-    maybe (Left TransformationError) Right
-        $ Document
-        <$> operation fragmentTable coercedValues chosenOperation
-        <*> pure fragmentTable
+    pure $ Document
+        $ operation fragmentTable coercedValues chosenOperation
   where
     defragment definition (operations, fragments')
         | (Full.ExecutableDefinition executable) <- definition
@@ -174,10 +195,11 @@ operation
     :: HashMap Full.Name Full.FragmentDefinition
     -> Schema.Subs
     -> OperationDefinition
-    -> Maybe Core.Operation
-operation fragmentTable subs operationDefinition = flip runReaderT subs
+    -> Core.Operation
+operation fragmentTable subs operationDefinition
+    = runIdentity
     $ evalStateT (collectFragments >> transform operationDefinition)
-    $ Replacement HashMap.empty fragmentTable
+    $ Replacement HashMap.empty fragmentTable subs
   where
     transform :: OperationDefinition -> TransformT Core.Operation
     transform (OperationDefinition Full.Query name _ _ sels) =
@@ -201,13 +223,15 @@ selection (Full.FragmentSpread name directives') =
     maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
         spreadDirectives <- Directive.selection <$> directives directives'
         fragments' <- gets fragments
-        fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
-        pure $ fragment <$ spreadDirectives
-  where
-    lookupDefinition = do
+
         fragmentDefinitions' <- gets fragmentDefinitions
-        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
-        fragmentDefinition found
+        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
+                             lift $ pure $ fragment <$ spreadDirectives
+                         Nothing -> lift $ pure  Nothing
 selection (Full.InlineFragment type' directives' selections) = do
     fragmentDirectives <- Directive.selection <$> directives directives'
     case fragmentDirectives of
@@ -255,13 +279,13 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
     fragmentSelection <- appendSelection selections
     let newValue = Core.Fragment type' fragmentSelection
     modify $ insertFragment newValue
-    liftJust newValue
+    lift $ pure newValue
   where
-    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =
-        Replacement fragments' $ HashMap.delete name fragmentDefinitions'
-    insertFragment newValue (Replacement fragments' fragmentDefinitions') =
+    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions' subs) =
+        Replacement fragments' (HashMap.delete name fragmentDefinitions') subs
+    insertFragment newValue (Replacement fragments' fragmentDefinitions' subs) =
         let newFragments = HashMap.insert name newValue fragments'
-         in Replacement newFragments fragmentDefinitions'
+         in Replacement newFragments fragmentDefinitions' subs
 
 arguments :: [Full.Argument] -> TransformT Core.Arguments
 arguments = fmap Core.Arguments . foldM go HashMap.empty
@@ -271,7 +295,8 @@ arguments = fmap Core.Arguments . foldM go HashMap.empty
         return $ HashMap.insert name substitutedValue arguments'
 
 value :: Full.Value -> TransformT Core.Value
-value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
+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

src/Language/GraphQL/Schema.hs

@@ -8,9 +8,7 @@ module Language.GraphQL.Schema
     , object
     , resolve
     , resolversToMap
-    , scalar
     , wrappedObject
-    , wrappedScalar
     -- * AST Reexports
     , Field
     , Value(..)
@@ -50,31 +48,18 @@ resolversToMap = HashMap.fromList . toList . fmap toKV
 --   and the value is the variable value.
 type Subs = HashMap Name Value
 
--- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
-object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
-object name = Resolver name
-    . Definition.NestingResolver
-    . fmap (Type.Named . resolversToMap)
-
 -- | Like 'object' but can be null or a list of objects.
 wrappedObject :: Monad m
     => Name
-    -> ActionT m (Type.Wrapping [Resolver m])
+    -> ActionT m (Type.Wrapping (Definition.FieldResolver m))
     -> Resolver m
-wrappedObject name = Resolver name
-    . Definition.NestingResolver
-    . (fmap . fmap) resolversToMap
+wrappedObject name = Resolver name . Definition.NestingResolver
 
--- | A scalar represents a primitive value, like a string or an integer.
-scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
-scalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
-
--- | Like 'scalar' but can be null or a list of scalars.
-wrappedScalar :: (Monad m, Aeson.ToJSON a)
-    => Name
-    -> ActionT m (Type.Wrapping a)
-    -> Resolver m
-wrappedScalar name = Resolver name . Definition.ValueResolver . fmap Aeson.toJSON
+-- | 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
 
 resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
 resolveFieldValue field@(Field _ _ args _) =
@@ -82,11 +67,6 @@ resolveFieldValue field@(Field _ _ args _) =
     . runExceptT
     . runActionT
 
-convert :: Type.Wrapping Aeson.Value -> Aeson.Value
-convert Type.Null = Aeson.Null
-convert (Type.Named value) = value
-convert (Type.List value) = Aeson.toJSON value
-
 withField :: Monad m
     => Field
     -> Definition.FieldResolver m
@@ -94,14 +74,22 @@ withField :: Monad m
 withField field (Definition.ValueResolver resolver) = do
     answer <- lift $ resolveFieldValue field resolver
     either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
-withField field@(Field _ _ _ seqSelection) (Definition.NestingResolver resolver) = do
+withField field (Definition.NestingResolver resolver) = do
     answer <- lift $ resolveFieldValue field resolver
     case answer of
-        Right result -> do
-            nestedFields <- traverse (`resolve` seqSelection) result
-            pure $ HashMap.singleton (aliasOrName field) $ convert nestedFields
+        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
+
 errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value)
 errmsg field errorMessage = do
     addErrMsg errorMessage
@@ -127,6 +115,14 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
             if Right (Aeson.String typeCondition) == that
                 then fmap fold . traverse tryResolvers $ selections'
                 else pure mempty
+        | Just (Definition.NestingResolver resolver) <- lookupResolver "__typename" = do
+            let fakeField = Field Nothing "__typename" mempty mempty
+            that <- lift $ resolveFieldValue fakeField resolver
+            case that of
+                Right (Type.S typeCondition')
+                    | typeCondition' == typeCondition ->
+                        fmap fold . traverse tryResolvers $ selections'
+                _ -> pure mempty
         | otherwise = fmap fold . traverse tryResolvers $ selections'
 
 aliasOrName :: Field -> Text

src/Language/GraphQL/Type.hs

@@ -3,8 +3,9 @@ module Language.GraphQL.Type
     ( Wrapping(..)
     ) where
 
-import Data.Aeson as Aeson (ToJSON, toJSON)
-import qualified Data.Aeson as Aeson
+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
@@ -15,26 +16,38 @@ import qualified Data.Aeson as Aeson
 --   nullable or an (arbitrary nested) list.
 data Wrapping a
     = List [Wrapping a] -- ^ Arbitrary nested list
-    | Named a -- ^ Named type without further wrapping
+--    | 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 (Named named) = Named $ f named
+    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
+    {-instance Foldable Wrapping where
     foldr f acc (List list) = foldr (flip $ foldr f) acc list
-    foldr f acc (Named named) = f named acc
-    foldr _ acc Null = acc
+    foldr f acc (O map') = foldr f acc map'
+    foldr _ acc _ = acc -}
 
-instance Traversable Wrapping where
+    {-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
+{-instance Applicative Wrapping where
     pure = Named
     Null <*> _ = Null
     _ <*> Null = Null
@@ -47,9 +60,4 @@ instance Monad Wrapping where
     return = pure
     Null >>= _ = Null
     (Named x) >>= f = f x
-    (List xs) >>= f = List $ fmap (>>= f) xs
-
-instance ToJSON a => ToJSON (Wrapping a) where
-    toJSON (List list) = toJSON list
-    toJSON (Named named) = toJSON named
-    toJSON Null = Aeson.Null
+    (List xs) >>= f = List $ fmap (>>= f) xs-}

src/Language/GraphQL/Type/Definition.hs

@@ -44,21 +44,21 @@ import Prelude hiding (id)
 --
 --   Almost all of the GraphQL types you define will be object types. Object
 --   types have a name, but most importantly describe their fields.
-data ObjectType m = ObjectType
-    { name :: Text
-    , fields :: HashMap Name (Field m)
-    }
+data ObjectType m = ObjectType Name (Maybe Text) (HashMap Name (Field m))
 
 -- | Output object field definition.
 data Field m = Field
-    (Maybe Text) (OutputType m) (HashMap Name Argument) (FieldResolver m)
+    (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 (HashMap Name (FieldResolver m))))
+    | NestingResolver (ActionT m (Type.Wrapping (FieldResolver m)))
 
 -- | Field argument definition.
 data Argument = Argument (Maybe Text) InputType (Maybe Value)

src/Language/GraphQL/Type/Schema.hs

@@ -62,7 +62,7 @@ collectReferencedTypes schema =
         let (EnumType typeName _ _) = enumType
          in collect Prelude.id typeName (EnumTypeDefinition enumType)
     traverseObjectType objectType foundTypes =
-        let (ObjectType typeName objectFields) = objectType
+        let (ObjectType typeName _ objectFields) = objectType
             element = ObjectTypeDefinition objectType
             traverser = flip (foldr visitFields) objectFields
          in collect traverser typeName element foundTypes

tests/Language/GraphQL/SchemaSpec.hs

@@ -5,21 +5,23 @@ module Language.GraphQL.SchemaSpec
 
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
+import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Sequence as Sequence
-import Data.Text (Text)
 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 Test.Hspec (Spec, describe, it, shouldBe)
 
 spec :: Spec
 spec =
     describe "resolve" $
         it "ignores invalid __typename" $ do
-            let resolver = object "__typename" $ pure
-                    [ scalar "field" $ pure ("T" :: Text)
+            let resolver = NestingResolver $ pure $ object
+                    [ wrappedObject "field" $ pure $ Type.S "T"
                     ]
-                schema = resolversToMap [resolver]
+                schema = HashMap.singleton "__typename" resolver
                 fields = Sequence.singleton
                     $ SelectionFragment
                     $ Fragment "T" Sequence.empty

tests/Test/DirectiveSpec.hs

@@ -16,7 +16,7 @@ experimentalResolver :: Schema IO
 experimentalResolver = Schema { query = queryType, mutation = Nothing }
   where
     resolver = ValueResolver $ pure $ Number 5
-    queryType = ObjectType "Query"
+    queryType = ObjectType "Query" Nothing
         $ HashMap.singleton "experimentalField"
         $ Field Nothing (ScalarOutputType int) mempty resolver
 

tests/Test/FragmentSpec.hs

@@ -9,12 +9,12 @@ 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 Test.Hspec
     ( Spec
     , describe
     , it
     , shouldBe
-    , shouldSatisfy
     , shouldNotSatisfy
     )
 import Language.GraphQL.Type.Definition
@@ -22,15 +22,16 @@ import Language.GraphQL.Type.Schema
 import Text.RawString.QQ (r)
 
 size :: Schema.Resolver IO
-size = Schema.scalar "size" $ return ("L" :: Text)
+size = Schema.wrappedObject "size" $ pure $ Type.S "L"
 
 circumference :: Schema.Resolver IO
-circumference = Schema.scalar "circumference" $ return (60 :: Int)
+circumference = Schema.wrappedObject "circumference" $ pure $ Type.I 60
 
 garment :: Text -> Schema.Resolver IO
-garment typeName = Schema.object "garment" $ return
+garment typeName = Schema.wrappedObject "garment"
+    $ pure $ Schema.object
     [ if typeName == "Hat" then circumference else size
-    , Schema.scalar "__typename" $ return typeName
+    , Schema.wrappedObject "__typename" $ pure $ Type.S typeName
     ]
 
 inlineQuery :: Text
@@ -50,14 +51,14 @@ hasErrors (Object object') = HashMap.member "errors" object'
 hasErrors _ = True
 
 shirtType :: ObjectType IO
-shirtType = ObjectType "Shirt"
+shirtType = ObjectType "Shirt" Nothing
     $ HashMap.singleton resolverName
     $ Field Nothing (ScalarOutputType string) mempty resolve
   where
     (Schema.Resolver resolverName resolve) = size
 
 hatType :: ObjectType IO
-hatType = ObjectType "Hat"
+hatType = ObjectType "Hat" Nothing
     $ HashMap.singleton resolverName
     $ Field Nothing (ScalarOutputType int) mempty resolve
   where
@@ -68,7 +69,7 @@ toSchema (Schema.Resolver resolverName resolve) = Schema
     { query = queryType, mutation = Nothing }
   where
     unionMember = if resolverName == "Hat" then hatType else shirtType
-    queryType = ObjectType "Query"
+    queryType = ObjectType "Query" Nothing
         $ HashMap.singleton resolverName
         $ Field Nothing (ObjectOutputType unionMember) mempty resolve
 
@@ -106,7 +107,8 @@ spec = do
                 }
               }
             }|]
-                resolvers = Schema.object "garment" $ return [circumference,  size]
+                resolvers = Schema.wrappedObject "garment"
+                    $ pure $ Schema.object [circumference,  size]
 
             actual <- graphql (toSchema resolvers) sourceQuery
             let expected = object
@@ -177,7 +179,10 @@ spec = do
              in actual `shouldBe` expected
 
         it "rejects recursive fragments" $ do
-            let sourceQuery = [r|
+            let expected = object
+                    [ "data" .= object []
+                    ]
+                sourceQuery = [r|
               {
                 ...circumferenceFragment
               }
@@ -188,7 +193,7 @@ spec = do
             |]
 
             actual <- graphql (toSchema circumference) sourceQuery
-            actual `shouldSatisfy` hasErrors
+            actual `shouldBe` expected
 
         it "considers type condition" $ do
             let sourceQuery = [r|

tests/Test/RootOperationSpec.hs

@@ -6,38 +6,36 @@ module Test.RootOperationSpec
 
 import Data.Aeson ((.=), object)
 import qualified Data.HashMap.Strict as HashMap
-import Data.List.NonEmpty (NonEmpty(..))
 import Language.GraphQL
 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 Language.GraphQL.Type.Schema
+import qualified Language.GraphQL.Type as Type
 
 hatType :: ObjectType IO
-hatType = ObjectType "Hat"
+hatType = ObjectType "Hat" Nothing
     $ HashMap.singleton resolverName
     $ Field Nothing (ScalarOutputType int) mempty resolve
   where
     (Schema.Resolver resolverName resolve) =
-        Schema.scalar "circumference" $ pure (60 :: Int)
+        Schema.wrappedObject "circumference" $ pure $ Type.I 60
 
 schema :: Schema IO
 schema = Schema
-    (ObjectType "Query" hatField)
-    (Just $ ObjectType "Mutation" incrementField)
+    (ObjectType "Query" Nothing hatField)
+    (Just $ ObjectType "Mutation" Nothing incrementField)
   where
-    queryResolvers = Schema.resolversToMap $ garment :| []
-    mutationResolvers = Schema.resolversToMap $ increment :| []
-    garment = Schema.object "garment" $ pure
-        [ Schema.scalar "circumference" $ pure (60 :: Int)
+    garment = NestingResolver
+        $ pure $ Schema.object
+        [ Schema.wrappedObject "circumference" $ pure $ Type.I 60
         ]
-    increment = Schema.scalar "incrementCircumference"
-        $ pure (61 :: Int)
-    incrementField = Field Nothing (ScalarOutputType int) mempty
-        <$> mutationResolvers
-    hatField = Field Nothing (ObjectOutputType hatType) mempty
-        <$> queryResolvers
+    incrementField = HashMap.singleton "incrementCircumference"
+        $ Field Nothing (ScalarOutputType int) mempty
+        $ NestingResolver $ pure $ Type.I 61
+    hatField = HashMap.singleton "garment"
+        $ Field Nothing (ObjectOutputType hatType) mempty garment
 
 spec :: Spec
 spec =

tests/Test/StarWars/Data.hs

@@ -22,7 +22,6 @@ import Control.Monad.Trans.Except (throwE)
 import Data.Maybe (catMaybes)
 import Data.Text (Text)
 import Language.GraphQL.Trans
-import qualified Language.GraphQL.Type as Type
 
 -- * Data
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@@ -184,8 +183,8 @@ getDroid' _      = empty
 getFriends :: Character -> [Character]
 getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
 
-getEpisode :: Int -> Maybe (Type.Wrapping Text)
-getEpisode 4 = pure $ Type.Named "NEWHOPE"
-getEpisode 5 = pure $ Type.Named "EMPIRE"
-getEpisode 6 = pure $ Type.Named "JEDI"
+getEpisode :: Int -> Maybe Text
+getEpisode 4 = pure $ "NEWHOPE"
+getEpisode 5 = pure $ "EMPIRE"
+getEpisode 6 = pure $ "JEDI"
 getEpisode _ = empty

tests/Test/StarWars/Schema.hs

@@ -10,7 +10,7 @@ module Test.StarWars.Schema
 import Control.Monad.Trans.Except (throwE)
 import Control.Monad.Trans.Class (lift)
 import Data.Functor.Identity (Identity)
-import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.HashMap.Strict as HashMap
 import Data.Maybe (catMaybes)
 import qualified Language.GraphQL.Schema as Schema
 import Language.GraphQL.Trans
@@ -24,46 +24,51 @@ import Test.StarWars.Data
 schema :: Schema Identity
 schema = Schema { query = queryType, mutation = Nothing }
   where
-    queryType = ObjectType "Query"
-        $ Field Nothing (ScalarOutputType string) mempty
-        <$> Schema.resolversToMap (hero :| [human, droid])
+    queryType = ObjectType "Query" Nothing $ HashMap.fromList
+        [ ("hero", Field Nothing (ScalarOutputType string) mempty hero)
+        , ("human", Field Nothing (ScalarOutputType string) mempty human)
+        , ("droid", Field Nothing (ScalarOutputType string) mempty droid)
+        ]
 
-hero :: Schema.Resolver Identity
-hero = Schema.object "hero" $ do
+hero :: FieldResolver Identity
+hero = NestingResolver $ do
   episode <- argument "episode"
-  character $ case episode of
+  pure $ character $ case episode of
       Schema.Enum "NEWHOPE" -> getHero 4
       Schema.Enum "EMPIRE" -> getHero 5
       Schema.Enum "JEDI" -> getHero 6
       _ -> artoo
 
-human :: Schema.Resolver Identity
-human = Schema.wrappedObject "human" $ do
+human :: FieldResolver Identity
+human = NestingResolver $ do
     id' <- argument "id"
     case id' of
         Schema.String i -> do
             humanCharacter <- lift $ return $ getHuman i >>= Just
             case humanCharacter of
-                Nothing -> return Type.Null
-                Just e -> Type.Named <$> character e
+                Nothing -> pure Type.Null
+                Just e -> pure $ character e
         _ -> ActionT $ throwE "Invalid arguments."
 
-droid :: Schema.Resolver Identity
-droid = Schema.object "droid" $ do
+droid :: FieldResolver Identity
+droid = NestingResolver $ do
     id' <- argument "id"
     case id' of
-        Schema.String i -> character =<< getDroid i
+        Schema.String i -> getDroid i >>= pure . character
         _ -> ActionT $ throwE "Invalid arguments."
 
-character :: Character -> ActionT Identity [Schema.Resolver Identity]
-character char = return
-    [ Schema.scalar "id" $ return $ id_ char
-    , Schema.scalar "name" $ return $ name_ char
+character :: Character -> Type.Wrapping (FieldResolver Identity)
+character char = Schema.object
+    [ Schema.wrappedObject "id" $ pure $ Type.S $ id_ char
+    , Schema.wrappedObject "name" $ pure $ Type.S $ name_ char
     , Schema.wrappedObject "friends"
-        $ traverse character $ Type.List $ Type.Named <$> getFriends char
-    , Schema.wrappedScalar "appearsIn" $ return . Type.List
-        $ catMaybes (getEpisode <$> appearsIn char)
-    , Schema.scalar "secretBackstory" $ secretBackstory char
-    , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
-    , Schema.scalar "__typename" $ return $ typeName char
+        $ 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
     ]