From 1561e62489beecf2a86625519f02e40cd8db642a Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Mon, 8 Feb 2016 17:30:18 +0100
Subject: Extend `execute` for deeper queries

The second graphql-js end-to-end test was ported and passed
successfully.
---
 Data/GraphQL/Execute.hs | 47 +++++++++++++++++++++++++++--------------------
 1 file changed, 27 insertions(+), 20 deletions(-)

(limited to 'Data/GraphQL/Execute.hs')

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
-- 
cgit v1.2.3