From bb685c9afa740091864220616ecd84d9329bee98 Mon Sep 17 00:00:00 2001 From: Danny Navarro Date: Tue, 26 Jan 2016 12:43:18 +0100 Subject: Rough implementation of `execute` The first end-to-end test taken from `graphql-js` passes but this still needs to be extended to support more general cases. - `Data.GraphQL.Schema` has been heavily modified to support the execution model. More drastic changes are expected in this module. - When defining a `Schema` ordinary functions taking fields as input are being used instead of maps. This makes the implementation of `execute` easier, and, arguably, makes `Schema` definitions more *Haskellish*. - Drop explicit `unordered-containers` dependency. `Aeson.Value`s and field functions should be good enough for now. --- Data/GraphQL/Execute.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) (limited to 'Data/GraphQL/Execute.hs') 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" -- cgit v1.2.3