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.

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 Control.Applicative ((<$>))
-import Data.Traversable (traverse)
 #endif
-import Control.Applicative (Alternative, empty)
+import Control.Applicative (Alternative)
-import Data.Foldable (fold)
 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
+execute (Schema resolvm) subs =
+   fmap Aeson.toJSON . Schema.withFields resolvm . rootFields subs
 
-query :: Alternative f => Document -> f SelectionSet
+rootFields :: Schema.Subs -> Document -> [Field]
-query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = pure sels
+rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
-query  _ = empty
+    Schema.fields $ substitute subs <$> sels
+rootFields _ _ = []
 
-selectionSet
+substitute :: Schema.Subs -> Selection -> Selection
-  :: Alternative f
+substitute subs (SelectionField (Field alias name args directives sels)) =
-  => Schema.Subs -> Resolver f -> SelectionSet -> f Aeson.Value
+    SelectionField $ Field
-selectionSet f resolv = fmap (Aeson.Object . fold)
+      alias
-                      . traverse (selection f resolv)
+      name
-
-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)
+      (catMaybes $ subsArg subs <$> args)
-                        (fieldToInput f . selectionToField <$> sels)
+      directives
+      (substitute subs <$> sels)
+substitute _ sel = sel
 
-selectionToField :: Selection -> Field
+-- TODO: Support different value types
-selectionToField (SelectionField x) = x
+subsArg :: Schema.Subs -> Argument -> Maybe Argument
-selectionToField _ = error "selectionField: not implemented yet"
+subsArg subs (Argument n (ValueVariable (Variable v))) =
+    Argument n . ValueString . StringValue <$> subs v
+subsArg _ arg = Just arg

Data/GraphQL/Schema.hs

@@ -1,20 +1,46 @@
 {-# LANGUAGE CPP #-}
-module Data.GraphQL.Schema where
+module Data.GraphQL.Schema
+  ( Schema(..)
+  , QueryRoot
+  , ResolverO
+  , ResolverM
+  , Output(..)
+  , Subs
+  , Scalar(..)
+  , withField
+  , withFieldFinal
+  , withFields
+  , withArgument
+  , outputTraverse
+  , fields
+  -- * Reexports
+  , Field
+  , Argument
+  ) where
 
 #if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
+import Data.Traversable (traverse)
 #endif
+import Control.Applicative
+import Data.Maybe (catMaybes)
+import Data.Foldable (fold)
 import Data.String (IsString(fromString))
 
 import Data.Aeson (ToJSON(toJSON))
 import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text, pack)
+import qualified Data.Text as T (null)
+
+import Data.GraphQL.AST
 
 data Schema f = Schema (QueryRoot f)
 
-type QueryRoot f = Resolver f
+type QueryRoot f = ResolverM f
 
-type Resolver f = Input -> f Output
+-- TODO: Come up with a unique data type or better renaming
+type ResolverM f =  Field  -> f (HashMap Text Output)
+type ResolverO f = [Field] -> f Output
 
 data Output = OutputObject (HashMap Text Output)
             | OutputList [Output]
@@ -22,12 +48,7 @@ data Output = OutputObject (HashMap Text Output)
             | OutputEnum Text
               deriving (Show)
 
-type Argument = (Text, Scalar)
+type Subs = Text -> Maybe Text
-
-type Subs = Text -> Maybe Scalar
-
-data Input = InputField Text [Argument] [Input]
-             deriving (Show)
 
 -- TODO: GraphQL spec for Integer Scalar is 32bits
 data Scalar = ScalarInt     Int
@@ -53,3 +74,38 @@ instance ToJSON Output where
     toJSON (OutputScalar x) = toJSON x
     toJSON (OutputEnum   x) = toJSON x
 
