summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Data/GraphQL/Execute.hs7
-rw-r--r--Data/GraphQL/Schema.hs175
-rw-r--r--tests/Test/StarWars/Schema.hs78
3 files changed, 129 insertions, 131 deletions
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index ba1eded..8d0335d 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -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))]) =
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 510741b..10cd691 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -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)
-
-instance IsString Scalar where
- fromString = ScalarString . pack
-
-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
-
-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
-
--- * 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
+object :: Alternative f => Text -> [Resolver f] -> Resolver f
+object name resolvs = objectA name $ \case
+ [] -> resolvs
+ _ -> empty
+
+objectA
+ :: Alternative f
+ => Text -> ([Argument] -> [Resolver f]) -> Resolver f
+objectA name f fld@(Field _ _ args _ sels) =
+ withField name (resolvers (f args) $ fields sels) fld
+
+scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f
+scalar name s = scalarA name $ \case
+ [] -> pure s
+ _ -> empty
+
+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
+
+array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
+array name resolvs = arrayA name $ \case
+ [] -> resolvs
+ _ -> empty
+
+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
+
+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
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 1cd8f42..ffe16ad 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/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 = Schema query
-
-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
- _ -> 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
+schema :: Alternative f => Schema f
+schema = Schema [hero, human, droid]
+
+hero :: Alternative f => Resolver f
+hero = Schema.objectA "hero" $ \case
+ [] -> character artoo
+ [Argument "episode" (ValueInt n)] -> character $ getHero (fromIntegral n)
+ _ -> empty
+
+human :: Alternative f => Resolver f
+human = Schema.objectA "human" $ \case
+ [Argument "id" (ValueString (StringValue i))] -> character =<< getHuman i
+ _ -> empty
+
+droid :: Alternative f => Resolver f
+droid = Schema.objectA "droid" $ \case
+ [Argument "id" (ValueString (StringValue i))] -> character =<< getDroid i
+ _ -> empty
+
+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
+ ]
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-27 01:10:25 +0000