Rough implementation of execute

The first end-to-end test taken from `graphql-js` passes but this still
needs to be extended to support more general cases.

- `Data.GraphQL.Schema` has been heavily modified to support the
  execution model. More drastic changes are expected in this module.
- When defining a `Schema` ordinary functions taking fields as input are
  being used instead of maps. This makes the implementation of `execute`
  easier, and, arguably, makes `Schema` definitions more *Haskellish*.
- Drop explicit `unordered-containers` dependency. `Aeson.Value`s and
  field functions should be good enough for now.

Data/GraphQL/Execute.hs

@@ -1,16 +1,32 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedLists #-}
 module Data.GraphQL.Execute where
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative (Applicative)
 #endif
 
-import qualified Data.Aeson as Aeson (Value)
+import qualified Data.Aeson as Aeson
 
 import Data.GraphQL.AST
 import Data.GraphQL.Schema
 
 type Response = Aeson.Value
 
-execute :: Applicative f => Schema f -> Document -> f Response
+execute :: Schema -> Document -> Maybe Response
-execute _schema _doc = undefined
+execute (Schema resolv0) doc = go resolv0 =<< root doc
+  where
+
+    root :: Document -> Maybe Selection
+    root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = Just sel
+    root _ = error "root: Not implemented yet"
+
+    go :: Resolver -> Selection -> Maybe Response
+    go resolv (SelectionField (Field _ n _ _ sfs)) =
+        case resolv (InputField n) of
+            (OutputScalar s) -> if null sfs
+                                   then Just $ Aeson.Object [(n, Aeson.toJSON s)]
+                                   else Nothing
+            (OutputResolver resolv') -> (\r-> Aeson.Object [(n, r)]) <$> go resolv' (head sfs)
+            _ -> error "go case resolv: Not implemented yet"
+    go _ _ = error "go: Not implemented yet"

Data/GraphQL/Schema.hs

@@ -1,33 +1,48 @@
 module Data.GraphQL.Schema where
 
+import Data.Maybe (catMaybes)
+import Text.Show.Functions ()
+
 import Data.Text (Text)
-import Data.HashMap.Lazy (HashMap)
+import Data.Aeson (ToJSON(toJSON))
 
-data Schema f = Schema (QueryRoot f) (Maybe (MutationRoot f))
+data Schema = Schema QueryRoot -- (Maybe  MutationRoot)
 
-type QueryRoot f = Map f
+type QueryRoot = Resolver
 
-type MutationRoot f = Map f
+type Resolver = Input -> Output
 
-type Map f = HashMap Text (Resolver f)
+data Output = OutputResolver Resolver
-
+            | OutputList [Output]
-type Resolver f = Input -> Output f
+            | OutputScalar Scalar
-
+         -- | OutputUnion [Output]
-data Output f = OutputScalar (f Scalar)
+         -- | OutputEnum [Scalar]
-              | OutputMap (Map f)
+         -- | OutputNonNull (Output)
-              | OutputUnion [Map f]
+            | OutputError
-              | OutputEnum (f Scalar)
+              deriving (Show)
-              | OutputList [Output f]
-              | OutputNonNull (Output f)
-              | InputError
 
 data Input = InputScalar Scalar
-           | InputEnum Scalar
+           | InputField Text
            | InputList [Input]
-           | InputNonNull Input
+             deriving (Show)
 
-data Scalar = ScalarInt Int
+field :: Input -> Maybe Text
-            | ScalarFloat Double
+field (InputField x) = Just x
-            | ScalarString Text
+field _ = Nothing
-            | ScalarBool Bool
+
-            | ScalarID Text
+fields :: [Input] -> [Text]
+fields = catMaybes . fmap field
+
+data Scalar = ScalarInt     Int
+            | ScalarFloat   Double
+            | ScalarString  Text
+            | ScalarBoolean Bool
+            | ScalarID      Text
+              deriving (Show)
+
+instance ToJSON Scalar where
+    toJSON (ScalarInt     x) = toJSON x
+    toJSON (ScalarFloat   x) = toJSON x
+    toJSON (ScalarString  x) = toJSON x
+    toJSON (ScalarBoolean x) = toJSON x
+    toJSON (ScalarID      x) = toJSON x

graphql.cabal

@@ -27,11 +27,10 @@ library
                        Data.GraphQL.Execute
                        Data.GraphQL.Schema
                        Data.GraphQL.Parser
-  build-depends:       base >=4.7 && < 5,
+  build-depends:       base >= 4.7 && < 5,
-                       text >=0.11.3.1,
+                       text >= 0.11.3.1,
-                       aeson >=0.7.0.3,
+                       aeson >= 0.7.0.3,
-                       attoparsec >=0.10.4.0,
+                       attoparsec >= 0.10.4.0
-                       unordered-containers >=0.2.5.0
 
 test-suite tasty
   default-language:    Haskell2010
@@ -41,12 +40,12 @@ test-suite tasty
   ghc-options:         -Wall
   other-modules:       Paths_graphql
                        Test.StarWars
-  build-depends:       base >=4.6 && <5,
+  build-depends:       base >= 4.6 && <5,
-                       aeson >=0.7.0.3,
+                       aeson >= 0.7.0.3,
-                       text >=0.11.3.1,
+                       text >= 0.11.3.1,
-                       attoparsec >=0.10.4.0,
+                       attoparsec >= 0.10.4.0,
-                       tasty >=0.10,
+                       tasty >= 0.10,
-                       tasty-hunit >=0.9,
+                       tasty-hunit >= 0.9,
                        graphql
 
 source-repository head

tests/Test/StarWars.hs

@@ -1,13 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE RecordWildCards #-}
 module Test.StarWars where
 
-import Data.Functor.Identity (Identity(..))
+import Control.Applicative ((<|>), liftA2)
+import Data.Maybe (catMaybes)
+-- import Data.Functor.Identity (Identity(..))
 import Data.Text (Text)
 
-import Data.Attoparsec.Text (parseOnly)
+-- import Data.Aeson (ToJSON(toJSON), genericToJSON, defaultOptions)
 import qualified Data.Aeson as Aeson
+import Data.Attoparsec.Text (parseOnly)
 
 import Test.Tasty (TestTree)
 import Test.Tasty.HUnit
@@ -17,119 +19,106 @@ import Data.GraphQL.Execute
 import qualified Data.GraphQL.Parser as Parser
 import Data.GraphQL.Schema
 
+
 -- * Test
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
 
 test :: TestTree
-test = testCase "R2-D2" $ execute schema heroQuery @=? Identity expected
+test = testCase "R2-D2" $ execute schema heroQuery @?= expected
   where
     heroQuery :: Document
     heroQuery = either (error "Parsing error") id $ parseOnly Parser.document
-      "{ query HeroNameQuery { hero { name } } }"
+      "query HeroNameQuery{hero{name}}"
 
-    expected :: Response
+    expected :: Maybe Response
-    expected = Aeson.Object
+    expected = Just $ Aeson.Object [("hero", Aeson.Object [("name", "R2-D2")])]
-        [ ( "hero" , Aeson.Object [ ("name", "R2-D2") ] ) ]
 
 -- * Schema
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
 
 type ID = Text
 
-schema :: Applicative f => Schema f
+schema :: Schema
-schema = Schema query Nothing
+schema = Schema query
 
-query :: Applicative f => QueryRoot f
+query ::  QueryRoot
-query = [ ("hero", hero)
+query (InputField "hero")  = OutputResolver hero
-        , ("human", human)
+query (InputField "human") = OutputResolver human
-        , ("droid", droid)
+query (InputField "droid") = OutputResolver droid
-        ]
+query _ = OutputError
 
-hero :: Applicative f => Resolver f
+hero :: Resolver
-hero (InputScalar (ScalarInt ep)) = OutputMap $ getHeroF ep
+hero (InputList (InputScalar (ScalarInt ep) : inputFields)) =
-hero _ = InputError
+    maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHero ep
+hero (InputField fld) = characterOutput fld artoo
+hero _ = OutputError
 
-human :: Applicative f => Resolver f
+human :: Resolver
-human (InputScalar (ScalarString id_)) = OutputScalar $ ScalarString <$> getHumanF id_
+human (InputList (InputScalar (ScalarID i) : inputFields)) =
-human _ = InputError
+    maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHuman i
+human _ = OutputError
 
-droid :: Applicative f => Resolver f
+droid :: Resolver
-droid (InputScalar (ScalarString id_)) = OutputScalar $ ScalarString <$> getDroidF id_
+droid (InputList (InputScalar (ScalarID i) : inputFields)) =
-droid _ = InputError
+    maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getDroid i
+droid _ = OutputError
+
+characterOutput :: Text -> Character -> Output
+characterOutput "id"      char = OutputScalar . ScalarString $ id_  char
+characterOutput "name"    char = OutputScalar . ScalarString $ name char
+characterOutput "friends" char = OutputList $ OutputResolver . (\c (InputField f) -> characterOutput f c) <$> getFriends char
+characterOutput _ _ = OutputError
 
 -- * Data
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
 
 -- ** Characters
 
 data Character = Character
-  { id_ :: ID
+  { id_        :: ID
-  , name :: Text
+  , name       :: Text
-  , friends :: [ID]
+  , friends    :: [ID]
-  , appearsIn :: [Int]
+  , appearsIn  :: [Int]
   , homePlanet :: Text
-  }
+  } deriving (Show)
 
 luke :: Character
 luke = Character
-  { id_ = "1000"
+  { id_        = "1000"
-  , name = "Luke Skywalker"
+  , name       = "Luke Skywalker"
-  , friends = ["1002","1003","2000","2001"]
+  , friends    = ["1002","1003","2000","2001"]
-  , appearsIn = [4,5,6]
+  , appearsIn  = [4,5,6]
   , homePlanet = "Tatoonie"
   }
 
 artoo :: Character
 artoo = Character
-  { id_ = "2001"
+  { id_        = "2001"
-  , name = "R2-D2"
+  , name       = "R2-D2"
-  , friends = ["1000","1002","1003"]
+  , friends    = ["1000","1002","1003"]
-  , appearsIn = [4,5,6]
+  , appearsIn  = [4,5,6]
   , homePlanet = "Astrometch"
   }
 
-type CharacterMap f = Map f
+-- ** Helper functions
 
-character :: Applicative f => Character -> CharacterMap f
+getHero :: Int -> Maybe Character
-character (Character{..}) =
+getHero 5 = Just luke
-  [ ("id_", const . OutputScalar . pure $ ScalarID id_)
+getHero _ = Just artoo
-  , ("name", const . OutputScalar . pure $ ScalarString name)
-  , ("friends", const . OutputList $ OutputScalar . pure . ScalarID <$> friends)
-  , ("appearsIn", const . OutputList $ OutputScalar . pure . ScalarInt <$> appearsIn)
-  , ("homePlanet", const . OutputScalar . pure $ ScalarString homePlanet)
-  ]
 
--- ** Hero
+getHuman :: ID -> Maybe Character
+getHuman "1000" = Just luke
+-- getHuman "1001" = "vader"
+-- getHuman "1002" = "han"
+-- getHuman "1003" = "leia"
+-- getHuman "1004" = "tarkin"
+getHuman _      = Nothing
 
-getHero :: Int -> Character
+getDroid :: ID -> Maybe Character
-getHero 5 = luke
+-- getDroid "2000" = "threepio"
-getHero _ = artoo
+getDroid "2001" = Just artoo
+getDroid _ = Nothing
 
-getHeroF :: Applicative f => Int -> CharacterMap f
-getHeroF = character . getHero
 
--- ** Human
+getFriends :: Character -> [Character]
-
+getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
-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