+-- * Helpers
+
+withField :: Alternative f => Text -> ([Argument] -> ResolverO f) -> ResolverM f
+withField n f (Field alias name' args _ sels) =
+  if n == name'
+     then HashMap.singleton aliasOrName <$> f args (fields sels)
+     else empty
+  where
+    aliasOrName = if T.null alias then name' else alias
+
+withFieldFinal :: Alternative f => Text -> Output -> ResolverM f
+withFieldFinal n o fld@(Field _ _ [] _ []) = withField n (\_ _ -> pure o) fld
+withFieldFinal _ _ _ = empty
+
+withFields :: Alternative f => ResolverM f -> ResolverO f
+withFields f = fmap (OutputObject . fold) . traverse f
+
+outputTraverse :: Applicative f => (a -> f Output) -> [a] -> f Output
+outputTraverse f = fmap OutputList . traverse f
+
+withArgument :: Text -> [Argument] -> Maybe Scalar
+withArgument x [Argument n s] = if x == n then scalarValue s else Nothing
+withArgument _ _ = Nothing
+
+scalarValue :: Value -> Maybe Scalar
+scalarValue (ValueInt x) = Just . ScalarInt $ fromIntegral x
+scalarValue (ValueString (StringValue x)) = Just $ ScalarString x
+scalarValue _ = Nothing
+
+fields :: SelectionSet -> [Field]
+fields = catMaybes . fmap field
+
+field :: Selection -> Maybe Field
+field (SelectionField x) = Just x
+field _ = Nothing

tests/Test/StarWars/Data.hs

@@ -38,7 +38,7 @@ data Droid = Droid
 
 type Character = Either Droid Human
 
--- I don't think this is cumbersome enough to make it worth using lens.
+-- I still don't think this is cumbersome enough to bring lens
 
 id_ :: Character -> ID
 id_ (Left  x) = _id_ . _droidChar $ x
@@ -128,7 +128,6 @@ threepio = Droid
 artoo :: Character
 artoo = Left artoo'
 
-
 artoo' :: Droid
 artoo' = Droid
   { _droidChar = CharCommon
@@ -149,7 +148,6 @@ getHero _ = artoo
 getHeroIO :: Int -> IO Character
 getHeroIO = pure . getHero
 
-
 getHuman :: Alternative f => ID -> f Character
 getHuman = fmap Right . getHuman'
 
@@ -171,3 +169,9 @@ getDroid' _      = empty
 
 getFriends :: Character -> [Character]
 getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
+
+getEpisode :: Alternative f => Int -> f Text
+getEpisode 4 = pure "NEWHOPE"
+getEpisode 5 = pure "EMPIRE"
+getEpisode 6 = pure "JEDI"
+getEpisode _ = empty

tests/Test/StarWars/QueryTests.hs

@@ -18,12 +18,6 @@ import Test.StarWars.Schema
 -- * Test
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
 
-testQuery :: Text -> Aeson.Value -> Assertion
-testQuery q expected = graphql schema q @?= Just expected
-
-testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion
-testQueryParams f q expected = graphqlSubs schema f q @?= Just expected
-
 test :: TestTree
 test = testGroup "Star Wars Query Tests"
   [ testGroup "Basic Queries"
@@ -148,24 +142,23 @@ test = testGroup "Star Wars Query Tests"
       $ object [
           "human" .= object ["name" .= ("Han Solo" :: Text)]
         ]
+    , testCase "Invalid ID" $ testFailParams
+        (\v -> if v == "id"
+                  then Just "Not a valid ID"
+                  else Nothing)
+        [r| query humanQuery($id: String!) {
+              human(id: $id) {
+                name
+              }
+            }
+        |]
         -- TODO: This test is directly ported from `graphql-js`, however do we want
         -- to mimic the same behavior? Is this part of the spec? Once proper
         -- exceptions are implemented this test might no longer be meaningful.
         -- If the same behavior needs to be replicated, should it be implemented
         -- when defining the `Schema` or when executing?
-    --
-    -- , testCase "Invalid ID" . testQueryParams
-    --     (\v -> if v == "id"
-    --               then Just "Not a valid ID"
-    --               else Nothing)
-    --     [r| query humanQuery($id: String!) {
-    --           human(id: $id) {
-    --             name
-    --           }
-    --         }
-    --     |]
         -- $ object ["human" .= Aeson.Null]
-    , testCase "Luke with alias" . testQuery
+    , testCase "Luke aliased" . testQuery
         [r| query FetchLukeAliased {
               luke: human(id: "1000") {
                 name
@@ -177,6 +170,28 @@ test = testGroup "Star Wars Query Tests"
            "name" .= ("Luke Skywalker" :: Text)
            ]
         ]
+    , testCase "R2-D2 ID and friends aliased" . testQuery
+        [r| query HeroNameAndFriendsQuery {
+              hero {
+                id
+                name
+                friends {
+                  friendName: name
+                }
+              }
+            }
+        |]
+      $ object [
+          "hero" .= object [
+              "id" .= ("2001" :: Text)
+            , "name" .= ("R2-D2" :: Text)
+            , "friends" .= [
+                  object ["friendName" .= ("Luke Skywalker" :: Text)]
+                , object ["friendName" .= ("Han Solo" :: Text)]
+                , object ["friendName" .= ("Leia Organa" :: Text)]
+                ]
+            ]
+        ]
     , testCase "Luke and Leia aliased" . testQuery
         [r| query FetchLukeAndLeiaAliased {
               luke: human(id: "1000") {
@@ -196,3 +211,15 @@ test = testGroup "Star Wars Query Tests"
            ]
         ]
   ]
+
+testQuery :: Text -> Aeson.Value -> Assertion
+testQuery q expected = graphql schema q @?= Just expected
+
+-- testFail :: Text -> Assertion
+-- testFail q = graphql schema q @?= Nothing
+
+testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion
+testQueryParams f q expected = graphqlSubs schema f q @?= Just expected
+
+testFailParams :: Subs -> Text -> Assertion
+testFailParams f q = graphqlSubs schema f q @?= Nothing

tests/Test/StarWars/Schema.hs

@@ -1,17 +1,7 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Test.StarWars.Schema where
 
-#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative ((<|>), Alternative, empty)
-import Control.Applicative (pure)
-import Data.Traversable (traverse)
-#endif
-import Control.Applicative (Alternative, empty)
-import Data.Foldable (fold)
-
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text)
 
 import Data.GraphQL.Schema
 
@@ -23,47 +13,43 @@ import Test.StarWars.Data
 schema :: (Alternative m, Monad m) => Schema m
 schema = Schema query
 
-query :: (Alternative m, Monad m) => QueryRoot m
+query :: (Alternative m, Monad m) => ResolverM m
-query (InputField "hero"  args ins) = hero  args ins
+query fld =
-query (InputField "human" args ins) = human args ins
+      withField "hero"  hero  fld
-query (InputField "droid" args ins) = droid args ins
+  <|> withField "human" human fld
-query _ = empty
+  <|> withField "droid" droid fld
 
-hero :: Alternative f => [Argument] -> [Input] -> f Output
+hero :: Alternative f => [Argument] -> ResolverO f
 hero [] = characterFields artoo
-hero [("episode", ScalarInt n)] = characterFields $ getHero n
+hero args =
-hero _ = const empty
+  case withArgument "episode" args of
+       Just (ScalarInt n) -> characterFields $ getHero n
+       _ -> const empty
 
-human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
+human :: (Alternative m, Monad m) => [Argument] -> ResolverO m
-human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i
+human args flds =
-human _ _ = empty
+  case withArgument "id" args of
+       Just (ScalarString i) -> flip characterFields flds =<< getHuman i
+       _ -> empty
 
-droid :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
+droid :: (Alternative m, Monad m) => [Argument] -> ResolverO m
-droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i
+droid args flds =
-droid _ _ = empty
+   case withArgument "id" args of
+        Just (ScalarString i) -> flip characterFields flds =<< getDroid i
+        _ -> empty
 
-episode :: Alternative f => Int -> f Output
+characterField :: Alternative f => Character -> ResolverM f
-episode 4 = pure $ OutputEnum "NEWHOPE"
+characterField char fld =
-episode 5 = pure $ OutputEnum "EMPIRE"
+      withFieldFinal "id"        (OutputScalar . ScalarString . id_ $ char) fld
-episode 6 = pure $ OutputEnum "JEDI"
+  <|> withFieldFinal "name"      (OutputScalar . ScalarString . name $ char) fld
-episode _ = empty
+  <|> withField      "friends"   friends' fld
+  <|> withField      "appearsIn" appears' fld
+  where
+    friends' [] flds = outputTraverse (`characterFields` flds) $ getFriends char
+    friends' _ _ = empty
 
-characterField :: Alternative f => Character -> Input -> f (HashMap Text Output)
+    appears' [] [] = outputTraverse (fmap OutputEnum . getEpisode) $ appearsIn char
-characterField char (InputField "id" [] [])  =
+    appears' _ _ = empty
-   pure . HashMap.singleton "id" . OutputScalar . ScalarString . id_ $ char
-characterField char (InputField "name" [] []) =
-   pure . HashMap.singleton "name" . OutputScalar . ScalarString . name $ char
-characterField char (InputField "friends" [] ins) =
-     fmap (HashMap.singleton "friends" . OutputList)
-   . traverse (`characterFields` ins)
-   . getFriends
-   $ char
-characterField char (InputField "appearsIn" [] []) =
-     fmap (HashMap.singleton "appearsIn" . OutputList)
-   . traverse episode
-   . appearsIn
-   $ char
-characterField _ _ = empty
 
-characterFields :: Alternative f => Character -> [Input] -> f Output
+characterFields :: Alternative f => Character -> ResolverO f
-characterFields char = fmap (OutputObject . fold) . traverse (characterField char)
+characterFields = withFields . characterField