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
parent
8ee50727bd
commit
770df82718
@ -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))]) =
|
||||
|
||||
@ -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)
|
||||
else empty
|
||||
where
|
||||
aliasOrName = if T.null alias then name' else alias
|
||||
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
|
||||
|
||||
withFieldFinal :: Alternative f => Text -> Output -> ResolverM f
|
||||
withFieldFinal n o fld@(Field _ _ [] _ []) = withField n (\_ _ -> pure o) fld
|
||||
withFieldFinal _ _ _ = empty
|
||||
enum :: Alternative f => Text -> f [Text] -> Resolver f
|
||||
enum name enums = enumA name $ \case
|
||||
[] -> enums
|
||||
_ -> empty
|
||||
|
||||
withFields :: Alternative f => ResolverM f -> ResolverO f
|
||||
withFields f = fmap (OutputObject . fold) . traverse f
|
||||
enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
|
||||
enumA name f fld@(Field _ _ args _ []) = withField name (f args) fld
|
||||
enumA _ _ _ = empty
|
||||
|
||||
outputTraverse :: Applicative f => (a -> f Output) -> [a] -> f Output
|
||||
outputTraverse f = fmap OutputList . traverse f
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
@ -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 => Resolver f
|
||||
hero = Schema.objectA "hero" $ \case
|
||||
[] -> character artoo
|
||||
[Argument "episode" (ValueInt n)] -> character $ getHero (fromIntegral n)
|
||||
_ -> empty
|
||||
|
||||
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 f => Resolver f
|
||||
human = Schema.objectA "human" $ \case
|
||||
[Argument "id" (ValueString (StringValue i))] -> character =<< getHuman i
|
||||
_ -> 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 f => Resolver f
|
||||
droid = Schema.objectA "droid" $ \case
|
||||
[Argument "id" (ValueString (StringValue i))] -> character =<< getDroid i
|
||||
_ -> 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
|
||||
_ -> 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
|
||||
|
||||
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
|
||||
]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user