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
execute
:: Alternative m
=> Schema m -> Schema.Subs -> Document -> m Aeson.Value
execute (Schema resolvm) subs =
fmap Aeson.toJSON . Schema.withFields resolvm . rootFields subs
:: Alternative f
=> Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value
execute (Schema resolvs) subs = Schema.resolvers resolvs . rootFields subs
rootFields :: Schema.Subs -> Document -> [Field]
rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =

View File

@ -1,111 +1,120 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module Data.GraphQL.Schema
( Schema(..)
, QueryRoot
, ResolverO
, ResolverM
, Output(..)
, Resolver
, Subs
, Scalar(..)
, withField
, withFieldFinal
, withFields
, withArgument
, outputTraverse
, object
, objectA
, scalar
, scalarA
, array
, 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
-- 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 Resolver f = Field -> f Aeson.Object
type Subs = Text -> Maybe Text
-- TODO: GraphQL spec for Integer Scalar is 32bits
data Scalar = ScalarInt Int
| ScalarFloat Double
| ScalarString Text
| ScalarBoolean Bool
| ScalarID Text
deriving (Show)
object :: Alternative f => Text -> [Resolver f] -> Resolver f
object name resolvs = objectA name $ \case
[] -> resolvs
_ -> empty
instance IsString Scalar where
fromString = ScalarString . pack
objectA
:: 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
toJSON (ScalarInt x) = toJSON x
toJSON (ScalarFloat x) = toJSON x
toJSON (ScalarString x) = toJSON x
toJSON (ScalarBoolean x) = toJSON x
toJSON (ScalarID x) = toJSON x
scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f
scalar name s = scalarA name $ \case
[] -> pure s
_ -> empty
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
scalarA
:: (Alternative f, Aeson.ToJSON a)
=> Text -> ([Argument] -> f a) -> Resolver f
scalarA name f fld@(Field _ _ args _ []) = withField name (f args) fld
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
withField n f (Field alias name' args _ sels) =
if n == name'
then HashMap.singleton aliasOrName <$> f args (fields sels)
arrayA
:: Alternative f
=> Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
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
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
resolvers :: Alternative f => [Resolver f] -> [Field] -> f Aeson.Value
resolvers resolvs =
fmap (Aeson.toJSON . fold)
. traverse (\fld -> getAlt $ foldMap (Alt . ($ fld)) resolvs)
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

View File

@ -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 = Schema query
schema :: Alternative f => Schema f
schema = Schema [hero, human, droid]
query :: (Alternative m, Monad m) => ResolverM m
query fld =
withField "hero" hero fld
<|> withField "human" human fld
<|> 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
hero :: Alternative f => Resolver f
hero = Schema.objectA "hero" $ \case
[] -> character artoo
[Argument "episode" (ValueInt n)] -> character $ getHero (fromIntegral n)
_ -> empty
droid :: (Alternative m, Monad m) => [Argument] -> ResolverO m
droid args flds =
case withArgument "id" args of
Just (ScalarString i) -> flip characterFields flds =<< getDroid i
human :: Alternative f => Resolver f
human = Schema.objectA "human" $ \case
[Argument "id" (ValueString (StringValue i))] -> character =<< getHuman i
_ -> empty
characterField :: Alternative f => Character -> ResolverM f
characterField char fld =
withFieldFinal "id" (OutputScalar . ScalarString . id_ $ char) fld
<|> withFieldFinal "name" (OutputScalar . ScalarString . name $ char) fld
<|> withField "friends" friends' fld
<|> withField "appearsIn" appears' fld
where
friends' [] flds = outputTraverse (`characterFields` flds) $ getFriends char
friends' _ _ = empty
droid :: Alternative f => Resolver f
droid = Schema.objectA "droid" $ \case
[Argument "id" (ValueString (StringValue i))] -> character =<< getDroid i
_ -> empty
appears' [] [] = outputTraverse (fmap OutputEnum . getEpisode) $ appearsIn char
appears' _ _ = empty
characterFields :: Alternative f => Character -> ResolverO f
characterFields = withFields . characterField
character :: Alternative f => Character -> [Resolver f]
character char =
[ Schema.scalar "id" $ id_ char
, Schema.scalar "name" $ name char
, Schema.array "friends" $ character <$> getFriends char
, Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char
]