From bb685c9afa740091864220616ecd84d9329bee98 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Tue, 26 Jan 2016 12:43:18 +0100
Subject: 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 | 22 +++++++++++++++---
 Data/GraphQL/Schema.hs  | 61 ++++++++++++++++++++++++++++++-------------------
 2 files changed, 57 insertions(+), 26 deletions(-)

(limited to 'Data')

diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 06dc9a6..40eb122 100644
--- a/Data/GraphQL/Execute.hs
+++ b/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 _doc = undefined
+execute :: Schema -> Document -> Maybe Response
+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"
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 37938ee..08ddaa1 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -1,33 +1,48 @@
 module Data.GraphQL.Schema where
 
-import Data.Text (Text)
-import Data.HashMap.Lazy (HashMap)
-
-data Schema f = Schema (QueryRoot f) (Maybe (MutationRoot f))
+import Data.Maybe (catMaybes)
+import Text.Show.Functions ()
 
-type QueryRoot f = Map f
+import Data.Text (Text)
+import Data.Aeson (ToJSON(toJSON))
 
-type MutationRoot f = Map f
+data Schema = Schema QueryRoot -- (Maybe  MutationRoot)
 
-type Map f = HashMap Text (Resolver f)
+type QueryRoot = Resolver
 
-type Resolver f = Input -> Output f
+type Resolver = Input -> Output
 
-data Output f = OutputScalar (f Scalar)
-              | OutputMap (Map f)
-              | OutputUnion [Map f]
-              | OutputEnum (f Scalar)
-              | OutputList [Output f]
-              | OutputNonNull (Output f)
-              | InputError
+data Output = OutputResolver Resolver
+            | OutputList [Output]
+            | OutputScalar Scalar
+         -- | OutputUnion [Output]
+         -- | OutputEnum [Scalar]
+         -- | OutputNonNull (Output)
+            | OutputError
+              deriving (Show)
 
 data Input = InputScalar Scalar
-           | InputEnum Scalar
+           | InputField Text
            | InputList [Input]
-           | InputNonNull Input
-
-data Scalar = ScalarInt Int
-            | ScalarFloat Double
-            | ScalarString Text
-            | ScalarBool Bool
-            | ScalarID Text
+             deriving (Show)
+
+field :: Input -> Maybe Text
+field (InputField x) = Just x
+field _ = Nothing
+
+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
-- 
cgit v1.2.3