Define resolvers on type fields

Returning resolvers from other resolvers isn't supported anymore. Since we have a type system now, we define the resolvers in the object type fields and pass an object with the previous result to them.
2020-05-27 23:18:35 +02:00
parent c06d0b8e95
commit d12577ae71
25 changed files with 534 additions and 516 deletions
--- a/tests/Language/GraphQL/Execute/CoerceSpec.hs
+++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs
@ -11,9 +11,8 @@ import qualified Data.HashMap.Strict as HashMap
 import Data.Maybe (isNothing)
 import Data.Scientific (scientific)
 import qualified Data.Set as Set
-import Language.GraphQL.AST.Core
+import Language.GraphQL.AST.Document (Name)
 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)
@ -23,12 +22,12 @@ direction :: EnumType
 direction = EnumType "Direction" Nothing 
    $ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"]

-coerceInputLiteral :: In.Type -> In.Value -> Maybe Subs
+coerceInputLiteral :: In.Type -> Value -> Maybe Subs
 coerceInputLiteral input value = coerceInputLiterals
    (HashMap.singleton "variableName" input)
    (HashMap.singleton "variableName" value)

-lookupActual :: Maybe (HashMap Name In.Value) -> Maybe In.Value
+lookupActual :: Maybe (HashMap Name Value) -> Maybe Value
 lookupActual = (HashMap.lookup "variableName" =<<)

 singletonInputObject :: In.Type
@ -42,22 +41,22 @@ spec :: Spec
 spec = do
    describe "ToGraphQL Aeson" $ do
        it "coerces strings" $
-            let expected = Just (In.String "asdf")
+            let expected = Just (String "asdf")
                actual = coerceVariableValue
                    (In.NamedScalarType string) (Aeson.String "asdf")
             in actual `shouldBe` expected
        it "coerces non-null strings" $
-            let expected = Just (In.String "asdf")
+            let expected = Just (String "asdf")
                actual = coerceVariableValue
                    (In.NonNullScalarType string) (Aeson.String "asdf")
             in actual `shouldBe` expected
        it "coerces booleans" $
-            let expected = Just (In.Boolean True)
+            let expected = Just (Boolean True)
                actual = coerceVariableValue
                    (In.NamedScalarType boolean) (Aeson.Bool True)
             in actual `shouldBe` expected
        it "coerces zero to an integer" $
-            let expected = Just (In.Int 0)
+            let expected = Just (Int 0)
                actual = coerceVariableValue
                    (In.NamedScalarType int) (Aeson.Number 0)
             in actual `shouldBe` expected
@ -66,24 +65,24 @@ spec = do
                    (In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1))
             in actual `shouldSatisfy` isNothing
        it "coerces float numbers" $
-            let expected = Just (In.Float 1.4)
+            let expected = Just (Float 1.4)
                actual = coerceVariableValue
                    (In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1))
             in actual `shouldBe` expected
        it "coerces IDs" $
-            let expected = Just (In.String "1234")
+            let expected = Just (String "1234")
                actual = coerceVariableValue
                    (In.NamedScalarType id) (Aeson.String "1234")
             in actual `shouldBe` expected
        it "coerces input objects" $
            let actual = coerceVariableValue singletonInputObject
                    $ Aeson.object ["field" .= ("asdf" :: Aeson.Value)]
-                expected = Just $ In.Object $ HashMap.singleton "field" "asdf"
+                expected = Just $ 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 $ In.Object HashMap.empty
+                expected = Just $ Object HashMap.empty
             in actual `shouldBe` expected
        it "fails if input object value contains extra fields" $
            let actual = coerceVariableValue singletonInputObject
@ -95,25 +94,25 @@ spec = do
             in actual `shouldSatisfy` isNothing
        it "preserves null" $
            let actual = coerceVariableValue (In.NamedScalarType id) Aeson.Null
