Handle Field arguments in Schema definition

The `Schema` has been overhauled to make `Output` monomorphic.
Traversing the `GraphQL` document is handled implicitly while defining
the `Schema`.

The 4th end-to-end test from `graphql-js` has been ported.

Data/GraphQL/Execute.hs

@@ -3,7 +3,7 @@
 module Data.GraphQL.Execute where
 
 #if !MIN_VERSION_base(4,8,0)
-import Control.Applicative (Applicative, (<$>), pure)
+import Control.Applicative ((<$>), pure)
 import Data.Traversable (traverse)
 #endif
 import Control.Applicative (Alternative, empty)
@@ -13,32 +13,35 @@ import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
 
 import Data.GraphQL.AST
-import Data.GraphQL.Schema
+import Data.GraphQL.Schema (Resolver, Schema(..))
+import qualified Data.GraphQL.Schema as Schema
 
-execute :: (Alternative f, Monad f) => Schema f -> Document -> f Aeson.Value
+execute :: (Alternative m, Monad m) => Schema m -> Document -> m Aeson.Value
 execute (Schema resolv) doc = selectionSet resolv =<< query doc
 
-query :: Applicative f => Document -> f SelectionSet
+query :: Alternative f => Document -> f SelectionSet
 query (Document [DefinitionOperation (Query (Node _ _ _ sels))]) = pure sels
-query _ = error "query: Not implemented yet"
+query _ = empty
 
-selectionSet :: (Alternative f, Monad f) => Resolver f -> SelectionSet -> f Aeson.Value
+selectionSet :: Alternative f => Resolver f -> SelectionSet -> f Aeson.Value
-selectionSet resolv sels = Aeson.Object . fold <$> traverse (selection resolv) sels
+selectionSet resolv = fmap (Aeson.Object . fold) . traverse (selection resolv)
 
-selection :: (Alternative f, Monad f) => Resolver f -> Selection -> f Aeson.Object
+selection :: Alternative f => Resolver f -> Selection -> f Aeson.Object
-selection resolv (SelectionField (Field _ n _ _ sfs)) =
+selection resolv (SelectionField field@(Field _ name _ _ _)) =
-    fmap (HashMap.singleton n) $ output sfs =<< resolv (InputField n)
+    fmap (HashMap.singleton name) $ Aeson.toJSON <$> resolv (fieldToInput field)
-selection _ _ = error "selection: Not implemented yet"
+selection _ _ = empty
 
-output :: (Alternative f, Monad f) => SelectionSet -> Output f -> f Aeson.Value
+-- * AST/Schema conversions
-output sels (OutputResolver resolv) = selectionSet resolv sels
-output sels (OutputList os) = fmap array . traverse (output sels) =<< os
-output sels (OutputEnum e)
-   | null sels = Aeson.toJSON <$> e
-   | otherwise = empty
-output sels (OutputScalar s)
-   | null sels = Aeson.toJSON <$> s
-   | otherwise = empty
 
-array :: [Aeson.Value] -> Aeson.Value
+argument :: Argument -> Schema.Argument
-array = Aeson.toJSON
+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)
+
+selectionToField :: Selection -> Field
+selectionToField (SelectionField x) = x
+selectionToField _ = error "selectionField: not implemented yet"

Data/GraphQL/Schema.hs

