Test fixtures for Schema toplevel

This includes simplications to the Schema data types.

Data/GraphQL/Schema.hs

@@ -3,38 +3,29 @@ module Data.GraphQL.Schema where
 import Data.Text (Text)
 import Data.HashMap.Lazy (HashMap)
 
-data Schema = Schema QueryRoot MutationRoot
+data Schema f = Schema (QueryRoot f) (Maybe (MutationRoot f))
 
-type QueryRoot = ObjectOutput
+type QueryRoot f = Object f
 
-type MutationRoot = ObjectOutput
+type MutationRoot f = Object f
 
-type ObjectOutput = HashMap Text Output
+type Object f = HashMap Text (Input -> f Output)
 
 type ObjectInput =  HashMap Text Input
 
-data Type = TypeScalar Scalar
-          | TypeOutputObject ObjectOutput
-          | TypeInterface Interface
-          | TypeUnion Union
-          | TypeEnum Scalar
-          | TypeInputObject ObjectInput
-          | TypeList List
-          | TypeNonNull NonNull
-
 data Output = OutputScalar Scalar
-            | OutputObject ObjectOutput
-            | OutputInterface Interface
-            | OutputUnion Union
+            | OutputObject (HashMap Text Output)
+            | OutputUnion [Output]
             | OutputEnum Scalar
-            | OutputList List
-            | OutputNonNull NonNull
+            | OutputList [Output]
+            | OutputNonNull Output
+            | InputError
 
 data Input = InputScalar Scalar
            | InputObject ObjectInput
            | InputEnum Scalar
-           | InputList List
-           | InputNonNull NonNull
+           | InputList [Output]
+           | InputNonNull Input
 
 data Scalar = ScalarInt Int
             | ScalarFloat Double
@@ -42,10 +33,4 @@ data Scalar = ScalarInt Int
             | ScalarBool Bool
             | ScalarID Text
 
-newtype Interface = Interface (HashMap Text Output)
-
-newtype Union = Union [ObjectOutput]
-
-type List = [Type]
-
-type NonNull = Type
+newtype Interface f = Interface (Object f)

graphql.cabal

@@ -40,6 +40,7 @@ test-suite tasty
   main-is:             tasty.hs
   ghc-options:         -Wall
   other-modules:       Paths_graphql
+                       Test.StarWars
   build-depends:       base >=4.6 && <5,
                        text >=0.11.3.1,
                        attoparsec >=0.10.4.0,

tests/Test/StarWars.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE RecordWildCards #-}
+module Test.StarWars where
+
+import Data.Text (Text)
+import Data.HashMap.Lazy (HashMap)
+import Data.GraphQL.Schema
+
+type ID = Text
+
+schema :: Applicative f => Schema f
+schema = Schema query Nothing
+
+query :: Applicative f => QueryRoot f
+query = [ ("hero", hero)
+        , ("human", human)
+        , ("droid", droid)
+        ]
+
+hero :: Applicative f => Input -> f Output
+hero (InputScalar (ScalarInt ep)) = OutputObject <$> getHeroF ep
+hero _ = pure InputError
+
+human :: Applicative f => Input -> f Output
+human (InputScalar (ScalarString id_)) = OutputScalar . ScalarString <$> getHumanF id_
+human _ = pure InputError
+
+droid :: Applicative f => Input -> f Output
+droid (InputScalar (ScalarString id_)) = OutputScalar . ScalarString <$> getDroidF id_
+droid _ = pure InputError
+
+-- * Data
+
+-- ** Characters
+
+
+data Character = Character
+  { id_ :: ID
+  , name :: Text
+  , friends :: [ID]
+  , appearsIn :: [Int]
+  , homePlanet :: Text
+  }
+
+luke :: Character
+luke = Character
+  { id_ = "1000"
+  , name = "Luke Skywalker"
+  , friends = ["1002","1003","2000","2001"]
+  , appearsIn = [4,5,6]
+  , homePlanet = "Tatoonie"
+  }
+
+artoo :: Character
+artoo = Character
+  { id_ = "2001"
+  , name = "R2-D2"
+  , friends = ["1000","1002","1003"]
+  , appearsIn = [4,5,6]
+  , homePlanet = "Astrometch"
+  }
+
+type CharacterObject = HashMap Text Output
+
+character :: Character -> CharacterObject
+character (Character{..}) =
+  [ ("id_", OutputScalar $ ScalarID id_)
+  , ("name", OutputScalar $ ScalarString name)
+  , ("friends", OutputList $ OutputScalar . ScalarID <$> friends)
+  , ("appearsIn", OutputList $ OutputScalar . ScalarInt <$> appearsIn)
+  , ("homePlanet", OutputScalar $ ScalarString homePlanet)
+  ]
+
+-- ** Hero
+
+getHero :: Int -> CharacterObject
+getHero 5 = character luke
+getHero _ = character artoo
+
+getHeroF :: Applicative f => Int -> f CharacterObject
+getHeroF = pure . getHero
+
+-- ** Human
+
+getHuman :: ID -> Text
+getHuman "1000" = "luke"
+getHuman "1001" = "vader"
+getHuman "1002" = "han"
+getHuman "1003" = "leia"
+getHuman "1004" = "tarkin"
+getHuman _      = ""
+
+getHumanF :: Applicative f => ID -> f Text
+getHumanF = pure . getHuman
+
+getHumanIO :: ID -> IO Text
+getHumanIO = getHumanF
+
+-- ** Droid
+
+getDroid :: ID -> Text
+getDroid "2000" = "threepio"
+getDroid "2001" = "artoo"
+getDroid _ = ""
+
+getDroidF :: Applicative f => ID -> f Text
+getDroidF = pure . getDroid
+
+getDroidIO :: ID -> IO Text
+getDroidIO = getDroidF