-             in actual `shouldBe` Just In.Null
+             in actual `shouldBe` Just Null
        it "preserves list order" $
            let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
                listType = (In.ListType $ In.NamedScalarType string)
                actual = coerceVariableValue listType list
-                expected = Just $ In.List [In.String "asdf", In.String "qwer"]
+                expected = Just $ List [String "asdf", String "qwer"]
             in actual `shouldBe` expected

    describe "coerceInputLiterals" $ do
        it "coerces enums" $
-            let expected = Just (In.Enum "NORTH")
+            let expected = Just (Enum "NORTH")
                actual = coerceInputLiteral
-                    (In.NamedEnumType direction) (In.Enum "NORTH")
+                    (In.NamedEnumType direction) (Enum "NORTH")
             in lookupActual actual `shouldBe` expected
        it "fails with non-existing enum value" $
            let actual = coerceInputLiteral
-                    (In.NamedEnumType direction) (In.Enum "NORTH_EAST")
+                    (In.NamedEnumType direction) (Enum "NORTH_EAST")
             in actual `shouldSatisfy` isNothing
        it "coerces integers to IDs" $
-            let expected = Just (In.String "1234")
-                actual = coerceInputLiteral (In.NamedScalarType id) (In.Int 1234)
+            let expected = Just (String "1234")
+                actual = coerceInputLiteral (In.NamedScalarType id) (Int 1234)
             in lookupActual actual `shouldBe` expected
--- a/tests/Language/GraphQL/SchemaSpec.hs
+++ b/tests/Language/GraphQL/SchemaSpec.hs
@ -1,32 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Language.GraphQL.SchemaSpec
-    ( spec
-    ) where
-
-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 Language.GraphQL.AST.Core
-import Language.GraphQL.Error
-import Language.GraphQL.Schema
-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 = pure $ object
-                    [ Resolver "field" $ pure $ Out.String "T"
-                    ]
-                schema = HashMap.singleton "__typename" resolver
-                fields = Sequence.singleton
-                    $ SelectionFragment
-                    $ Fragment "T" Sequence.empty
-                expected = Aeson.object
-                    [ ("data" , Aeson.emptyObject)
-                    ]
-
-            actual <- runCollectErrs (resolve schema fields)
-            actual `shouldBe` expected
--- a/tests/Language/GraphQL/Type/OutSpec.hs
+++ b/tests/Language/GraphQL/Type/OutSpec.hs
@ -3,13 +3,12 @@ module Language.GraphQL.Type.OutSpec
    ( spec
    ) where

-import Data.Functor.Identity (Identity)
-import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Type.Definition
 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."
+            let nietzsche = "Goldstaub abblasen." :: Value
+             in nietzsche `shouldBe` String "Goldstaub abblasen."
--- a/tests/Test/DirectiveSpec.hs
+++ b/tests/Test/DirectiveSpec.hs
@ -4,7 +4,8 @@ module Test.DirectiveSpec
    ( spec
    ) where

-import Data.Aeson (Value(..), object, (.=))
+import Data.Aeson (object, (.=))
+import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
 import Language.GraphQL
 import Language.GraphQL.Type.Definition
@ -16,12 +17,12 @@ import Text.RawString.QQ (r)
 experimentalResolver :: Schema IO
 experimentalResolver = Schema { query = queryType, mutation = Nothing }
  where
-    resolver = pure $ Out.Int 5
+    resolver = pure $ Int 5
    queryType = Out.ObjectType "Query" Nothing []
        $ HashMap.singleton "experimentalField"
        $ Out.Field Nothing (Out.NamedScalarType int) mempty resolver

-emptyObject :: Value
+emptyObject :: Aeson.Value
 emptyObject = object
    [ "data" .= object []
    ]
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@ -4,11 +4,11 @@ module Test.FragmentSpec
    ( spec
    ) where

-import Data.Aeson (Value(..), object, (.=))
+import Data.Aeson (object, (.=))
+import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
 import Language.GraphQL
