diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index 0586a2e..01fc118 100644 --- a/Data/GraphQL/Execute.hs +++ b/Data/GraphQL/Execute.hs @@ -3,7 +3,7 @@ module Data.GraphQL.Execute where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative, (<$>), pure) +import Control.Applicative ((<$>), pure) import Data.Traversable (traverse) #endif import Control.Applicative (Alternative, empty) @@ -13,32 +13,35 @@ import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap import Data.GraphQL.AST -import Data.GraphQL.Schema +import Data.GraphQL.Schema (Resolver, Schema(..)) +import qualified Data.GraphQL.Schema as Schema -execute :: (Alternative f, Monad f) => Schema f -> Document -> f Aeson.Value +execute :: (Alternative m, Monad m) => Schema m -> Document -> m Aeson.Value execute (Schema resolv) doc = selectionSet resolv =<< query doc -query :: Applicative f => Document -> f SelectionSet +query :: Alternative f => Document -> f SelectionSet query (Document [DefinitionOperation (Query (Node _ _ _ sels))]) = pure sels -query _ = error "query: Not implemented yet" +query _ = empty -selectionSet :: (Alternative f, Monad f) => Resolver f -> SelectionSet -> f Aeson.Value -selectionSet resolv sels = Aeson.Object . fold <$> traverse (selection resolv) sels +selectionSet :: Alternative f => Resolver f -> SelectionSet -> f Aeson.Value +selectionSet resolv = fmap (Aeson.Object . fold) . traverse (selection resolv) -selection :: (Alternative f, Monad f) => Resolver f -> Selection -> f Aeson.Object -selection resolv (SelectionField (Field _ n _ _ sfs)) = - fmap (HashMap.singleton n) $ output sfs =<< resolv (InputField n) -selection _ _ = error "selection: Not implemented yet" +selection :: Alternative f => Resolver f -> Selection -> f Aeson.Object +selection resolv (SelectionField field@(Field _ name _ _ _)) = + fmap (HashMap.singleton name) $ Aeson.toJSON <$> resolv (fieldToInput field) +selection _ _ = empty -output :: (Alternative f, Monad f) => SelectionSet -> Output f -> f Aeson.Value -output sels (OutputResolver resolv) = selectionSet resolv sels -output sels (OutputList os) = fmap array . traverse (output sels) =<< os -output sels (OutputEnum e) - | null sels = Aeson.toJSON <$> e - | otherwise = empty -output sels (OutputScalar s) - | null sels = Aeson.toJSON <$> s - | otherwise = empty +-- * AST/Schema conversions -array :: [Aeson.Value] -> Aeson.Value -array = Aeson.toJSON +argument :: Argument -> Schema.Argument +argument (Argument n (ValueInt v)) = (n, Schema.ScalarInt $ fromIntegral v) +argument (Argument n (ValueString (StringValue v))) = (n, Schema.ScalarString v) +argument _ = error "argument: not implemented yet" + +fieldToInput :: Field -> Schema.Input +fieldToInput (Field _ n as _ sels) = + Schema.InputField n (argument <$> as) (fieldToInput . selectionToField <$> sels) + +selectionToField :: Selection -> Field +selectionToField (SelectionField x) = x +selectionToField _ = error "selectionField: not implemented yet" diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index 8a6e625..8ceb11f 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -1,35 +1,34 @@ +{-# LANGUAGE CPP #-} module Data.GraphQL.Schema where -import Data.Maybe (catMaybes) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif -import Data.Text (Text) import Data.Aeson (ToJSON(toJSON)) +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) data Schema f = Schema (QueryRoot f) -- (Maybe MutationRoot) type QueryRoot f = Resolver f -type Resolver f = Input -> f (Output f) +type Resolver f = Input -> f Output -data Output f = OutputResolver (Resolver f) - | OutputList (f [Output f]) - | OutputScalar (f Scalar) - | OutputEnum (f Text) +data Output = OutputObject (HashMap Text Output) + | OutputList [Output] + | OutputScalar Scalar + | OutputEnum Text + deriving (Show) -- | OutputUnion [Output] -- | OutputNonNull (Output) -data Input = InputScalar Scalar - | InputField Text - | InputList [Input] +type Argument = (Text, Scalar) + +data Input = InputField Text [Argument] [Input] deriving (Show) -field :: Input -> Maybe Text -field (InputField x) = Just x -field _ = Nothing - -fields :: [Input] -> [Text] -fields = catMaybes . fmap field - +-- TODO: Make ScalarInt Int32 data Scalar = ScalarInt Int | ScalarFloat Double | ScalarString Text @@ -43,3 +42,10 @@ instance ToJSON Scalar where 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 + diff --git a/graphql.cabal b/graphql.cabal index d270b0b..ea1d152 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -49,6 +49,7 @@ test-suite tasty raw-strings-qq >= 1.1, tasty >= 0.10, tasty-hunit >= 0.9, + unordered-containers >= 0.2.5.0, graphql source-repository head diff --git a/tests/Test/StarWars.hs b/tests/Test/StarWars.hs index a969bda..7e1d8ab 100644 --- a/tests/Test/StarWars.hs +++ b/tests/Test/StarWars.hs @@ -4,14 +4,17 @@ module Test.StarWars where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative, (<$>), pure) +import Control.Applicative ((<$>), pure) import Data.Monoid (mempty) import Data.Traversable (traverse) #endif import Control.Applicative (Alternative, (<|>), empty, liftA2) +import Data.Foldable (fold) import Data.Maybe (catMaybes) import Data.Aeson (object, (.=)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Text.RawString.QQ (r) @@ -111,7 +114,18 @@ test = testGroup "Star Wars Query Tests" ] ] ] - ] + , testCase "Luke ID" $ (@?=) (graphql schema [r| +query FetchLukeQuery { + human(id: "1000") { + name + } +}|]) . Just + $ object [ + "human" .= object [ + "name" .= ("Luke Skywalker" :: Text) + ] + ] + ] ] -- * Schema @@ -119,52 +133,53 @@ test = testGroup "Star Wars Query Tests" type ID = Text -schema :: Alternative f => Schema f +schema :: (Alternative m, Monad m) => Schema m schema = Schema query -query :: Alternative f => QueryRoot f -query (InputField "hero") = pure $ OutputResolver hero -query (InputField "human") = pure $ OutputResolver human -query (InputField "droid") = pure $ OutputResolver droid +query :: (Alternative m, Monad m) => QueryRoot m +query (InputField "hero" args ins) = hero args ins +query (InputField "human" args ins) = human args ins +query (InputField "droid" args ins) = droid args ins query _ = empty -hero :: Alternative f => Resolver f -hero (InputList (InputScalar (ScalarInt ep) : inputFields)) = - withFields inputFields <$> getHero ep -hero (InputField fld) = characterOutput fld $ Left artoo -hero _ = empty +hero :: Alternative f => [Argument] -> [Input] -> f Output +hero [] = characterFields artoo +hero [("episode", ScalarInt n)] = characterFields $ getHero n +hero _ = const empty -human :: Alternative f => Resolver f -human (InputList (InputScalar (ScalarID i) : inputFields)) = - withFields inputFields <$> getHuman i -human _ = empty +human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output +human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i +human _ _ = empty -droid :: Alternative f => Resolver f -droid (InputList (InputScalar (ScalarID i) : inputFields)) = - withFields inputFields <$> getDroid i -droid _ = empty +droid :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output +droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i +droid _ _ = empty -episode :: Alternative f => Int -> Output f -episode 4 = OutputEnum $ pure "NEWHOPE" -episode 5 = OutputEnum $ pure "EMPIRE" -episode 6 = OutputEnum $ pure "JEDI" -episode _ = OutputEnum empty +episode :: Alternative f => Int -> f Output +episode 4 = pure $ OutputEnum "NEWHOPE" +episode 5 = pure $ OutputEnum "EMPIRE" +episode 6 = pure $ OutputEnum "JEDI" +episode _ = empty -characterOutput :: Alternative f => Text -> Character -> f (Output f) -characterOutput "id" char = - pure $ OutputScalar . pure . ScalarString $ id_ char -characterOutput "name" char = - pure $ OutputScalar . pure . ScalarString $ name char -characterOutput "friends" char = - pure . OutputList . pure $ OutputResolver . (\c (InputField f) -> - characterOutput f c) <$> getFriends char -characterOutput "appearsIn" char = - pure $ OutputList . pure . fmap episode $ appearsIn char -characterOutput _ _ = empty +characterField :: Alternative f => Character -> Input -> f (HashMap Text Output) +characterField char (InputField "id" [] []) = + pure . HashMap.singleton "id" . OutputScalar . ScalarString . id_ $ char +characterField char (InputField "name" [] []) = + pure . HashMap.singleton "name" . OutputScalar . ScalarString . name $ char +characterField char (InputField "friends" [] ins) = + fmap (HashMap.singleton "friends" . OutputList) + . traverse (`characterFields` ins) + . getFriends + $ char +characterField char (InputField "appearsIn" [] []) = + fmap (HashMap.singleton "appearsIn" . OutputList) + . traverse episode + . appearsIn + $ char +characterField _ _ = empty -withFields :: Alternative f => [Input] -> Character -> Output f -withFields inputFields char = - OutputList . traverse (`characterOutput` char) $ fields inputFields +characterFields :: Alternative f => Character -> [Input] -> f Output +characterFields char = fmap (OutputObject . fold) . traverse (characterField char) -- * Data -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js @@ -209,8 +224,11 @@ appearsIn :: Character -> [Int] appearsIn (Left x) = _appearsIn . _droidChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x -luke :: Human -luke = Human +luke :: Character +luke = Right luke' + +luke' :: Human +luke' = Human { _humanChar = CharCommon { _id_ = "1000" , _name = "Luke Skywalker" @@ -275,8 +293,12 @@ threepio = Droid , primaryFunction = "Protocol" } -artoo :: Droid -artoo = Droid +artoo :: Character +artoo = Left artoo' + + +artoo' :: Droid +artoo' = Droid { _droidChar = CharCommon { _id_ = "2001" , _name = "R2-D2" @@ -288,19 +310,19 @@ artoo = Droid -- ** Helper functions -getHero :: Applicative f => Int -> f Character -getHero 5 = pure $ Right luke -getHero _ = pure $ Left artoo +getHero :: Int -> Character +getHero 5 = luke +getHero _ = artoo getHeroIO :: Int -> IO Character -getHeroIO = getHero +getHeroIO = pure . getHero getHuman :: Alternative f => ID -> f Character getHuman = fmap Right . getHuman' getHuman' :: Alternative f => ID -> f Human -getHuman' "1000" = pure luke +getHuman' "1000" = pure luke' getHuman' "1001" = pure vader getHuman' "1002" = pure han getHuman' "1003" = pure leia @@ -312,7 +334,7 @@ getDroid = fmap Left . getDroid' getDroid' :: Alternative f => ID -> f Droid getDroid' "2000" = pure threepio -getDroid' "2001" = pure artoo +getDroid' "2001" = pure artoo' getDroid' _ = empty getFriends :: Character -> [Character]