Don't fail on invalid fragments and variables

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/QuerySpec.hs

@@ -39,7 +39,7 @@ spec = describe "Star Wars Query Tests" $ do
                 id
                 name
                 friends {
-                name
+                  name
                 }
             }
             }

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
     ]