@@ -1,35 +1,34 @@
+{-# LANGUAGE CPP #-}
 module Data.GraphQL.Schema where
 
-import Data.Maybe (catMaybes)
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative ((<$>))
+#endif
 
-import Data.Text (Text)
 import Data.Aeson (ToJSON(toJSON))
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
 
 data Schema f = Schema (QueryRoot f) -- (Maybe  MutationRoot)
 
 type QueryRoot f = Resolver f
 
-type Resolver f = Input -> f (Output f)
+type Resolver f = Input -> f Output
 
-data Output f = OutputResolver (Resolver f)
+data Output = OutputObject (HashMap Text Output)
-              | OutputList (f [Output f])
+            | OutputList [Output]
-              | OutputScalar (f Scalar)
+            | OutputScalar Scalar
-              | OutputEnum (f Text)
+            | OutputEnum Text
+              deriving (Show)
            -- | OutputUnion [Output]
            -- | OutputNonNull (Output)
 
-data Input = InputScalar Scalar
+type Argument = (Text, Scalar)
-           | InputField Text
+
-           | InputList [Input]
+data Input = InputField Text [Argument] [Input]
              deriving (Show)
 
-field :: Input -> Maybe Text
+-- TODO: Make ScalarInt Int32
-field (InputField x) = Just x
-field _ = Nothing
-
-fields :: [Input] -> [Text]
-fields = catMaybes . fmap field
-
 data Scalar = ScalarInt     Int
             | ScalarFloat   Double
             | ScalarString  Text
@@ -43,3 +42,10 @@ instance ToJSON Scalar where
     toJSON (ScalarString  x) = toJSON x
     toJSON (ScalarBoolean x) = toJSON x
     toJSON (ScalarID      x) = toJSON x
+
+instance ToJSON Output where
+    toJSON (OutputObject x) = toJSON $ toJSON <$> x
+    toJSON (OutputList   x) = toJSON $ toJSON <$> x
+    toJSON (OutputScalar x) = toJSON x
+    toJSON (OutputEnum   x) = toJSON x
+

graphql.cabal

@@ -49,6 +49,7 @@ test-suite tasty
                        raw-strings-qq >= 1.1,
                        tasty >= 0.10,
                        tasty-hunit >= 0.9,
+                       unordered-containers >= 0.2.5.0,
                        graphql
 
 source-repository head

tests/Test/StarWars.hs

@@ -4,14 +4,17 @@
 module Test.StarWars where
 
 #if !MIN_VERSION_base(4,8,0)
-import Control.Applicative (Applicative, (<$>), pure)
+import Control.Applicative ((<$>), pure)
 import Data.Monoid (mempty)
 import Data.Traversable (traverse)
 #endif
 import Control.Applicative (Alternative, (<|>), empty, liftA2)
+import Data.Foldable (fold)
 import Data.Maybe (catMaybes)
 
 import Data.Aeson (object, (.=))
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
 import Text.RawString.QQ (r)
 
@@ -111,7 +114,18 @@ test = testGroup "Star Wars Query Tests"
                    ]
                ]
            ]
-      ]
+    , testCase "Luke ID" $ (@?=) (graphql schema [r|
+query FetchLukeQuery {
+  human(id: "1000") {
+    name
+  }
+}|]) . Just
+     $ object [
+        "human" .= object [
+           "name" .= ("Luke Skywalker" :: Text)
+           ]
+        ]
+    ]
   ]
 
 -- * Schema
@@ -119,52 +133,53 @@ test = testGroup "Star Wars Query Tests"
 
 type ID = Text
 
-schema :: Alternative f => Schema f
+schema :: (Alternative m, Monad m) => Schema m
 schema = Schema query
 
-query :: Alternative f => QueryRoot f
+query :: (Alternative m, Monad m) => QueryRoot m
-query (InputField "hero")  = pure $ OutputResolver hero
+query (InputField "hero"  args ins) = hero  args ins
-query (InputField "human") = pure $ OutputResolver human
+query (InputField "human" args ins) = human args ins
-query (InputField "droid") = pure $ OutputResolver droid
+query (InputField "droid" args ins) = droid args ins
 query _ = empty
 
-hero :: Alternative f => Resolver f
+hero :: Alternative f => [Argument] -> [Input] -> f Output
-hero (InputList (InputScalar (ScalarInt ep) : inputFields)) =
+hero [] = characterFields artoo
-    withFields inputFields <$> getHero ep
+hero [("episode", ScalarInt n)] = characterFields $ getHero n
-hero (InputField fld) = characterOutput fld $ Left artoo
+hero _ = const empty
-hero _ = empty
 
-human :: Alternative f => Resolver f
+human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
-human (InputList (InputScalar (ScalarID i) : inputFields)) =
+human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i
-    withFields inputFields <$> getHuman i
+human _ _ = empty
-human _ = empty
 
-droid :: Alternative f => Resolver f
+droid :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
-droid (InputList (InputScalar (ScalarID i) : inputFields)) =
+droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i
-    withFields inputFields <$> getDroid i
+droid _ _ = empty
-droid _ = empty
 
