Simplify Schema definition API

Now there is one `Resolver` type and the `Output` and `Scalar` types
have been removed. This should be closer to the final Schema definition
API.

Data/GraphQL/Execute.hs

@@ -14,10 +14,9 @@ import Data.GraphQL.Schema (Schema(..))
 import qualified Data.GraphQL.Schema as Schema
 
 execute
-  :: Alternative m
+  :: Alternative f
-  => Schema m -> Schema.Subs -> Document -> m Aeson.Value
+  => Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value
-execute (Schema resolvm) subs =
+execute (Schema resolvs) subs = Schema.resolvers resolvs . rootFields subs
-   fmap Aeson.toJSON . Schema.withFields resolvm . rootFields subs
 
 rootFields :: Schema.Subs -> Document -> [Field]
 rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =

Data/GraphQL/Schema.hs

@@ -1,111 +1,120 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 module Data.GraphQL.Schema
   ( Schema(..)
-  , QueryRoot
+  , Resolver
-  , ResolverO
-  , ResolverM
-  , Output(..)
   , Subs
-  , Scalar(..)
+  , object
-  , withField
+  , objectA
-  , withFieldFinal
+  , scalar
-  , withFields
+  , scalarA
-  , withArgument
+  , array
-  , outputTraverse
+  , arrayA
+  , enum
+  , enumA
+  , resolvers
   , fields
-  -- * Reexports
+  -- * AST Reexports
   , Field
-  , Argument
+  , Argument(..)
+  , Value(..)
+  , StringValue(..)
   ) where
 
 #if !MIN_VERSION_base(4,8,0)
+import Control.Applicative (pure, (<|>))
+import Data.Foldable (foldMap)
 import Data.Traversable (traverse)
+import Data.Monoid (Monoid(mempty,mappend))
+#else
+import Data.Monoid (Alt(Alt,getAlt))
 #endif
-import Control.Applicative
+import Control.Applicative (Alternative, empty)
 import Data.Maybe (catMaybes)
 import Data.Foldable (fold)
-import Data.String (IsString(fromString))
 
-import Data.Aeson (ToJSON(toJSON))
+import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text, pack)
+import Data.Text (Text)
 import qualified Data.Text as T (null)
 
 import Data.GraphQL.AST
 
-data Schema f = Schema (QueryRoot f)
+data Schema f = Schema [Resolver f]
 
-type QueryRoot f = ResolverM f
+type Resolver  f = Field -> f Aeson.Object
-
--- 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]
-            | OutputScalar Scalar
-            | OutputEnum Text
-              deriving (Show)
 
 type Subs = Text -> Maybe Text
 
--- TODO: GraphQL spec for Integer Scalar is 32bits
+object :: Alternative f => Text -> [Resolver f] -> Resolver f
-data Scalar = ScalarInt     Int
+object name resolvs = objectA name $ \case
-            | ScalarFloat   Double
+     [] -> resolvs
-            | ScalarString  Text
+     _  -> empty
-            | ScalarBoolean Bool
-            | ScalarID      Text
-              deriving (Show)
 
-instance IsString Scalar where
+objectA
-    fromString = ScalarString . pack
+  :: Alternative f
+  => Text -> ([Argument] -> [Resolver f]) -> Resolver f
+objectA name f fld@(Field _ _ args _ sels) =
+    withField name (resolvers (f args) $ fields sels) fld
 
-instance ToJSON Scalar where
+scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f
-    toJSON (ScalarInt     x) = toJSON x
+scalar name s = scalarA name $ \case
-    toJSON (ScalarFloat   x) = toJSON x
+    [] -> pure s
-    toJSON (ScalarString  x) = toJSON x
+    _  -> empty
-    toJSON (ScalarBoolean x) = toJSON x
-    toJSON (ScalarID      x) = toJSON x
 
-instance ToJSON Output where
+scalarA
-    toJSON (OutputObject x) = toJSON $ toJSON <$> x
+  :: (Alternative f, Aeson.ToJSON a)
-    toJSON (OutputList   x) = toJSON $ toJSON <$> x
+  => Text -> ([Argument] -> f a) -> Resolver f
-    toJSON (OutputScalar x) = toJSON x
+scalarA name f fld@(Field _ _ args _ []) = withField name (f args) fld
-    toJSON (OutputEnum   x) = toJSON x
+scalarA _ _ _ = empty
 
--- * Helpers
+array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
+array name resolvs = arrayA name $ \case
+    [] -> resolvs
+    _  -> empty
 
