Allow resolvers to return arbitrary nested lists

graphql.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 83313d55668f177f44fe72b0e590759e61e44093406bd0e7d41af66dd9199c92
+-- hash: 2f09ae8e288ccdea02b6f59bec6625b3f8795841f7ccf7cb19d1de428f0f63cb
 
 name:           graphql
 version:        0.3
@@ -48,6 +48,7 @@ library
       Data.GraphQL.Schema
       Language.GraphQL.Lexer
       Language.GraphQL.Trans
+      Language.GraphQL.Type
   other-modules:
       Paths_graphql
   hs-source-dirs:

src/Data/GraphQL/Schema.hs

@@ -3,22 +3,22 @@
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 --   functions for defining and manipulating Schemas.
 module Data.GraphQL.Schema
-  ( Schema
+  ( Resolver
-  , Resolver
+  , Schema
   , Subs
-  , nullableArray
-  , nullableEnum
-  , nullableObject
-  , nullableScalar
   , object
   , objectA
   , scalar
   , scalarA
-  , array
-  , arrayA
   , enum
   , enumA
   , resolve
+  , wrappedEnum
+  , wrappedEnumA
+  , wrappedObject
+  , wrappedObjectA
+  , wrappedScalar
+  , wrappedScalarA
   -- * AST Reexports
   , Field
   , Argument(..)
@@ -40,6 +40,7 @@ import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
 import qualified Data.Text as T
 import Language.GraphQL.Trans
+import Language.GraphQL.Type
 import Data.GraphQL.AST.Core
 
 -- | A GraphQL schema.
@@ -70,14 +71,18 @@ objectA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
 
--- | Like 'object' but can be null.
+-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
-nullableObject :: MonadPlus m
+wrappedObjectA :: MonadPlus m
-    => Name -> (Arguments -> ActionT m (Maybe [Resolver m])) -> Resolver m
+    => Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m
-nullableObject name f = Resolver name $ resolveFieldValue f resolveRight
+wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
   where
-    resolveRight fld@(Field _ _ _ flds) (Just resolver) = withField (resolve resolver flds) fld
+    resolveRight fld@(Field _ _ _ sels) resolver
-    resolveRight fld Nothing
+        = withField (traverse (`resolve` sels) resolver) fld
-        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
+
+-- | Like 'object' but can be null or a list of objects.
+wrappedObject :: MonadPlus m
+    => Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m
+wrappedObject name = wrappedObjectA name . const
 
 -- | A scalar represents a primitive value, like a string or an integer.
 scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
@@ -88,40 +93,22 @@ scalarA :: (MonadPlus m, Aeson.ToJSON a)
     => Name -> (Arguments -> ActionT m a) -> Resolver m
 scalarA name f = Resolver name $ resolveFieldValue f resolveRight
   where
-    resolveRight fld@(Field _ _ _ []) result = withField (return result) fld
+    resolveRight fld result = withField (return result) fld
-    resolveRight _ _ = mzero
 
--- | Lika 'scalar' but can be null.
+-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
-nullableScalar :: (MonadPlus m, Aeson.ToJSON a)
+wrappedScalarA :: (MonadPlus m, Aeson.ToJSON a)
-    => Name -> (Arguments -> ActionT m (Maybe a)) -> Resolver m
+    => Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
-nullableScalar name f = Resolver name $ resolveFieldValue f resolveRight
+wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
   where
-    resolveRight fld@(Field _ _ _ []) (Just result) = withField (return result) fld
+    resolveRight fld (Named result) = withField (return result) fld
-    resolveRight fld Nothing
+    resolveRight fld Null
         = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
-    resolveRight _ _ = mzero
+    resolveRight fld (List result) = withField (return result) fld
 
--- | Creates a list of 'Resolver's.
+-- | Like 'scalar' but can be null or a list of scalars.
-array :: MonadPlus m => Name -> ActionT m [[Resolver m]] -> Resolver m
+wrappedScalar :: (MonadPlus m, Aeson.ToJSON a)
-array name = arrayA name . const
+    => Name -> ActionT m (Wrapping a) -> Resolver m
-
+wrappedScalar name = wrappedScalarA name . const
--- | Like 'array' but also taking 'Argument's.
-arrayA :: MonadPlus m
-    => Name -> (Arguments -> ActionT m [[Resolver m]]) -> Resolver m
-arrayA name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld@(Field _ _ _ sels) resolver
-        = withField (traverse (`resolve` sels) resolver) fld
-
--- | Like 'array' but can be null.
-nullableArray :: MonadPlus m
-    => Name -> (Arguments -> ActionT m (Maybe [[Resolver m]])) -> Resolver m
-nullableArray name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld@(Field _ _ _ sels) (Just resolver)
-        = withField (traverse (`resolve` sels) resolver) fld
-    resolveRight fld Nothing
-        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
 
 -- | Represents one of a finite set of possible values.
 --   Used in place of a 'scalar' when the possible responses are easily enumerable.
@@ -134,14 +121,19 @@ enumA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld resolver = withField (return resolver) fld
 
--- | Like 'array'' but also taking 'Argument's.
+-- | Like 'enum' but also taking 'Argument's and can be null or a list of enums.
-nullableEnum :: MonadPlus m
+wrappedEnumA :: MonadPlus m
-    => Name -> (Arguments -> ActionT m (Maybe [Text])) -> Resolver m
+    => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
-nullableEnum name f = Resolver name $ resolveFieldValue f resolveRight
+wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
   where
-    resolveRight fld (Just resolver) = withField (return resolver) fld
+    resolveRight fld (Named resolver) = withField (return resolver) fld
-    resolveRight fld Nothing
+    resolveRight fld Null
         = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
+    resolveRight fld (List resolver) = withField (return resolver) fld
+
+-- | Like 'enum' but can be null or a list of enums.
+wrappedEnum :: MonadPlus m => Name -> ActionT m (Wrapping [Text]) -> Resolver m
+wrappedEnum name = wrappedEnumA name . const
 
 resolveFieldValue :: MonadPlus m
     => ([Argument] -> ActionT m a)

src/Language/GraphQL/Type.hs

@@ -0,0 +1,57 @@
+-- | Definitions for @GraphQL@ type system.
+module Language.GraphQL.Type
+    ( Wrapping(..)
+    ) where
+
+import Data.Aeson as Aeson ( ToJSON
+                           , toJSON
+                           )
+import qualified Data.Aeson as Aeson
+
+-- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
+--   type can wrap other wrapping or named types. Wrapping types are lists and
+--   Non-Null types (named types are nullable by default).
+--
+--   This 'Wrapping' type doesn\'t reflect this distinction exactly but it is
+--   used in the resolvers to take into account that the returned value can be
+--   nullable or an (arbitrary nested) list.
+data Wrapping a
+    = List [Wrapping a] -- ^ Arbitrary nested list
+    | Named a -- ^ Named type without further wrapping
+    | Null -- ^ Null
+    deriving (Eq, Show)
+
+instance Functor Wrapping where
+    fmap f (List list) = List $ fmap (fmap f) list
+    fmap f (Named named) = Named $ f named
+    fmap _ Null = Null
+
+instance Foldable Wrapping where
+    foldr f acc (List list) = foldr (flip $ foldr f) acc list
+    foldr f acc (Named named) = f named acc
+    foldr _ acc Null = acc
+
+instance Traversable Wrapping where
+    traverse f (List list) = List <$> traverse (traverse f) list
+    traverse f (Named named) = Named <$> f named
+    traverse _ Null = pure Null
+
+instance Applicative Wrapping where
+    pure = Named
+    Null <*> _ = Null
+    _ <*> Null = Null
+    (Named f) <*> (Named x) = Named $ f x
+    (List fs) <*> (List xs) = List $ (<*>) <$> fs <*> xs
+    (Named f) <*> list = f <$> list
+    (List fs) <*> named = List $ (<*> named) <$> fs
+
+instance Monad Wrapping where
+    return = pure
+    Null >>= _ = Null
+    (Named x) >>= f = f x
+    (List xs) >>= f = List $ fmap (>>= f) xs
+
+instance ToJSON a => ToJSON (Wrapping a) where
+    toJSON (List list) = toJSON list
+    toJSON (Named named) = toJSON named
+    toJSON Null = Aeson.Null

tests/Test/StarWars/Schema.hs

@@ -13,6 +13,7 @@ import Data.GraphQL.Schema ( Schema
                            )
 import qualified Data.GraphQL.Schema as Schema
 import Language.GraphQL.Trans
+import Language.GraphQL.Type
 import Test.StarWars.Data
 
 -- * Schema
@@ -30,12 +31,12 @@ hero = Schema.objectA "hero" $ \case
   _ -> ActionT $ throwE "Invalid arguments."
 
 human :: MonadPlus m => Resolver m
-human = Schema.nullableObject "human" $ \case
+human = Schema.wrappedObjectA "human" $ \case
   [Argument "id" (ValueString i)] -> do
       humanCharacter <- lift $ return $ getHuman i >>= Just
       case humanCharacter of
-        Nothing -> return Nothing
+        Nothing -> return Null
-        Just e -> Just <$> character e
+        Just e -> Named <$> character e
   _ -> ActionT $ throwE "Invalid arguments."
 
 droid :: MonadPlus m => Resolver m
@@ -45,11 +46,12 @@ droid = Schema.objectA "droid" $ \case
 
 character :: MonadPlus m => Character -> ActionT m [Resolver m]
 character char = return
-    [ Schema.scalar "id"              $ return $ id_ char
+    [ Schema.scalar "id" $ return $ id_ char
-    , Schema.scalar "name"            $ return $ name char
+    , Schema.scalar "name" $ return $ name char
-    , Schema.array  "friends"         $ traverse character $ getFriends char
+    , Schema.wrappedObject "friends"
-    , Schema.enum   "appearsIn"       $ return $ foldMap getEpisode $ appearsIn char
+        $ traverse character $ List $ Named <$> getFriends char
+    , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char
     , Schema.scalar "secretBackstory" $ secretBackstory char
-    , Schema.scalar "homePlanet"      $ return $ either mempty homePlanet char
+    , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
-    , Schema.scalar "__typename"      $ return $ typeName char
+    , Schema.scalar "__typename" $ return $ typeName char
     ]