This commit is contained in:
Danny Navarro 2016-02-17 13:13:01 +01:00
parent 7131d1c142
commit a6b2fd297b
3 changed files with 21 additions and 14 deletions

View File

@ -1,5 +1,5 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Data.GraphQL.Execute where module Data.GraphQL.Execute (execute) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), pure) import Control.Applicative ((<$>), pure)
@ -17,20 +17,28 @@ import Data.GraphQL.AST
import Data.GraphQL.Schema (Resolver, Schema(..)) import Data.GraphQL.Schema (Resolver, Schema(..))
import qualified Data.GraphQL.Schema as Schema import qualified Data.GraphQL.Schema as Schema
execute :: (Alternative m, Monad m) => Schema m -> Schema.Subs -> Document -> m Aeson.Value execute
:: (Alternative m, Monad m)
=> Schema m -> Schema.Subs -> Document -> m Aeson.Value
execute (Schema resolv) f doc = selectionSet f resolv =<< query doc execute (Schema resolv) f doc = selectionSet f resolv =<< query doc
query :: Alternative f => Document -> f SelectionSet query :: Alternative f => Document -> f SelectionSet
query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = pure sels
pure sels
query _ = empty query _ = empty
selectionSet :: Alternative f => Schema.Subs -> Resolver f -> SelectionSet -> f Aeson.Value selectionSet
selectionSet f resolv = fmap (Aeson.Object . fold) . traverse (selection f resolv) :: Alternative f
=> Schema.Subs -> Resolver f -> SelectionSet -> f Aeson.Value
selectionSet f resolv = fmap (Aeson.Object . fold)
. traverse (selection f resolv)
selection :: Alternative f => Schema.Subs -> Resolver f -> Selection -> f Aeson.Object selection
:: Alternative f
=> Schema.Subs -> Resolver f -> Selection -> f Aeson.Object
selection f resolv (SelectionField field@(Field alias name _ _ _)) = selection f resolv (SelectionField field@(Field alias name _ _ _)) =
fmap (HashMap.singleton aliasOrName) $ Aeson.toJSON <$> resolv (fieldToInput f field) fmap (HashMap.singleton aliasOrName)
$ Aeson.toJSON
<$> resolv (fieldToInput f field)
where where
aliasOrName = if T.null alias then name else alias aliasOrName = if T.null alias then name else alias
selection _ _ _ = empty selection _ _ _ = empty
@ -48,6 +56,7 @@ argument _ _ = error "argument: not implemented yet"
fieldToInput :: Schema.Subs -> Field -> Schema.Input fieldToInput :: Schema.Subs -> Field -> Schema.Input
fieldToInput f (Field _ n as _ sels) = fieldToInput f (Field _ n as _ sels) =
-- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
Schema.InputField n (catMaybes $ argument f <$> as) Schema.InputField n (catMaybes $ argument f <$> as)
(fieldToInput f . selectionToField <$> sels) (fieldToInput f . selectionToField <$> sels)

View File

@ -10,7 +10,7 @@ import Data.Aeson (ToJSON(toJSON))
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Text (Text, pack) import Data.Text (Text, pack)
data Schema f = Schema (QueryRoot f) -- (Maybe MutationRoot) data Schema f = Schema (QueryRoot f)
type QueryRoot f = Resolver f type QueryRoot f = Resolver f
@ -21,8 +21,6 @@ data Output = OutputObject (HashMap Text Output)
| OutputScalar Scalar | OutputScalar Scalar
| OutputEnum Text | OutputEnum Text
deriving (Show) deriving (Show)
-- | OutputUnion [Output]
-- | OutputNonNull (Output)
type Argument = (Text, Scalar) type Argument = (Text, Scalar)
@ -31,7 +29,7 @@ type Subs = Text -> Maybe Scalar
data Input = InputField Text [Argument] [Input] data Input = InputField Text [Argument] [Input]
deriving (Show) deriving (Show)
-- TODO: Make ScalarInt Int32 -- TODO: GraphQL spec for Integer Scalar is 32bits
data Scalar = ScalarInt Int data Scalar = ScalarInt Int
| ScalarFloat Double | ScalarFloat Double
| ScalarString Text | ScalarString Text

View File

@ -1,4 +1,4 @@
resolver: lts-5.2 resolver: lts-5.3
packages: packages:
- '.' - '.'
extra-deps: [] extra-deps: []