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.
This commit is contained in:
Danny Navarro 2016-02-19 19:21:32 +01:00
parent 8ee50727bd
commit 770df82718
3 changed files with 116 additions and 118 deletions

View File

@ -14,10 +14,9 @@ import Data.GraphQL.Schema (Schema(..))
import qualified Data.GraphQL.Schema as Schema import qualified Data.GraphQL.Schema as Schema
execute 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 :: Schema.Subs -> Document -> [Field]
rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =

View File

@ -1,111 +1,120 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module Data.GraphQL.Schema module Data.GraphQL.Schema
( Schema(..) ( Schema(..)
, QueryRoot , Resolver
, ResolverO
, ResolverM
, Output(..)
, Subs , Subs
, Scalar(..) , object
, withField , objectA
, withFieldFinal , scalar
, withFields , scalarA
, withArgument , array
, outputTraverse , arrayA
, enum
, enumA
, resolvers
, fields , fields
-- * Reexports -- * AST Reexports
, Field , Field
, Argument , Argument(..)
, Value(..)
, StringValue(..)
) where ) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative (pure, (<|>))
import Data.Foldable (foldMap)
import Data.Traversable (traverse) import Data.Traversable (traverse)
import Data.Monoid (Monoid(mempty,mappend))
#else
import Data.Monoid (Alt(Alt,getAlt))
#endif #endif
import Control.Applicative import Control.Applicative (Alternative, empty)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Foldable (fold) 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 Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as 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 qualified Data.Text as T (null)
import Data.GraphQL.AST 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 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 else empty
where where
aliasOrName = if T.null alias then name' else alias 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 :: Selection -> Maybe Field
field (SelectionField x) = Just x field (SelectionField x) = Just x
field _ = Nothing 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

View File

@ -1,55 +1,45 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Schema where 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 Data.GraphQL.Schema
import qualified Data.GraphQL.Schema as Schema
import Test.StarWars.Data import Test.StarWars.Data
-- * Schema -- * Schema
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -- 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 _ -> 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 _ -> 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
]