summaryrefslogtreecommitdiff
path: root/Data
diff options
context:
space:
mode:
Diffstat (limited to 'Data')
-rw-r--r--Data/GraphQL/Execute.hs22
-rw-r--r--Data/GraphQL/Schema.hs61
2 files changed, 57 insertions, 26 deletions
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"
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 37938ee..08ddaa1 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -1,33 +1,48 @@
module Data.GraphQL.Schema where
-import Data.Text (Text)
-import Data.HashMap.Lazy (HashMap)
-
-data Schema f = Schema (QueryRoot f) (Maybe (MutationRoot f))
+import Data.Maybe (catMaybes)
+import Text.Show.Functions ()
-type QueryRoot f = Map f
+import Data.Text (Text)
+import Data.Aeson (ToJSON(toJSON))
-type MutationRoot f = Map f
+data Schema = Schema QueryRoot -- (Maybe MutationRoot)
-type Map f = HashMap Text (Resolver f)
+type QueryRoot = Resolver
-type Resolver f = Input -> Output f
+type Resolver = Input -> Output
-data Output f = OutputScalar (f Scalar)
- | OutputMap (Map f)
- | OutputUnion [Map f]
- | OutputEnum (f Scalar)
- | OutputList [Output f]
- | OutputNonNull (Output f)
- | InputError
+data Output = OutputResolver Resolver
+ | OutputList [Output]
+ | OutputScalar Scalar
+ -- | OutputUnion [Output]
+ -- | OutputEnum [Scalar]
+ -- | OutputNonNull (Output)
+ | OutputError
+ deriving (Show)
data Input = InputScalar Scalar
- | InputEnum Scalar
+ | InputField Text
| InputList [Input]
- | InputNonNull Input
-
-data Scalar = ScalarInt Int
- | ScalarFloat Double
- | ScalarString Text
- | ScalarBool Bool
- | ScalarID Text
+ deriving (Show)
+
+field :: Input -> Maybe Text
+field (InputField x) = Just x
+field _ = Nothing
+
+fields :: [Input] -> [Text]
+fields = catMaybes . fmap field
+
+data Scalar = ScalarInt Int
+ | ScalarFloat Double
+ | ScalarString Text
+ | ScalarBoolean Bool
+ | ScalarID Text
+ deriving (Show)
+
+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