Extend `execute` for deeper queries

The second graphql-js end-to-end test was ported and passed
successfully.

3 files changed, 119 insertions, 34 deletions

diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index b843f07..df6b506 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -1,34 +1,41 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE LambdaCase #-}
 module Data.GraphQL.Execute where
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative (Applicative, (<$>), pure)
+import Data.Traversable (traverse)
 #endif
 import Control.Applicative (Alternative, empty)
+import Data.Foldable (fold)
 
 import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
 
 import Data.GraphQL.AST
 import Data.GraphQL.Schema
 
-type Response = Aeson.Value
-
-execute :: (Alternative f, Monad f) => Schema f -> Document -> f Response
-execute (Schema resolv0) doc = go resolv0 =<< root doc
-  where
-    root :: Applicative f => Document -> f Selection
-    root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = pure sel
-    root _ = error "root: Not implemented yet"
-
-    go :: (Alternative f, Monad f) => Resolver f -> Selection -> f Response
-    go resolv (SelectionField (Field _ n _ _ sfs)) =
-        resolv (InputField n) >>= \case
-            (OutputScalar s) ->
-               if null sfs
-                 then (\s' -> Aeson.Object [(n, Aeson.toJSON s')]) <$> s
-                 else empty
-            (OutputResolver resolv') -> (\r-> Aeson.Object [(n, r)]) <$> go resolv' (head sfs)
-            _ -> error "go case resolv: Not implemented yet"
-    go _ _ = error "go: Not implemented yet"
+execute :: (Alternative f, Monad f) => Schema f -> Document -> f Aeson.Value
+execute (Schema resolv) doc = selectionSet resolv =<< query doc
+
+query :: Applicative f => Document -> f SelectionSet
+query (Document [DefinitionOperation (Query (Node _ _ _ sels))]) = pure sels
+query _ = error "query: Not implemented yet"
+
+selectionSet :: (Alternative f, Monad f) => Resolver f -> SelectionSet -> f Aeson.Value
+selectionSet resolv sels = Aeson.Object . fold <$> traverse (selection resolv) sels
+
+selection :: (Alternative f, Monad f) => Resolver f -> Selection -> f Aeson.Object
+selection resolv (SelectionField (Field _ n _ _ sfs)) =
+    fmap (HashMap.singleton n) $ output sfs =<< resolv (InputField n)
+selection _ _ = error "selection: Not implemented yet"
+
+output :: (Alternative f, Monad f) => SelectionSet -> Output f -> f Aeson.Value
+output sels (OutputResolver resolv) = selectionSet resolv sels
+output sels (OutputList os) = fmap array . traverse (output sels) =<< os
+output sels (OutputScalar s)
+   | null sels = Aeson.toJSON <$> s
+   | otherwise = empty
+
+array :: [Aeson.Value] -> Aeson.Value
+array = Aeson.toJSON
diff --git a/graphql.cabal b/graphql.cabal
index 40da990..bd3bbd8 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -31,7 +31,8 @@ library
   build-depends:       base >= 4.7 && < 5,
                        text >= 0.11.3.1,
                        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
@@ -45,6 +46,7 @@ test-suite tasty
                        aeson >= 0.7.0.3,
                        text >= 0.11.3.1,
                        attoparsec >= 0.10.4.0,
+                       raw-strings-qq >= 1.1,
                        tasty >= 0.10,
                        tasty-hunit >= 0.9,
                        graphql
diff --git a/tests/Test/StarWars.hs b/tests/Test/StarWars.hs
index a6fa9ee..b3ab99e 100644
--- a/tests/Test/StarWars.hs
+++ b/tests/Test/StarWars.hs
@@ -1,10 +1,11 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Test.StarWars where
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative (Applicative, (<$>), pure)
+import Data.Monoid (mempty)
 import Data.Traversable (traverse)
 #endif
 import Control.Applicative (Alternative, (<|>), empty, liftA2)
@@ -12,6 +13,7 @@ import Data.Maybe (catMaybes)
 
 import Data.Aeson (object, (.=))
 import Data.Text (Text)
+import Text.RawString.QQ (r)
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (testCase, (@?=))
@@ -24,10 +26,40 @@ import Data.GraphQL.Schema
 
 test :: TestTree
 test = testGroup "Basic Queries"
-     [testCase "R2-D2"
-         $  graphql schema "query HeroNameQuery{hero{name}}"
-        @?= Just (object ["hero" .= object ["name" .= ("R2-D2" :: Text)]])
-     ]
+  [ testCase "R2-D2 hero" $ (@?=) (graphql schema [r|
+query HeroNameQuery {
+  hero {
+    id
+  }
+}|]) . Just
+     $ object [
+         "hero" .= object [
+              "id"   .= ("2001" :: Text)
+            ]
+         ]
+
+  , testCase "R2-D2 ID and friends" $ (@?=) (graphql schema [r|
+query HeroNameAndFriendsQuery {
+  hero {
+    id
+    name
+    friends {
+      name
+    }
+  }
+}|]) . Just
+     $ object [
+          "hero" .= object [
+               "id" .= ("2001" :: Text)
+             , "name" .= ("R2-D2" :: Text)
+             , "friends" .= [
+                    object ["name" .= ("Luke Skywalker" :: Text)]
+                  , object ["name" .= ("Han Solo" :: Text)]
+                  , object ["name" .= ("Leia Organa" :: Text)]
+                  ]
+             ]
+           ]
+  ]
 
 -- * Schema
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
@@ -45,7 +77,7 @@ query _ = empty
 
 hero :: Alternative f => Resolver f
 hero (InputList (InputScalar (ScalarInt ep) : inputFields)) =
-    withFields inputFields  <$> getHero ep
+    withFields inputFields <$> getHero ep
 hero (InputField fld) = characterOutput fld artoo
 hero _ = empty
 
@@ -65,7 +97,6 @@ characterOutput "id" char =
 characterOutput "name" char =
     pure $ OutputScalar . pure . ScalarString $ name char
 characterOutput "friends" char =
-    -- TODO: Cleanup
     pure . OutputList . pure $ OutputResolver . (\c (InputField f) ->
       characterOutput f c) <$> getFriends char
 characterOutput _ _ = empty
@@ -96,6 +127,51 @@ luke = Character
   , homePlanet = "Tatoonie"
   }
 
