Support variables in AST transformation

Data/GraphQL/AST/Core.hs

@@ -3,6 +3,7 @@ module Data.GraphQL.AST.Core where
 
 import Data.Int (Int32)
 import Data.List.NonEmpty (NonEmpty)
+import Data.String
 
 import Data.Text (Text)
 
@@ -31,4 +32,7 @@ data Value = ValueInt Int32
            | ValueObject [ObjectField]
              deriving (Eq,Show)
 
+instance IsString Value where
+  fromString = ValueString . fromString
+
 data ObjectField = ObjectField Name Value deriving (Eq,Show)

Data/GraphQL/AST/Transform.hs

@@ -4,10 +4,10 @@ import Control.Applicative (empty)
 import Control.Monad ((<=<))
 import Data.Bifunctor (first)
 import Data.Either (partitionEithers)
+import Data.Foldable (fold, foldMap)
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Maybe (maybeToList)
 import Data.Monoid (Alt(Alt,getAlt))
-import Data.Foldable (foldMap)
 
 import Data.Text (Text)
 
@@ -25,7 +25,11 @@ type Fragmenter = Name -> [Core.Field]
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
 document subs defs = operations subs fr ops
   where
-    (fr, ops) = first foldFrags . partitionEithers . NonEmpty.toList $ defrag <$> defs
+    (fr, ops) = first foldFrags
+              . partitionEithers
+              . NonEmpty.toList
+              $ defrag subs
+            <$> defs
 
     foldFrags :: [Fragmenter] -> Fragmenter
     foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
@@ -46,53 +50,70 @@ operation
   -> Maybe Core.Operation
 operation subs fr (Full.OperationSelectionSet sels) =
   operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
-operation _subs fr (Full.OperationDefinition ot _n _vars _dirs sels) =
+-- TODO: Validate Variable definitions with substituter
+operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) =
   case ot of
     Full.Query    -> Core.Query    <$> node
     Full.Mutation -> Core.Mutation <$> node
   where
-    node = traverse (hush <=< selection fr) sels
+    node = traverse (hush <=< selection subs fr) sels
 
-selection :: Fragmenter -> Full.Selection -> Maybe (Either [Core.Field] Core.Field)
+selection
-selection fr (Full.SelectionField _fld) = Right <$> field fr _fld
+  :: Schema.Subs
-selection fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) = Just . Left $ fr n
+  -> Fragmenter
-selection _  (Full.SelectionInlineFragment _)  = error "Inline fragments not supported yet"
+  -> Full.Selection
+  -> Maybe (Either [Core.Field] Core.Field)
+selection subs fr (Full.SelectionField fld) =
+  Right <$> field subs fr fld
+selection _    fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
+  Just . Left $ fr n
+selection _ _  (Full.SelectionInlineFragment _)  =
+  error "Inline fragments not supported yet"
 
 -- * Fragment replacement
 
 -- | Extract Fragments into a single Fragmenter function and a Operation
 --   Definition.
-defrag :: Full.Definition -> Either Fragmenter Full.OperationDefinition
+defrag
-defrag (Full.DefinitionOperation op) = Right op
+  :: Schema.Subs
-defrag (Full.DefinitionFragment fragDef) = Left $ fragmentDefinition fragDef
+  -> Full.Definition
+  -> Either Fragmenter Full.OperationDefinition
+defrag _    (Full.DefinitionOperation op) =
+  Right op
+defrag subs (Full.DefinitionFragment fragDef) =
+  Left $ fragmentDefinition subs fragDef
 
-fragmentDefinition :: Full.FragmentDefinition -> Fragmenter
+fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter
-fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) name' =
+fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' =
   -- TODO: Support fragments within fragments. Fold instead of map.
   if name == name'
-  then either id pure =<< maybeToList =<< NonEmpty.toList (selection mempty <$> sels)
+  then either id pure =<< maybeToList
+                      =<< NonEmpty.toList (selection subs mempty <$> sels)
   else empty
 
-field :: Fragmenter -> Full.Field -> Maybe Core.Field
+field :: Schema.Subs -> Fragmenter -> Full.Field -> Maybe Core.Field
-field fr (Full.Field a n args _ sels) =
+field subs fr (Full.Field a n args _dirs sels) =
-    Core.Field a n (argument <$> args) <$> traverse (hush <=< selection fr) sels
+      Core.Field a n (fold $ argument subs `traverse` args)
+  <$> traverse (hush <=< selection subs fr) sels
 
-argument :: Full.Argument -> Core.Argument
+argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
-argument (Full.Argument n v) = Core.Argument n (value v)
+argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
 
-value :: Full.Value -> Core.Value
+value :: Schema.Subs -> Full.Value -> Maybe Core.Value
-value (Full.ValueVariable _) = error "Variables within fragments not supported yet"
+value subs (Full.ValueVariable n) = subs n
-value (Full.ValueInt      i) = Core.ValueInt i
+value _    (Full.ValueInt      i) = pure $ Core.ValueInt i
-value (Full.ValueFloat    f) = Core.ValueFloat f
+value _    (Full.ValueFloat    f) = pure $ Core.ValueFloat f
-value (Full.ValueString   x) = Core.ValueString x
+value _    (Full.ValueString   x) = pure $ Core.ValueString x
-value (Full.ValueBoolean  b) = Core.ValueBoolean b
+value _    (Full.ValueBoolean  b) = pure $ Core.ValueBoolean b
-value  Full.ValueNull        = Core.ValueNull
+value _     Full.ValueNull        = pure   Core.ValueNull
-value (Full.ValueEnum     e) = Core.ValueEnum e
+value _    (Full.ValueEnum     e) = pure $ Core.ValueEnum e
-value (Full.ValueList     l) = Core.ValueList (value <$> l)
+value subs (Full.ValueList     l) =
-value (Full.ValueObject   o) = Core.ValueObject (objectField <$> o)
+  Core.ValueList   <$> traverse (value subs) l
+value subs (Full.ValueObject   o) =
+  Core.ValueObject <$> traverse (objectField subs) o
 
-objectField :: Full.ObjectField -> Core.ObjectField
+objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField
-objectField (Full.ObjectField n v) = Core.ObjectField n (value v)
+objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v
 
 hush :: Either a b -> Maybe b
 hush = either (const Nothing) Just

Data/GraphQL/Schema.hs

@@ -48,7 +48,7 @@ type Fields = [Field]
 type Arguments = [Argument]
 
 -- | Variable substitution function.
-type Subs = Text -> Maybe Text
+type Subs = Name -> Maybe Value
 
 -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
 object :: Alternative f => Name -> Resolvers f -> Resolver f
@@ -110,7 +110,6 @@ withField name f (Field alias name' _ _) =
   where
     aliasOrName = fromMaybe name alias
 
-
 -- | Takes a list of 'Resolver's and a list of 'Field's and applies each
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.