Overhaul Schema DSL

Aside of making the definition of Schemas easier, it takes care of
issues like nested aliases which previously wasn't possible. The naming
of the DSL functions is still provisional.

1 files changed, 28 insertions, 51 deletions

diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 1abda00..ba1eded 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -2,64 +2,41 @@
 module Data.GraphQL.Execute (execute) where
 
 #if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>), pure)
-import Data.Traversable (traverse)
+import Control.Applicative ((<$>))
 #endif
-import Control.Applicative (Alternative, empty)
-import Data.Foldable (fold)
+import Control.Applicative (Alternative)
 import Data.Maybe (catMaybes)
 
 import qualified Data.Aeson as Aeson
-import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Text as T
 
 import Data.GraphQL.AST
-import Data.GraphQL.Schema (Resolver, Schema(..))
+import Data.GraphQL.Schema (Schema(..))
 import qualified Data.GraphQL.Schema as Schema
 
 execute
-  :: (Alternative m, Monad m)
+  :: Alternative m
   => Schema m -> Schema.Subs -> Document -> m Aeson.Value
-execute (Schema resolv) f doc = selectionSet f resolv =<< query doc
-
-query :: Alternative f => Document -> f SelectionSet
-query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = pure sels
-query  _ = empty
-
-selectionSet
-  :: Alternative f
-  => Schema.Subs -> Resolver f -> SelectionSet -> f Aeson.Value
-selectionSet f resolv = fmap (Aeson.Object . fold)
-                      . traverse (selection f resolv)
-
-selection
-  :: Alternative f
-  => Schema.Subs -> Resolver f -> Selection -> f Aeson.Object
-selection f resolv (SelectionField field@(Field alias name _ _ _)) =
-    fmap (HashMap.singleton aliasOrName)
-      $  Aeson.toJSON
-     <$> resolv (fieldToInput f field)
-  where
-    aliasOrName = if T.null alias then name else alias
-selection _ _ _ = empty
-
--- * AST/Schema conversions
-
-argument :: Schema.Subs -> Argument -> Maybe Schema.Argument
-argument f (Argument n (ValueVariable (Variable v))) =
-    maybe Nothing (\v' -> Just (n, v')) $ f v
-argument _ (Argument n (ValueInt v)) =
-    Just (n, Schema.ScalarInt $ fromIntegral v)
-argument _ (Argument n (ValueString (StringValue v))) =
-    Just (n, Schema.ScalarString v)
-argument _ _ = error "argument: not implemented yet"
-
-fieldToInput :: Schema.Subs -> Field -> Schema.Input
-fieldToInput f (Field _ n as _ sels) =
-    -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
-    Schema.InputField n (catMaybes $ argument f <$> as)
-                        (fieldToInput f . selectionToField <$> sels)
-
-selectionToField :: Selection -> Field
-selectionToField (SelectionField x) = x
-selectionToField _ = error "selectionField: not implemented yet"
+execute (Schema resolvm) subs =
+   fmap Aeson.toJSON . Schema.withFields resolvm . rootFields subs
+
+rootFields :: Schema.Subs -> Document -> [Field]
+rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
+    Schema.fields $ substitute subs <$> sels
+rootFields _ _ = []
+
+substitute :: Schema.Subs -> Selection -> Selection
+substitute subs (SelectionField (Field alias name args directives sels)) =
+    SelectionField $ Field
+      alias
+      name
+      -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
+      (catMaybes $ subsArg subs <$> args)
+      directives
+      (substitute subs <$> sels)
+substitute _ sel = sel
+
+-- TODO: Support different value types
+subsArg :: Schema.Subs -> Argument -> Maybe Argument
+subsArg subs (Argument n (ValueVariable (Variable v))) =
+    Argument n . ValueString . StringValue <$> subs v
+subsArg _ arg = Just arg