-import qualified Language.GraphQL.Schema as Schema
 import Language.GraphQL.Type.Definition
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
@ -21,18 +21,19 @@ import Test.Hspec
    )
 import Text.RawString.QQ (r)

-size :: Schema.Resolver IO
-size = Schema.Resolver "size" $ pure $ Out.String "L"
+size :: (Text, Value)
+size = ("size", String "L")

-circumference :: Schema.Resolver IO
-circumference = Schema.Resolver "circumference" $ pure $ Out.Int 60
+circumference :: (Text, Value)
+circumference = ("circumference", Int 60)

-garment :: Text -> Schema.Resolver IO
-garment typeName = Schema.Resolver "garment"
-    $ pure $ Schema.object
-    [ if typeName == "Hat" then circumference else size
-    , Schema.Resolver "__typename" $ pure $ Out.String typeName
-    ]
+garment :: Text -> (Text, Value)
+garment typeName =
+    ("garment",  Object $ HashMap.fromList
+        [ if typeName == "Hat" then circumference else size
+        , ("__typename", String typeName)
+        ]
+    )

 inlineQuery :: Text
 inlineQuery = [r|{
@ -46,38 +47,46 @@ inlineQuery = [r|{
  }
 }|]

-hasErrors :: Value -> Bool
-hasErrors (Object object') = HashMap.member "errors" object'
+hasErrors :: Aeson.Value -> Bool
+hasErrors (Aeson.Object object') = HashMap.member "errors" object'
 hasErrors _ = True

 shirtType :: Out.ObjectType IO
 shirtType = Out.ObjectType "Shirt" Nothing []
-    $ HashMap.singleton resolverName
-    $ Out.Field Nothing (Out.NamedScalarType string) mempty resolve
-  where
-    (Schema.Resolver resolverName resolve) = size
+    $ HashMap.fromList
+        [ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size)
+        , ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference)
+        , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt")
+        ]

 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
-    $ HashMap.singleton resolverName
-    $ Out.Field Nothing (Out.NamedScalarType int) mempty resolve
-  where
-    (Schema.Resolver resolverName resolve) = circumference
+    $ HashMap.fromList
+        [ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size)
+        , ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference)
+        , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Hat")
+        ]

-toSchema :: Schema.Resolver IO -> Schema IO
-toSchema (Schema.Resolver resolverName resolve) = Schema
+toSchema :: Text -> (Text, Value) -> Schema IO
+toSchema t (_, resolve) = Schema
    { query = queryType, mutation = Nothing }
  where
-    unionMember = if resolverName == "Hat" then hatType else shirtType
-    queryType = Out.ObjectType "Query" Nothing []
-        $ HashMap.singleton resolverName
-        $ Out.Field Nothing (Out.NamedObjectType unionMember) mempty resolve
+    unionMember = if t == "Hat" then hatType else shirtType
+    queryType =
+        case t of
+            "circumference" -> hatType
+            "size" -> shirtType
+            _ -> Out.ObjectType "Query" Nothing []
+                $ HashMap.fromList
+                    [ ("garment", Out.Field Nothing (Out.NamedObjectType unionMember) mempty $ pure resolve)
+                    , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt")
+                    ]

 spec :: Spec
 spec = do
    describe "Inline fragment executor" $ do
        it "chooses the first selection if the type matches" $ do
-            actual <- graphql (toSchema $ garment "Hat") inlineQuery
+            actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
            let expected = object
                    [ "data" .= object
                        [ "garment" .= object
@ -88,7 +97,7 @@ spec = do
             in actual `shouldBe` expected

        it "chooses the last selection if the type matches" $ do
-            actual <- graphql (toSchema $ garment "Shirt") inlineQuery
+            actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
            let expected = object
                    [ "data" .= object
                        [ "garment" .= object
@ -107,10 +116,9 @@ spec = do
                }
              }
            }|]