-withField :: Alternative f => Text -> ([Argument] -> ResolverO f) -> ResolverM f
+arrayA
-withField n f (Field alias name' args _ sels) =
+  :: Alternative f
-  if n == name'
+  => Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
-     then HashMap.singleton aliasOrName <$> f args (fields sels)
+arrayA name f fld@(Field _ _ args _ sels) =
+     withField name (traverse (flip resolvers $ fields sels) $ f args) fld
+
+enum :: Alternative f => Text -> f [Text] -> Resolver f
+enum name enums = enumA name $ \case
+     [] -> enums
+     _  -> empty
+
+enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
+enumA name f fld@(Field _ _ args _ []) = withField name (f args) fld
+enumA _ _ _ = empty
+
+withField
+  :: (Alternative f, Aeson.ToJSON a)
+  => Text -> f a -> Field -> f (HashMap Text Aeson.Value)
+withField name f (Field alias name' _ _ _) =
+     if name == name'
+        then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f
         else empty
      where
        aliasOrName = if T.null alias then name' else alias
 
-withFieldFinal :: Alternative f => Text -> Output -> ResolverM f
+resolvers :: Alternative f => [Resolver f] -> [Field] -> f Aeson.Value
-withFieldFinal n o fld@(Field _ _ [] _ []) = withField n (\_ _ -> pure o) fld
+resolvers resolvs =
-withFieldFinal _ _ _ = empty
+    fmap (Aeson.toJSON . fold)
-
+  . traverse (\fld -> getAlt $ foldMap (Alt . ($ fld)) resolvs)
-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
+
+fields :: SelectionSet -> [Field]
+fields = catMaybes . fmap field
+
+#if !MIN_VERSION_base(4,8,0)
+newtype Alt f a = Alt {getAlt :: f a}
+
+instance Alternative f => Monoid (Alt f a) where
+        mempty = Alt empty
+        Alt x `mappend` Alt y = Alt $ x <|> y
+#endif

tests/Test/StarWars/Schema.hs

@@ -1,55 +1,45 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Test.StarWars.Schema where
 
-import Control.Applicative ((<|>), Alternative, empty)
+import Control.Applicative (Alternative, empty)
 
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative ((<$>))
+import Data.Traversable (traverse)
+#endif
 import Data.GraphQL.Schema
+import qualified Data.GraphQL.Schema as Schema
 
 import Test.StarWars.Data
 
 -- * Schema
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
 
-schema :: (Alternative m, Monad m) => Schema m
+schema :: Alternative f => Schema f
-schema = Schema query
+schema = Schema [hero, human, droid]
 
-query :: (Alternative m, Monad m) => ResolverM m
+hero :: Alternative f => Resolver f
-query fld =
+hero = Schema.objectA "hero" $ \case
-      withField "hero"  hero  fld
+  [] -> character artoo
-  <|> withField "human" human fld
+  [Argument "episode" (ValueInt n)] -> character $ getHero (fromIntegral n)
-  <|> withField "droid" droid fld
-
-hero :: Alternative f => [Argument] -> ResolverO f
-hero [] = characterFields artoo
-hero args =
-  case withArgument "episode" args of
-       Just (ScalarInt n) -> characterFields $ getHero n
-       _ -> const empty
-
-human :: (Alternative m, Monad m) => [Argument] -> ResolverO m
-human args flds =
-  case withArgument "id" args of
-       Just (ScalarString i) -> flip characterFields flds =<< getHuman i
   _ -> empty
 
-droid :: (Alternative m, Monad m) => [Argument] -> ResolverO m
+human :: Alternative f => Resolver f
-droid args flds =
+human = Schema.objectA "human" $ \case
-   case withArgument "id" args of
+  [Argument "id" (ValueString (StringValue i))] -> character =<< getHuman i
-        Just (ScalarString i) -> flip characterFields flds =<< getDroid i
   _ -> empty
 
-characterField :: Alternative f => Character -> ResolverM f
+droid :: Alternative f => Resolver f
-characterField char fld =
+droid = Schema.objectA "droid" $ \case
-      withFieldFinal "id"        (OutputScalar . ScalarString . id_ $ char) fld
+   [Argument "id" (ValueString (StringValue i))] -> character =<< getDroid i
-  <|> withFieldFinal "name"      (OutputScalar . ScalarString . name $ char) fld
+   _ -> empty
-  <|> withField      "friends"   friends' fld
-  <|> withField      "appearsIn" appears' fld
-  where
-    friends' [] flds = outputTraverse (`characterFields` flds) $ getFriends char
-    friends' _ _ = empty
 
-    appears' [] [] = outputTraverse (fmap OutputEnum . getEpisode) $ appearsIn char
+character :: Alternative f => Character -> [Resolver f]
-    appears' _ _ = empty
+character char =
-
+  [ Schema.scalar "id"        $ id_ char
-characterFields :: Alternative f => Character -> ResolverO f
+  , Schema.scalar "name"      $ name char
-characterFields = withFields . characterField
+  , Schema.array  "friends"   $ character <$> getFriends char
+  , Schema.enum   "appearsIn" . traverse getEpisode $ appearsIn char
+  ]