prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Define Schema using Core AST

Browse Source 
Also, temporarily remove error reporting to simplify execution. This should be
restored once the new execution model is nailed.
This commit is contained in:
Danny Navarro 2017-01-29 12:53:15 -03:00
parent 337b620717
commit f35e1f949a
No known key found for this signature in database
GPG Key ID: 81E5F99780FA6A32
3 changed files with 67 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
Data/GraphQL/Execute.hs
View File

@ -3,15 +3,23 @@
module Data.GraphQL.Execute (execute) where module Data.GraphQL.Execute (execute) where
import Control.Applicative (Alternative) import Control.Applicative (Alternative)
import Data.Maybe (catMaybes) import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.GraphQL.AST import qualified Data.GraphQL.AST as AST
import Data.GraphQL.Schema (Schema(..)) import qualified Data.GraphQL.AST.Core as AST.Core
import Data.GraphQL.Schema (Schema)
import qualified Data.GraphQL.Schema as Schema import qualified Data.GraphQL.Schema as Schema
import Data.GraphQL.Error
core :: Schema.Subs -> AST.Document -> AST.Core.Document
core subs ((AST.DefinitionOperation opDef) :| []) = error "Not implemented yet"
core _ ((AST.DefinitionFragment fragDef) :| []) =
error "Fragment definitions not supported yet"
core _ _ = error "Multiple definitions not supported yet"
-- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a -- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a
-- @GraphQL@ 'document'. The substitution is applied to the document using -- @GraphQL@ 'document'. The substitution is applied to the document using
@ -19,9 +27,19 @@ import Data.GraphQL.Error
-- --
-- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or -- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
-- errors wrapped in an /errors/ field. -- errors wrapped in an /errors/ field.
execute :: Alternative f execute
=> Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value :: Alternative f
execute resolvers subs doc = undefined -- resolver resolvs $ rootFields subs doc => Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value
execute schema subs doc = document schema $ core subs doc
document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value
document schema (op :| [])= operation schema op
document _ _ = error "Multiple operations not supported yet"
operation :: Alternative f => Schema f -> AST.Core.Operation -> f Aeson.Value
operation schema (AST.Core.Query flds) =
Schema.resolve (NE.toList schema) (NE.toList flds)
operation _ _ = error "Mutations not supported yet"
-- | Takes a variable substitution function and a @GraphQL@ document. -- | Takes a variable substitution function and a @GraphQL@ document.
-- If the document contains one query (and no other definitions) -- If the document contains one query (and no other definitions)