-                resolvers = Schema.Resolver "garment"
-                    $ pure $ Schema.object [circumference,  size]
+                resolvers = ("garment", Object $ HashMap.fromList [circumference,  size])

-            actual <- graphql (toSchema resolvers) sourceQuery
+            actual <- graphql (toSchema "garment" resolvers) sourceQuery
            let expected = object
                    [ "data" .= object
                        [ "garment" .= object
@ -128,7 +136,7 @@ spec = do
              }
            }|]

-            actual <- graphql (toSchema size) sourceQuery
+            actual <- graphql (toSchema "size" size) sourceQuery
            actual `shouldNotSatisfy` hasErrors

    describe "Fragment spread executor" $ do
@ -143,7 +151,7 @@ spec = do
              }
            |]

-            actual <- graphql (toSchema circumference) sourceQuery
+            actual <- graphql (toSchema "circumference" circumference) sourceQuery
            let expected = object
                    [ "data" .= object
                        [ "circumference" .= (60 :: Int)
@ -168,7 +176,7 @@ spec = do
              }
            |]

-            actual <- graphql (toSchema $ garment "Hat") sourceQuery
+            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
            let expected = object
                    [ "data" .= object
                        [ "garment" .= object
@ -192,7 +200,7 @@ spec = do
              }
            |]

-            actual <- graphql (toSchema circumference) sourceQuery
+            actual <- graphql (toSchema "circumference" circumference) sourceQuery
            actual `shouldBe` expected

        it "considers type condition" $ do
@ -217,5 +225,5 @@ spec = do
                            ]
                        ]
                    ]
-            actual <- graphql (toSchema $ garment "Hat") sourceQuery
+            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
            actual `shouldBe` expected
--- a/tests/Test/RootOperationSpec.hs
+++ b/tests/Test/RootOperationSpec.hs
@ -7,7 +7,6 @@ module Test.RootOperationSpec
 import Data.Aeson ((.=), object)
 import qualified Data.HashMap.Strict as HashMap
 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
@ -16,23 +15,21 @@ import Language.GraphQL.Type.Schema

 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
