Initial support for variable substitution

The correspondent end-to-end test has been ported. The variable
definition still needs to be checked.

3 files changed, 38 insertions, 22 deletions

diff --git a/Data/GraphQL.hs b/Data/GraphQL.hs
index d18ff2f..2da8a46 100644
--- a/Data/GraphQL.hs
+++ b/Data/GraphQL.hs
@@ -12,5 +12,9 @@ import Data.GraphQL.Parser
 import Data.GraphQL.Schema
 
 graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
-graphql schema = either (const empty) (execute schema)
-               . Attoparsec.parseOnly document
+graphql = flip graphqlSubs $ const Nothing
+
+graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
+graphqlSubs schema f =
+    either (const empty) (execute schema f)
+  . Attoparsec.parseOnly document
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 01fc118..9d20e5c 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
 module Data.GraphQL.Execute where
 
 #if !MIN_VERSION_base(4,8,0)
@@ -8,6 +7,7 @@ import Data.Traversable (traverse)
 #endif
 import Control.Applicative (Alternative, empty)
 import Data.Foldable (fold)
+import Data.Maybe (catMaybes)
 
 import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
@@ -16,31 +16,37 @@ import Data.GraphQL.AST
 import Data.GraphQL.Schema (Resolver, Schema(..))
 import qualified Data.GraphQL.Schema as Schema
 
-execute :: (Alternative m, Monad m) => Schema m -> Document -> m Aeson.Value
-execute (Schema resolv) doc = selectionSet resolv =<< query doc
+execute :: (Alternative m, Monad 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 _ _ _ sels))]) = pure sels
-query _ = empty
+query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
+  pure sels
+query  _ = empty
 
-selectionSet :: Alternative f => Resolver f -> SelectionSet -> f Aeson.Value
-selectionSet resolv = fmap (Aeson.Object . fold) . traverse (selection resolv)
+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 => Resolver f -> Selection -> f Aeson.Object
-selection resolv (SelectionField field@(Field _ name _ _ _)) =
-    fmap (HashMap.singleton name) $ Aeson.toJSON <$> resolv (fieldToInput field)
-selection _ _ = empty
+selection :: Alternative f => Schema.Subs -> Resolver f -> Selection -> f Aeson.Object
+selection f resolv (SelectionField field@(Field _ name _ _ _)) =
+    fmap (HashMap.singleton name) $ Aeson.toJSON <$> resolv (fieldToInput f field)
+selection _ _ _ = empty
 
 -- * AST/Schema conversions
 
-argument :: Argument -> Schema.Argument
-argument (Argument n (ValueInt v)) = (n, Schema.ScalarInt $ fromIntegral v)
-argument (Argument n (ValueString (StringValue v))) = (n, Schema.ScalarString v)
-argument _ = error "argument: not implemented yet"
-
-fieldToInput :: Field -> Schema.Input
-fieldToInput (Field _ n as _ sels) =
-  Schema.InputField n (argument <$> as) (fieldToInput . selectionToField <$> sels)
+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) =
+    Schema.InputField n (catMaybes $ argument f <$> as)
+                        (fieldToInput f . selectionToField <$> sels)
 
 selectionToField :: Selection -> Field
 selectionToField (SelectionField x) = x
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 8ceb11f..8d63696 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -4,10 +4,11 @@ module Data.GraphQL.Schema where
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative ((<$>))
 #endif
+import Data.String (IsString(fromString))
 
 import Data.Aeson (ToJSON(toJSON))
 import Data.HashMap.Strict (HashMap)
-import Data.Text (Text)
+import Data.Text (Text, pack)
 
 data Schema f = Schema (QueryRoot f) -- (Maybe  MutationRoot)
 
@@ -25,6 +26,8 @@ data Output = OutputObject (HashMap Text Output)
 
 type Argument = (Text, Scalar)
 
+type Subs = Text -> Maybe Scalar
+
 data Input = InputField Text [Argument] [Input]
              deriving (Show)
 
@@ -36,6 +39,9 @@ data Scalar = ScalarInt     Int
             | ScalarID      Text
               deriving (Show)
 
+instance IsString Scalar where
+  fromString = ScalarString . pack
+
 instance ToJSON Scalar where
     toJSON (ScalarInt     x) = toJSON x
     toJSON (ScalarFloat   x) = toJSON x