+vader :: Character
+vader = Character
+  { id_        = "1001"
+  , name       = "Darth Vader"
+  , friends    = ["1004"]
+  , appearsIn  = [4,5,6]
+  , homePlanet = "Tatooine"
+  }
+
+han :: Character
+han = Character
+  { id_        = "1002"
+  , name       = "Han Solo"
+  , friends    = ["1000","1003","2001" ]
+  , appearsIn  = [4,5,6]
+  , homePlanet = mempty
+  }
+
+leia :: Character
+leia = Character
+  { id_        = "1003"
+  , name       = "Leia Organa"
+  , friends    = ["1000","1002","2000","2001"]
+  , appearsIn  = [4,5,6]
+  , homePlanet = "Alderaan"
+  }
+
+tarkin :: Character
+tarkin = Character
+  { id_        = "1004"
+  , name       = "Wilhuff Tarkin"
+  , friends    = ["1001"]
+  , appearsIn  = [4]
+  , homePlanet = mempty
+  }
+
+threepio :: Character
+threepio = Character
+  { id_ = "2000"
+  , name = "C-3PO"
+  , friends = ["1000","1002","1003","2001" ]
+  , appearsIn = [ 4, 5, 6 ]
+  , homePlanet = "Protocol"
+  }
+
 artoo :: Character
 artoo = Character
   { id_        = "2001"
@@ -116,16 +192,16 @@ getHeroIO = getHero
 
 getHuman :: Alternative f => ID -> f Character
 getHuman "1000" = pure luke
--- getHuman "1001" = "vader"
--- getHuman "1002" = "han"
--- getHuman "1003" = "leia"
--- getHuman "1004" = "tarkin"
+getHuman "1001" = pure vader
+getHuman "1002" = pure han
+getHuman "1003" = pure leia
+getHuman "1004" = pure tarkin
 getHuman _      = empty
 
 getDroid :: Alternative f => ID -> f Character
--- getDroid "2000" = "threepio"
+getDroid "2000" = pure threepio
 getDroid "2001" = pure artoo
-getDroid _ = empty
+getDroid _      = empty
 
 getFriends :: Character -> [Character]
 getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char