-    $ HashMap.singleton resolverName
-    $ Out.Field Nothing (Out.NamedScalarType int) mempty resolve
-  where
-    (Schema.Resolver resolverName resolve) =
-        Schema.Resolver "circumference" $ pure $ Out.Int 60
+    $ HashMap.singleton "circumference"
+    $ Out.Field Nothing (Out.NamedScalarType int) mempty
+    $ pure $ Int 60

 schema :: Schema IO
 schema = Schema
    (Out.ObjectType "Query" Nothing [] hatField)
    (Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
  where
-    garment = pure $ Schema.object
-        [ Schema.Resolver "circumference" $ pure $ Out.Int 60
+    garment = pure $ Object $ HashMap.fromList
+        [ ("circumference", Int 60)
        ]
    incrementField = HashMap.singleton "incrementCircumference"
        $ Out.Field Nothing (Out.NamedScalarType int) mempty
-        $ pure $ Out.Int 61
+        $ pure $ Int 61
    hatField = HashMap.singleton "garment"
        $ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment

--- a/tests/Test/StarWars/Data.hs
+++ b/tests/Test/StarWars/Data.hs
@ -66,8 +66,8 @@ appearsIn :: Character -> [Int]
 appearsIn (Left  x) = _appearsIn . _droidChar $ x
 appearsIn (Right x) = _appearsIn . _humanChar $ x

-secretBackstory :: Character -> ActionT Identity Text
-secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
+secretBackstory :: ActionT Identity Text
+secretBackstory = ActionT $ throwE "secretBackstory is secret."

 typeName :: Character -> Text
 typeName = either (const "Droid") (const "Human")
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@ -1,24 +1,22 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Test.StarWars.Schema
-    ( character
-    , droid
-    , hero
-    , human
-    , schema
+    ( schema
    ) where

+import Control.Monad.Trans.Reader (asks)
 import Control.Monad.Trans.Except (throwE)
 import Control.Monad.Trans.Class (lift)
 import Data.Functor.Identity (Identity)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Maybe (catMaybes)
-import qualified Language.GraphQL.Schema as Schema
+import Data.Text (Text)
 import Language.GraphQL.Trans
 import Language.GraphQL.Type.Definition
-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
+import Prelude hiding (id)

 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js

@ -26,50 +24,72 @@ schema :: Schema Identity
 schema = Schema { query = queryType, mutation = Nothing }
  where
    queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
-        [ ("hero", Out.Field Nothing (Out.NamedScalarType string) mempty hero)
-        , ("human", Out.Field Nothing (Out.NamedScalarType string) mempty human)
-        , ("droid", Out.Field Nothing (Out.NamedScalarType string) mempty droid)
+        [ ("hero", Out.Field Nothing (Out.NamedObjectType heroObject) mempty hero)
+        , ("human", Out.Field Nothing (Out.NamedObjectType heroObject) mempty human)
+        , ("droid", Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid)
        ]

-hero :: ActionT Identity (Out.Value Identity)
+heroObject :: Out.ObjectType Identity
+heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
+    [ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id"))
+    , ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name"))
+    , ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType heroObject) mempty (idField "friends"))
+    , ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn"))
+    , ("homePlanet", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "homePlanet"))
+    , ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory))
+    , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename"))
+    ]
+
+droidObject :: Out.ObjectType Identity
+droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
+    [ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id"))
+    , ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name"))
+    , ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty (idField "friends"))
+    , ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn"))
+    , ("primaryFunction", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "primaryFunction"))
+    , ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory))
+    , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename"))
+    ]
+
+idField :: Text -> ActionT Identity Value
+idField f = do
+    v <- ActionT $ lift $ asks values
+    let (Object v') = v
+    pure $ v' HashMap.! f
+
+hero :: ActionT Identity Value
 hero = do
  episode <- argument "episode"
  pure $ character $ case episode of
-      In.Enum "NEWHOPE" -> getHero 4
-      In.Enum "EMPIRE" -> getHero 5
-      In.Enum "JEDI" -> getHero 6
+      Enum "NEWHOPE" -> getHero 4
+      Enum "EMPIRE" -> getHero 5
+      Enum "JEDI" -> getHero 6
      _ -> artoo

-human :: ActionT Identity (Out.Value Identity)
+human :: ActionT Identity Value
 human = do
    id' <- argument "id"
    case id' of
-        In.String i -> do
+        String i -> do
            humanCharacter <- lift $ return $ getHuman i >>= Just
            case humanCharacter of
-                Nothing -> pure Out.Null
+                Nothing -> pure Null
                Just e -> pure $ character e
        _ -> ActionT $ throwE "Invalid arguments."

-droid :: ActionT Identity (Out.Value Identity)
+droid :: ActionT Identity Value
 droid = do
    id' <- argument "id"
    case id' of
-        In.String i -> character <$> getDroid i
+        String i -> character <$> getDroid i
        _ -> ActionT $ throwE "Invalid arguments."

-character :: Character -> Out.Value Identity
-character char = Schema.object
-    [ Schema.Resolver "id" $ pure $ Out.String $ id_ char
-    , Schema.Resolver "name" $ pure $ Out.String $ name_ char
-    , Schema.Resolver "friends"
-        $ pure $ Out.List $ 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
+character :: Character -> Value
+character char = Object $ HashMap.fromList
+    [ ("id", String $ id_ char)
+    , ("name", String $ name_ char)
+    , ("friends", List $ character <$> getFriends char)
+    , ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))
+    , ("homePlanet", String $ either mempty homePlanet char)
+    , ("__typename", String $ typeName char)
    ]