From 8ee50727bde4779ba5c3aa98f74e669ada66bb26 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Wed, 17 Feb 2016 18:13:10 +0100
Subject: Overhaul Schema DSL

Aside of making the definition of Schemas easier, it takes care of
issues like nested aliases which previously wasn't possible. The naming
of the DSL functions is still provisional.
---
 Data/GraphQL/Schema.hs | 76 +++++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 66 insertions(+), 10 deletions(-)

(limited to 'Data/GraphQL/Schema.hs')

diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 4ec3748..510741b 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -1,20 +1,46 @@
 {-# LANGUAGE CPP #-}
-module Data.GraphQL.Schema where
+module Data.GraphQL.Schema
+  ( Schema(..)
+  , QueryRoot
+  , ResolverO
+  , ResolverM
+  , Output(..)
+  , Subs
+  , Scalar(..)
+  , withField
+  , withFieldFinal
+  , withFields
+  , withArgument
+  , outputTraverse
+  , fields
+  -- * Reexports
+  , Field
+  , Argument
+  ) where
 
 #if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
+import Data.Traversable (traverse)
 #endif
+import Control.Applicative
+import Data.Maybe (catMaybes)
+import Data.Foldable (fold)
 import Data.String (IsString(fromString))
 
 import Data.Aeson (ToJSON(toJSON))
 import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text, pack)
+import qualified Data.Text as T (null)
+
+import Data.GraphQL.AST
 
 data Schema f = Schema (QueryRoot f)
 
-type QueryRoot f = Resolver f
+type QueryRoot f = ResolverM f
 
-type Resolver f = Input -> f Output
+-- 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]
@@ -22,12 +48,7 @@ data Output = OutputObject (HashMap Text Output)
             | OutputEnum Text
               deriving (Show)
 
-type Argument = (Text, Scalar)
-
-type Subs = Text -> Maybe Scalar
-
-data Input = InputField Text [Argument] [Input]
-             deriving (Show)
+type Subs = Text -> Maybe Text
 
 -- TODO: GraphQL spec for Integer Scalar is 32bits
 data Scalar = ScalarInt     Int
@@ -53,3 +74,38 @@ instance ToJSON Output where
     toJSON (OutputScalar x) = toJSON x
     toJSON (OutputEnum   x) = toJSON x
 
+-- * Helpers
+
+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
+
+withFieldFinal :: Alternative f => Text -> Output -> ResolverM f
+withFieldFinal n o fld@(Field _ _ [] _ []) = withField n (\_ _ -> pure o) fld
+withFieldFinal _ _ _ = empty
+
+withFields :: Alternative f => ResolverM f -> ResolverO f
+withFields f = fmap (OutputObject . fold) . traverse f
+
+outputTraverse :: Applicative f => (a -> f Output) -> [a] -> f Output
+outputTraverse f = fmap OutputList . traverse f
+
+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
+
+field :: Selection -> Maybe Field
+field (SelectionField x) = Just x
+field _ = Nothing
-- 
cgit v1.2.3