summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Data/GraphQL/Execute.hs22
-rw-r--r--Data/GraphQL/Schema.hs61
-rw-r--r--graphql.cabal21
-rw-r--r--tests/Test/StarWars.hs157
4 files changed, 140 insertions, 121 deletions
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 06dc9a6..40eb122 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -1,16 +1,32 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedLists #-}
module Data.GraphQL.Execute where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative)
#endif
-import qualified Data.Aeson as Aeson (Value)
+import qualified Data.Aeson as Aeson
import Data.GraphQL.AST
import Data.GraphQL.Schema
type Response = Aeson.Value
-execute :: Applicative f => Schema f -> Document -> f Response
-execute _schema _doc = undefined
+execute :: Schema -> Document -> Maybe Response
+execute (Schema resolv0) doc = go resolv0 =<< root doc
+ where
+
+ root :: Document -> Maybe Selection
+ root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = Just sel
+ root _ = error "root: Not implemented yet"
+
+ go :: Resolver -> Selection -> Maybe Response
+ go resolv (SelectionField (Field _ n _ _ sfs)) =
+ case resolv (InputField n) of
+ (OutputScalar s) -> if null sfs
+ then Just $ Aeson.Object [(n, Aeson.toJSON s)]
+ else Nothing
+ (OutputResolver resolv') -> (\r-> Aeson.Object [(n, r)]) <$> go resolv' (head sfs)
+ _ -> error "go case resolv: Not implemented yet"
+ go _ _ = error "go: Not implemented yet"
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 37938ee..08ddaa1 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -1,33 +1,48 @@
module Data.GraphQL.Schema where
-import Data.Text (Text)
-import Data.HashMap.Lazy (HashMap)
-
-data Schema f = Schema (QueryRoot f) (Maybe (MutationRoot f))
+import Data.Maybe (catMaybes)
+import Text.Show.Functions ()
-type QueryRoot f = Map f
+import Data.Text (Text)
+import Data.Aeson (ToJSON(toJSON))
-type MutationRoot f = Map f
+data Schema = Schema QueryRoot -- (Maybe MutationRoot)
-type Map f = HashMap Text (Resolver f)
+type QueryRoot = Resolver
-type Resolver f = Input -> Output f
+type Resolver = Input -> Output
-data Output f = OutputScalar (f Scalar)
- | OutputMap (Map f)
- | OutputUnion [Map f]
- | OutputEnum (f Scalar)
- | OutputList [Output f]
- | OutputNonNull (Output f)
- | InputError
+data Output = OutputResolver Resolver
+ | OutputList [Output]
+ | OutputScalar Scalar
+ -- | OutputUnion [Output]
+ -- | OutputEnum [Scalar]
+ -- | OutputNonNull (Output)
+ | OutputError
+ deriving (Show)
data Input = InputScalar Scalar
- | InputEnum Scalar
+ | InputField Text
| InputList [Input]
- | InputNonNull Input
-
-data Scalar = ScalarInt Int
- | ScalarFloat Double
- | ScalarString Text
- | ScalarBool Bool
- | ScalarID Text
+ deriving (Show)
+
+field :: Input -> Maybe Text
+field (InputField x) = Just x
+field _ = Nothing
+
+fields :: [Input] -> [Text]
+fields = catMaybes . fmap field
+
+data Scalar = ScalarInt Int
+ | ScalarFloat Double
+ | ScalarString Text
+ | ScalarBoolean Bool
+ | ScalarID Text
+ deriving (Show)
+
+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
diff --git a/graphql.cabal b/graphql.cabal
index e32b593..267f3eb 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -27,11 +27,10 @@ library
Data.GraphQL.Execute
Data.GraphQL.Schema
Data.GraphQL.Parser
- build-depends: base >=4.7 && < 5,
- text >=0.11.3.1,
- aeson >=0.7.0.3,
- attoparsec >=0.10.4.0,
- unordered-containers >=0.2.5.0
+ build-depends: base >= 4.7 && < 5,
+ text >= 0.11.3.1,
+ aeson >= 0.7.0.3,
+ attoparsec >= 0.10.4.0
test-suite tasty
default-language: Haskell2010
@@ -41,12 +40,12 @@ test-suite tasty
ghc-options: -Wall
other-modules: Paths_graphql
Test.StarWars
- build-depends: base >=4.6 && <5,
- aeson >=0.7.0.3,
- text >=0.11.3.1,
- attoparsec >=0.10.4.0,
- tasty >=0.10,
- tasty-hunit >=0.9,
+ build-depends: base >= 4.6 && <5,
+ aeson >= 0.7.0.3,
+ text >= 0.11.3.1,
+ attoparsec >= 0.10.4.0,
+ tasty >= 0.10,
+ tasty-hunit >= 0.9,
graphql
source-repository head
diff --git a/tests/Test/StarWars.hs b/tests/Test/StarWars.hs
index ffafd66..b75e6b6 100644
--- a/tests/Test/StarWars.hs
+++ b/tests/Test/StarWars.hs
@@ -1,13 +1,15 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE RecordWildCards #-}
module Test.StarWars where
-import Data.Functor.Identity (Identity(..))
+import Control.Applicative ((<|>), liftA2)
+import Data.Maybe (catMaybes)
+-- import Data.Functor.Identity (Identity(..))
import Data.Text (Text)
-import Data.Attoparsec.Text (parseOnly)
+-- import Data.Aeson (ToJSON(toJSON), genericToJSON, defaultOptions)
import qualified Data.Aeson as Aeson
+import Data.Attoparsec.Text (parseOnly)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit
@@ -17,119 +19,106 @@ import Data.GraphQL.Execute
import qualified Data.GraphQL.Parser as Parser
import Data.GraphQL.Schema
+
-- * Test
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
test :: TestTree
-test = testCase "R2-D2" $ execute schema heroQuery @=? Identity expected
+test = testCase "R2-D2" $ execute schema heroQuery @?= expected
where
heroQuery :: Document
heroQuery = either (error "Parsing error") id $ parseOnly Parser.document
- "{ query HeroNameQuery { hero { name } } }"
+ "query HeroNameQuery{hero{name}}"
- expected :: Response
- expected = Aeson.Object
- [ ( "hero" , Aeson.Object [ ("name", "R2-D2") ] ) ]
+ expected :: Maybe Response
+ expected = Just $ Aeson.Object [("hero", Aeson.Object [("name", "R2-D2")])]
-- * Schema
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
type ID = Text
-schema :: Applicative f => Schema f
-schema = Schema query Nothing
-
-query :: Applicative f => QueryRoot f
-query = [ ("hero", hero)
- , ("human", human)
- , ("droid", droid)
- ]
-
-hero :: Applicative f => Resolver f
-hero (InputScalar (ScalarInt ep)) = OutputMap $ getHeroF ep
-hero _ = InputError
-
-human :: Applicative f => Resolver f
-human (InputScalar (ScalarString id_)) = OutputScalar $ ScalarString <$> getHumanF id_
-human _ = InputError
-
-droid :: Applicative f => Resolver f
-droid (InputScalar (ScalarString id_)) = OutputScalar $ ScalarString <$> getDroidF id_
-droid _ = InputError
+schema :: Schema
+schema = Schema query
+
+query :: QueryRoot
+query (InputField "hero") = OutputResolver hero
+query (InputField "human") = OutputResolver human
+query (InputField "droid") = OutputResolver droid
+query _ = OutputError
+
+hero :: Resolver
+hero (InputList (InputScalar (ScalarInt ep) : inputFields)) =
+ maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHero ep
+hero (InputField fld) = characterOutput fld artoo
+hero _ = OutputError
+
+human :: Resolver
+human (InputList (InputScalar (ScalarID i) : inputFields)) =
+ maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHuman i
+human _ = OutputError
+
+droid :: Resolver
+droid (InputList (InputScalar (ScalarID i) : inputFields)) =
+ maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getDroid i
+droid _ = OutputError
+
+characterOutput :: Text -> Character -> Output
+characterOutput "id" char = OutputScalar . ScalarString $ id_ char
+characterOutput "name" char = OutputScalar . ScalarString $ name char
+characterOutput "friends" char = OutputList $ OutputResolver . (\c (InputField f) -> characterOutput f c) <$> getFriends char
+characterOutput _ _ = OutputError
-- * Data
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
-- ** Characters
data Character = Character
- { id_ :: ID
- , name :: Text
- , friends :: [ID]
- , appearsIn :: [Int]
+ { id_ :: ID
+ , name :: Text
+ , friends :: [ID]
+ , appearsIn :: [Int]
, homePlanet :: Text
- }
+ } deriving (Show)
luke :: Character
luke = Character
- { id_ = "1000"
- , name = "Luke Skywalker"
- , friends = ["1002","1003","2000","2001"]
- , appearsIn = [4,5,6]
+ { id_ = "1000"
+ , name = "Luke Skywalker"
+ , friends = ["1002","1003","2000","2001"]
+ , appearsIn = [4,5,6]
, homePlanet = "Tatoonie"
}
artoo :: Character
artoo = Character
- { id_ = "2001"
- , name = "R2-D2"
- , friends = ["1000","1002","1003"]
- , appearsIn = [4,5,6]
+ { id_ = "2001"
+ , name = "R2-D2"
+ , friends = ["1000","1002","1003"]
+ , appearsIn = [4,5,6]
, homePlanet = "Astrometch"
}
-type CharacterMap f = Map f
-
-character :: Applicative f => Character -> CharacterMap f
-character (Character{..}) =
- [ ("id_", const . OutputScalar . pure $ ScalarID id_)
- , ("name", const . OutputScalar . pure $ ScalarString name)
- , ("friends", const . OutputList $ OutputScalar . pure . ScalarID <$> friends)
- , ("appearsIn", const . OutputList $ OutputScalar . pure . ScalarInt <$> appearsIn)
- , ("homePlanet", const . OutputScalar . pure $ ScalarString homePlanet)
- ]
-
--- ** Hero
-
-getHero :: Int -> Character
-getHero 5 = luke
-getHero _ = artoo
-
-getHeroF :: Applicative f => Int -> CharacterMap f
-getHeroF = character . getHero
-
--- ** Human
-
-getHuman :: ID -> Text
-getHuman "1000" = "luke"
-getHuman "1001" = "vader"
-getHuman "1002" = "han"
-getHuman "1003" = "leia"
-getHuman "1004" = "tarkin"
-getHuman _ = ""
-
-getHumanF :: Applicative f => ID -> f Text
-getHumanF = pure . getHuman
+-- ** Helper functions
-getHumanIO :: ID -> IO Text
-getHumanIO = getHumanF
+getHero :: Int -> Maybe Character
+getHero 5 = Just luke
+getHero _ = Just artoo
--- ** Droid
+getHuman :: ID -> Maybe Character
+getHuman "1000" = Just luke
+-- getHuman "1001" = "vader"
+-- getHuman "1002" = "han"
+-- getHuman "1003" = "leia"
+-- getHuman "1004" = "tarkin"
+getHuman _ = Nothing
-getDroid :: ID -> Text
-getDroid "2000" = "threepio"
-getDroid "2001" = "artoo"
-getDroid _ = ""
+getDroid :: ID -> Maybe Character
+-- getDroid "2000" = "threepio"
+getDroid "2001" = Just artoo
+getDroid _ = Nothing
-getDroidF :: Applicative f => ID -> f Text
-getDroidF = pure . getDroid
-getDroidIO :: ID -> IO Text
-getDroidIO = getDroidF
+getFriends :: Character -> [Character]
+getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-27 03:06:24 +0000