Simplify Schema definition API

Now there is one `Resolver` type and the `Output` and `Scalar` types
have been removed. This should be closer to the final Schema definition
API.

1 files changed, 92 insertions, 83 deletions

diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 510741b..10cd691 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -1,111 +1,120 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 module Data.GraphQL.Schema
   ( Schema(..)
-  , QueryRoot
-  , ResolverO
-  , ResolverM
-  , Output(..)
+  , Resolver
   , Subs
-  , Scalar(..)
-  , withField
-  , withFieldFinal
-  , withFields
-  , withArgument
-  , outputTraverse
+  , object
+  , objectA
+  , scalar
+  , scalarA
+  , array
+  , arrayA
+  , enum
+  , enumA
+  , resolvers
   , fields
-  -- * Reexports
+  -- * AST Reexports
   , Field
-  , Argument
+  , Argument(..)
+  , Value(..)
+  , StringValue(..)
   ) where
 
 #if !MIN_VERSION_base(4,8,0)
+import Control.Applicative (pure, (<|>))
+import Data.Foldable (foldMap)
 import Data.Traversable (traverse)
+import Data.Monoid (Monoid(mempty,mappend))
+#else
+import Data.Monoid (Alt(Alt,getAlt))
 #endif
-import Control.Applicative
+import Control.Applicative (Alternative, empty)
 import Data.Maybe (catMaybes)
 import Data.Foldable (fold)
-import Data.String (IsString(fromString))
 
-import Data.Aeson (ToJSON(toJSON))
+import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text, pack)
+import Data.Text (Text)
 import qualified Data.Text as T (null)
 
 import Data.GraphQL.AST
 
-data Schema f = Schema (QueryRoot f)
+data Schema f = Schema [Resolver f]
 
-type QueryRoot f = ResolverM f
-
--- 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]
-            | OutputScalar Scalar
-            | OutputEnum Text
-              deriving (Show)
+type Resolver  f = Field -> f Aeson.Object
 
 type Subs = Text -> Maybe Text
 
--- TODO: GraphQL spec for Integer Scalar is 32bits
-data Scalar = ScalarInt     Int
-            | ScalarFloat   Double
-            | ScalarString  Text
-            | ScalarBoolean Bool
-            | ScalarID      Text
-              deriving (Show)
-
-instance IsString Scalar where
-    fromString = ScalarString . pack
-
-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
-
-instance ToJSON Output where
-    toJSON (OutputObject x) = toJSON $ toJSON <$> x
-    toJSON (OutputList   x) = toJSON $ toJSON <$> x
-    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
+object :: Alternative f => Text -> [Resolver f] -> Resolver f
+object name resolvs = objectA name $ \case
+     [] -> resolvs
+     _  -> empty
+
+objectA
+  :: Alternative f
+  => Text -> ([Argument] -> [Resolver f]) -> Resolver f
+objectA name f fld@(Field _ _ args _ sels) =
+    withField name (resolvers (f args) $ fields sels) fld
+
+scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f
+scalar name s = scalarA name $ \case
+    [] -> pure s
+    _  -> empty
+
+scalarA
+  :: (Alternative f, Aeson.ToJSON a)
+  => Text -> ([Argument] -> f a) -> Resolver f
+scalarA name f fld@(Field _ _ args _ []) = withField name (f args) fld
+scalarA _ _ _ = empty
+
+array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
+array name resolvs = arrayA name $ \case
+    [] -> resolvs
+    _  -> empty
+
+arrayA
+  :: Alternative f
+  => Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
+arrayA name f fld@(Field _ _ args _ sels) =
+     withField name (traverse (flip resolvers $ fields sels) $ f args) fld
+
+enum :: Alternative f => Text -> f [Text] -> Resolver f
+enum name enums = enumA name $ \case
+     [] -> enums
+     _  -> empty
+
+enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
+enumA name f fld@(Field _ _ args _ []) = withField name (f args) fld
+enumA _ _ _ = empty
+
+withField
+  :: (Alternative f, Aeson.ToJSON a)
+  => Text -> f a -> Field -> f (HashMap Text Aeson.Value)
+withField name f (Field alias name' _ _ _) =
+     if name == name'
+        then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f
+        else empty
+     where
+       aliasOrName = if T.null alias then name' else alias
+
+resolvers :: Alternative f => [Resolver f] -> [Field] -> f Aeson.Value
+resolvers resolvs =
+    fmap (Aeson.toJSON . fold)
+  . traverse (\fld -> getAlt $ foldMap (Alt . ($ fld)) resolvs)
 
 field :: Selection -> Maybe Field
 field (SelectionField x) = Just x
 field _ = Nothing
+
+fields :: SelectionSet -> [Field]
+fields = catMaybes . fmap field
+
+#if !MIN_VERSION_base(4,8,0)
+newtype Alt f a = Alt {getAlt :: f a}
+
+instance Alternative f => Monoid (Alt f a) where
+        mempty = Alt empty
+        Alt x `mappend` Alt y = Alt $ x <|> y
+#endif