74
Data/GraphQL/Schema.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to -- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating Schemas. -- functions for defining and manipulating Schemas.
@ -14,15 +13,14 @@ module Data.GraphQL.Schema
, arrayA , arrayA
, enum , enum
, enumA , enumA
, resolvers , resolve
-- * AST Reexports -- * AST Reexports
, Field , Field
, Argument(..) , Argument(..)
, Value(..) , Value(..)
) where ) where
import Control.Applicative (Alternative((<|>), empty)) import Control.Applicative (Alternative( empty))
import Data.Bifunctor (first)
import Data.Foldable (fold) import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -32,10 +30,8 @@ import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T (unwords)
import Data.GraphQL.AST.Core import Data.GraphQL.AST.Core
import Data.GraphQL.Error
-- | A GraphQL schema. -- | A GraphQL schema.
-- @f@ is usually expected to be an instance of 'Alternative'. -- @f@ is usually expected to be an instance of 'Alternative'.
@ -43,24 +39,31 @@ type Schema f = NonEmpty (Resolver f)
-- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
-- (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'. -- (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'.
type Resolver f = Field -> CollectErrsT f Aeson.Object type Resolver f = Field -> f Aeson.Object
type Resolvers f = [Resolver f]
type Fields = [Field]
type Arguments = [Argument]
-- | Variable substitution function. -- | Variable substitution function.
type Subs = Text -> Maybe Text type Subs = Text -> Maybe Text
object :: Alternative f => Name -> [Resolver f] -> Resolver f -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object name resolvs = objectA name $ \case object :: Alternative f => Name -> Resolvers f -> Resolver f
[] -> resolvs object name resolvers = objectA name $ \case
_ -> empty [] -> resolvers
_ -> empty
-- | Like 'object' but also taking 'Argument's. -- | Like 'object' but also taking 'Argument's.
objectA objectA
:: Alternative f :: Alternative f
=> Name -> ([Argument] -> [Resolver f]) -> Resolver f => Name -> (Arguments -> Resolvers f) -> Resolver f
objectA name f fld@(Field _ _ args sels) = withField name (resolvers (f args) sels) fld objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld
-- | A scalar represents a primitive value, like a string or an integer. -- | A scalar represents a primitive value, like a string or an integer.
scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f scalar :: (Alternative f, Aeson.ToJSON a) => Name -> a -> Resolver f
scalar name s = scalarA name $ \case scalar name s = scalarA name $ \case
[] -> pure s [] -> pure s
_ -> empty _ -> empty
@ -68,21 +71,21 @@ scalar name s = scalarA name $ \case
-- | Like 'scalar' but also taking 'Argument's. -- | Like 'scalar' but also taking 'Argument's.
scalarA scalarA
:: (Alternative f, Aeson.ToJSON a) :: (Alternative f, Aeson.ToJSON a)
=> Name -> ([Argument] -> f a) -> Resolver f => Name -> (Arguments -> f a) -> Resolver f
scalarA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld scalarA name f fld@(Field _ _ args []) = withField name (f args) fld
scalarA _ _ _ = empty scalarA _ _ _ = empty
array :: Alternative f => Text -> [[Resolver f]] -> Resolver f array :: Alternative f => Name -> [Resolvers f] -> Resolver f
array name resolvs = arrayA name $ \case array name resolvers = arrayA name $ \case
[] -> resolvs [] -> resolvers
_ -> empty _ -> empty
-- | Like 'array' but also taking 'Argument's. -- | Like 'array' but also taking 'Argument's.
arrayA arrayA
:: Alternative f :: Alternative f
=> Text -> ([Argument] -> [[Resolver f]]) -> Resolver f => Text -> (Arguments -> [Resolvers f]) -> Resolver f
arrayA name f fld@(Field _ _ args sels) = arrayA name f fld@(Field _ _ args sels) =
withField name (joinErrs $ traverse (`resolvers` sels) $ f args) fld withField name (traverse (`resolve` sels) $ f args) fld
-- | Represents one of a finite set of possible values. -- | Represents one of a finite set of possible values.
-- Used in place of a 'scalar' when the possible responses are easily enumerable. -- Used in place of a 'scalar' when the possible responses are easily enumerable.
@ -93,30 +96,25 @@ enum name enums = enumA name $ \case
-- | Like 'enum' but also taking 'Argument's. -- | Like 'enum' but also taking 'Argument's.
enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
enumA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld enumA name f fld@(Field _ _ args []) = withField name (f args) fld
enumA _ _ _ = empty enumA _ _ _ = empty
-- | Helper function to facilitate 'Argument' handling. -- | Helper function to facilitate 'Argument' handling.
withField withField
:: (Alternative f, Aeson.ToJSON a) :: (Alternative f, Aeson.ToJSON a)
=> Name -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value) => Name -> f a -> Field -> f (HashMap Text Aeson.Value)
withField name f (Field alias name' _ _) = withField name f (Field alias name' _ _) =
if name == name' if name == name'
then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f
else empty else empty
where where
aliasOrName = fromMaybe name' alias aliasOrName = fromMaybe name alias
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- | Takes a list of 'Resolver's and a list of 'Field's and applies each
-- 'Resolver' to each 'Field'. Resolves into a value containing the -- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information. -- resolved 'Field', or a null value and error information.
resolvers :: Alternative f => [Resolver f] -> [Field] -> CollectErrsT f Aeson.Value resolve :: Alternative f => Resolvers f -> Fields -> f Aeson.Value
resolvers resolvs = resolve resolvers =
fmap (first Aeson.toJSON . fold) fmap (Aeson.toJSON . fold)
. traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvs) <|> errmsg fld) . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers))
where
errmsg (Field alias name _ _) = addErrMsg msg $ (errWrap . pure) val
where
val = HashMap.singleton aliasOrName Aeson.Null
msg = T.unwords ["field", name, "not resolved."]
aliasOrName = fromMaybe name alias

12
tests/Test/StarWars/Schema.hs
View File

@ -19,7 +19,7 @@ schema = hero :| [human, droid]
hero :: Alternative f => Resolver f hero :: Alternative f => Resolver f
hero = Schema.objectA "hero" $ \case hero = Schema.objectA "hero" $ \case
[] -> character artoo [] -> character artoo
[Argument "episode" (ValueInt n)] -> character $ getHero (fromIntegral n) [Argument "episode" (ValueInt n)] -> character . getHero $ fromIntegral n
_ -> empty _ -> empty
human :: Alternative f => Resolver f human :: Alternative f => Resolver f
@ -34,10 +34,10 @@ droid = Schema.objectA "droid" $ \case
character :: Alternative f => Character -> [Resolver f] character :: Alternative f => Character -> [Resolver f]
character char = character char =
[ Schema.scalar "id" $ id_ char [ Schema.scalar "id" $ id_ char
, Schema.scalar "name" $ name char , Schema.scalar "name" $ name char
, Schema.array "friends" $ character <$> getFriends char , Schema.array "friends" $ character <$> getFriends char
, Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char , Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char
, Schema.scalar "secretBackstory" $ secretBackstory char , Schema.scalar "secretBackstory" $ secretBackstory char
, Schema.scalar "homePlanet" $ either mempty homePlanet char , Schema.scalar "homePlanet" $ either mempty homePlanet char
] ]