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) +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 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 +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 + ]