-episode :: Alternative f => Int -> Output f
+episode :: Alternative f => Int -> f Output
-episode 4 = OutputEnum $ pure "NEWHOPE"
+episode 4 = pure $ OutputEnum "NEWHOPE"
-episode 5 = OutputEnum $ pure "EMPIRE"
+episode 5 = pure $ OutputEnum "EMPIRE"
-episode 6 = OutputEnum $ pure "JEDI"
+episode 6 = pure $ OutputEnum "JEDI"
-episode _ = OutputEnum empty
+episode _ = empty
 
-characterOutput :: Alternative f => Text -> Character -> f (Output f)
+characterField :: Alternative f => Character -> Input -> f (HashMap Text Output)
-characterOutput "id" char =
+characterField char (InputField "id" [] [])  =
-    pure $ OutputScalar . pure . ScalarString $ id_  char
+   pure . HashMap.singleton "id" . OutputScalar . ScalarString . id_ $ char
-characterOutput "name" char =
+characterField char (InputField "name" [] []) =
-    pure $ OutputScalar . pure . ScalarString $ name char
+   pure . HashMap.singleton "name" . OutputScalar . ScalarString . name $ char
-characterOutput "friends" char =
+characterField char (InputField "friends" [] ins) =
-    pure . OutputList . pure $ OutputResolver . (\c (InputField f) ->
+     fmap (HashMap.singleton "friends" . OutputList)
-      characterOutput f c) <$> getFriends char
+   . traverse (`characterFields` ins)
-characterOutput "appearsIn" char =
+   . getFriends
-    pure $ OutputList . pure . fmap episode $ appearsIn char
+   $ char
-characterOutput _ _ = empty
+characterField char (InputField "appearsIn" [] []) =
+     fmap (HashMap.singleton "appearsIn" . OutputList)
+   . traverse episode
+   . appearsIn
+   $ char
+characterField _ _ = empty
 
-withFields :: Alternative f => [Input] -> Character -> Output f
+characterFields :: Alternative f => Character -> [Input] -> f Output
-withFields inputFields char =
+characterFields char = fmap (OutputObject . fold) . traverse (characterField char)
-    OutputList . traverse (`characterOutput` char) $ fields inputFields
 
 -- * Data
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@@ -209,8 +224,11 @@ appearsIn :: Character -> [Int]
 appearsIn (Left  x) = _appearsIn . _droidChar $ x
 appearsIn (Right x) = _appearsIn . _humanChar $ x
 
-luke :: Human
+luke :: Character
-luke = Human
+luke = Right luke'
+
+luke' :: Human
+luke' = Human
   { _humanChar = CharCommon
       { _id_        = "1000"
       , _name       = "Luke Skywalker"
@@ -275,8 +293,12 @@ threepio = Droid
   , primaryFunction = "Protocol"
   }
 
-artoo :: Droid
+artoo :: Character
-artoo = Droid
+artoo = Left artoo'
+
+
+artoo' :: Droid
+artoo' = Droid
   { _droidChar = CharCommon
       { _id_        = "2001"
       , _name       = "R2-D2"
@@ -288,19 +310,19 @@ artoo = Droid
 
 -- ** Helper functions
 
-getHero :: Applicative f => Int -> f Character
+getHero :: Int -> Character
-getHero 5 = pure $ Right luke
+getHero 5 = luke
-getHero _ = pure $ Left artoo
+getHero _ = artoo
 
 getHeroIO :: Int -> IO Character
-getHeroIO = getHero
+getHeroIO = pure . getHero
 
 
 getHuman :: Alternative f => ID -> f Character
 getHuman = fmap Right . getHuman'
 
 getHuman' :: Alternative f => ID -> f Human
-getHuman' "1000" = pure luke
+getHuman' "1000" = pure luke'
 getHuman' "1001" = pure vader
 getHuman' "1002" = pure han
 getHuman' "1003" = pure leia
@@ -312,7 +334,7 @@ getDroid = fmap Left . getDroid'
 
 getDroid' :: Alternative f => ID -> f Droid
 getDroid' "2000" = pure threepio
-getDroid' "2001" = pure artoo
+getDroid' "2001" = pure artoo'
 getDroid' _      = empty
 
 getFriends :: Character -> [Character]