Replace Alternative with MonadPlus

Data/GraphQL.hs

@@ -1,7 +1,7 @@
 -- | This module provides the functions to parse and execute @GraphQL@ queries.
 module Data.GraphQL where
 
-import Control.Applicative (Alternative)
+import Control.Monad (MonadPlus)
 
 import qualified Data.Text as T
 
@@ -21,7 +21,7 @@ import Data.GraphQL.Error
 --   executed according to the given 'Schema'.
 --
 --   Returns the response as an @Aeson.@'Aeson.Value'.
-graphql :: (Alternative m, Monad m) => Schema m -> T.Text -> m Aeson.Value
+graphql :: MonadPlus m => Schema m -> T.Text -> m Aeson.Value
 graphql = flip graphqlSubs $ const Nothing
 
 -- | Takes a 'Schema', a variable substitution function and text
@@ -30,7 +30,7 @@ graphql = flip graphqlSubs $ const Nothing
 --   query and the query is then executed according to the given 'Schema'.
 --
 --   Returns the response as an @Aeson.@'Aeson.Value'.
-graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> T.Text -> m Aeson.Value
+graphqlSubs :: MonadPlus m => Schema m -> Subs -> T.Text -> m Aeson.Value
 graphqlSubs schema f =
     either (parseError . errorBundlePretty) (execute schema f)
     . parse document ""

Data/GraphQL/Error.hs

@@ -1,57 +1,57 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
+module Data.GraphQL.Error
-module Data.GraphQL.Error (
+  ( parseError
-  parseError,
+  , CollectErrsT
-  CollectErrsT,
+  , addErr
-  addErr,
+  , addErrMsg
-  addErrMsg,
+  , runCollectErrs
-  runCollectErrs,
+  , runAppendErrs
-  joinErrs,
-  errWrap
   ) where
 
 import qualified Data.Aeson as Aeson
 import Data.Text (Text, pack)
-
+import Control.Monad.Trans.Class (lift)
-import Control.Arrow ((&&&))
+import Control.Monad.Trans.State ( StateT
+                                 , modify
+                                 , runStateT
+                                 )
 
 -- | Wraps a parse error into a list of errors.
 parseError :: Applicative f => String -> f Aeson.Value
 parseError s =
   pure $ Aeson.object [("errors", Aeson.toJSON [makeErrorMsg $ pack s])]
 
--- | A wrapper for an 'Applicative' to pass error messages around.
+-- | A wrapper to pass error messages around.
-type CollectErrsT f a = f (a,[Aeson.Value])
+type CollectErrsT m = StateT [Aeson.Value] m
-
--- | Takes a (wrapped) list (foldable functor) of values and errors,
---   joins the values into a list and concatenates the errors.
-joinErrs
-  :: (Functor m, Functor f, Foldable f)
-  => m (f (a,[Aeson.Value])) -> CollectErrsT m (f a)
-joinErrs = fmap $ fmap fst &&& concatMap snd
-
--- | Wraps the given 'Applicative' to handle errors
-errWrap :: Functor f => f a -> f (a, [Aeson.Value])
-errWrap = fmap (, [])
 
 -- | Adds an error to the list of errors.
-addErr :: Functor f => Aeson.Value -> CollectErrsT f a -> CollectErrsT f a
+addErr :: Monad m => Aeson.Value -> CollectErrsT m ()
-addErr v = (fmap . fmap) (v :)
+addErr v = modify (v :)
 
 makeErrorMsg :: Text -> Aeson.Value
-makeErrorMsg s = Aeson.object [("message",Aeson.toJSON s)]
+makeErrorMsg s = Aeson.object [("message", Aeson.toJSON s)]
 
 -- | Convenience function for just wrapping an error message.
-addErrMsg :: Functor f => Text -> CollectErrsT f a -> CollectErrsT f a
+addErrMsg :: Monad m => Text -> CollectErrsT m ()
 addErrMsg = addErr . makeErrorMsg
 
--- | Runs the given query, but collects the errors into an error
+-- | Appends the given list of errors to the current list of errors.
---   list which is then sent back with the data.
+appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m ()
-runCollectErrs :: Functor f => CollectErrsT f Aeson.Value -> f Aeson.Value
+appendErrs errs = modify (errs ++)
-runCollectErrs = fmap finalD
+
-  where
+-- | Runs the given query computation, but collects the errors into an error
-    finalD (dat,errs) =
+--   list, which is then sent back with the data.
-        Aeson.object
+runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value
-      $ if null errs
+runCollectErrs res = do
-           then [("data",dat)]
+    (dat, errs) <- runStateT res []
-           else [("data",dat),("errors",Aeson.toJSON $ reverse errs)]
+    if null errs
+       then return $ Aeson.object [("data", dat)]
+       else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)]
+
+-- | Runs the given computation, collecting the errors and appending them
+--   to the previous list of errors.
+runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a
+runAppendErrs f = do
+    (v, errs) <- lift $ runStateT f []
+    appendErrs errs
+    return v

Data/GraphQL/Execute.hs

@@ -3,7 +3,7 @@
 --   according to a 'Schema'.
 module Data.GraphQL.Execute (execute) where
 
-import Control.Applicative (Alternative, empty)
+import Control.Monad (MonadPlus(..))
 import Data.GraphQL.Error
 import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty (NonEmpty((:|)))
@@ -21,15 +21,17 @@ import qualified Data.GraphQL.Schema as Schema
 --   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
 --   errors wrapped in an /errors/ field.
 execute
-  :: (Alternative f, Monad f)
+  :: (MonadPlus m)
-  => Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value
+  => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value
-execute schema subs doc = document schema =<< maybe empty pure (Transform.document subs doc)
+execute schema subs doc = do
+    coreDocument <- maybe mzero pure (Transform.document subs doc)
+    document schema coreDocument
 
-document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value
+document :: MonadPlus m => Schema m -> AST.Core.Document -> m Aeson.Value
 document schema (op :| []) = operation schema op
 document _ _ = error "Multiple operations not supported yet"
 
-operation :: Alternative f => Schema f -> AST.Core.Operation -> f Aeson.Value
+operation :: MonadPlus m => Schema m -> AST.Core.Operation -> m Aeson.Value
 operation schema (AST.Core.Query flds)
     = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
 operation schema (AST.Core.Mutation flds)

Data/GraphQL/Schema.hs

@@ -25,13 +25,17 @@ module Data.GraphQL.Schema
   , Value(..)
   ) where
 
-import Control.Applicative (Alternative(empty), (<|>))
+import Control.Applicative (Alternative(..))
-import Data.Bifunctor (first)
+import Control.Monad (MonadPlus)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State ( get
+                                 , put
+                                 )
 import Data.Foldable (fold)
 import Data.GraphQL.Error
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (fromMaybe)
-import Data.Monoid (Alt(Alt,getAlt))
+import Data.Monoid (Alt(..))
 import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
@@ -41,13 +45,13 @@ import Data.GraphQL.AST.Core
 
 -- | A GraphQL schema.
 --   @f@ is usually expected to be an instance of 'Alternative'.
-type Schema f = NonEmpty (Resolver f)
+type Schema m = NonEmpty (Resolver m)
 
 -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
 --   (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'.
-type Resolver f = Field -> CollectErrsT f Aeson.Object
+type Resolver m = Field -> CollectErrsT m Aeson.Object
 
-type Resolvers f = [Resolver f]
+type Resolvers m = [Resolver m]
 
 type Fields = [Field]
 
@@ -57,107 +61,108 @@ type Arguments = [Argument]
 type Subs = Name -> Maybe Value
 
 -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
-object :: Alternative f => Name -> Resolvers f -> Resolver f
+object :: MonadPlus m => Name -> Resolvers m -> Resolver m
 object name resolvers = objectA name $ \case
   [] -> resolvers
   _  -> empty
 
 -- | Like 'object' but also taking 'Argument's.
 objectA
-  :: Alternative f
+  :: MonadPlus m
-  => Name -> (Arguments -> Resolvers f) -> Resolver f
+  => Name -> (Arguments -> Resolvers m) -> Resolver m
 objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld
 
 
 -- | Create a named 'Resolver' from a list of 'Resolver's.
-object' :: (Alternative f, Monad f) => T.Text -> f [Resolver f] -> Resolver f
+object' :: MonadPlus m => Name -> m (Resolvers m) -> Resolver m
 object' name resolvs = objectA' name $ \case
      [] -> resolvs
      _  -> empty
 
 -- | Like 'object'' but also taking 'Argument's.
 objectA'
-  :: (Alternative f, Monad f)
+  :: MonadPlus m
-  => T.Text -> ([Argument] -> f [Resolver f]) -> Resolver f
+  => Name -> (Arguments -> m (Resolvers m)) -> Resolver m
 objectA' name f fld@(Field _ _ args flds) = do
-    resolvs <- f args
+    resolvs <- lift $ f args
     withField name (resolve resolvs flds) fld
 
-
 -- | A scalar represents a primitive value, like a string or an integer.
-scalar :: (Alternative f, Aeson.ToJSON a) => Name -> a -> Resolver f
+scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> a -> Resolver m
 scalar name s = scalarA name $ \case
     [] -> pure s
     _  -> empty
 
 -- | Like 'scalar' but also taking 'Argument's.
 scalarA
-  :: (Alternative f, Aeson.ToJSON a)
+  :: (MonadPlus m, Aeson.ToJSON a)
-  => Name -> (Arguments -> f a) -> Resolver f
+  => Name -> (Arguments -> m a) -> Resolver m
-scalarA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
+scalarA name f fld@(Field _ _ args []) = withField name (lift $ f args) fld
 scalarA _ _ _ = empty
 
-array :: Alternative f => Name -> [Resolvers f] -> Resolver f
+array :: MonadPlus m => Name -> [Resolvers m] -> Resolver m
 array name resolvers = arrayA name $ \case
     [] -> resolvers
     _  -> empty
 
 -- | Like 'array' but also taking 'Argument's.
 arrayA
-  :: Alternative f
+  :: MonadPlus m
-  => T.Text -> (Arguments -> [Resolvers f]) -> Resolver f
+  => Name -> (Arguments -> [Resolvers m]) -> Resolver m
 arrayA name f fld@(Field _ _ args sels) =
-     withField name (joinErrs $ traverse (`resolve` sels) $ f args) fld
+     withField name (traverse (`resolve` sels) $ f args) fld
 
 -- | Like 'object'' but taking lists of 'Resolver's instead of a single list.
-array' :: (Alternative f, Monad f) => T.Text -> f [[Resolver f]] -> Resolver f
+array' :: MonadPlus m => Name -> m [Resolvers m] -> Resolver m
 array' name resolvs = arrayA' name $ \case
     [] -> resolvs
     _  -> empty
 
 -- | Like 'array'' but also taking 'Argument's.
 arrayA'
-  :: (Alternative f, Monad f)
+  :: MonadPlus m
-  => T.Text -> ([Argument] -> f [[Resolver f]]) -> Resolver f
+  => Name -> (Arguments -> m [Resolvers m]) -> Resolver m
 arrayA' name f fld@(Field _ _ args sels) = do
-     resolvs <- f args
+     resolvs <- lift $ f args
-     withField name (joinErrs $ traverse (`resolve` sels) resolvs) fld
+     withField name (traverse (`resolve` sels) resolvs) fld
 
 -- | Represents one of a finite set of possible values.
 --   Used in place of a 'scalar' when the possible responses are easily enumerable.
-enum :: Alternative f => T.Text -> f [T.Text] -> Resolver f
+enum :: MonadPlus m => Name -> m [T.Text] -> Resolver m
 enum name enums = enumA name $ \case
      [] -> enums
      _  -> empty
 
 -- | Like 'enum' but also taking 'Argument's.
-enumA :: Alternative f => T.Text -> ([Argument] -> f [T.Text]) -> Resolver f
+enumA :: MonadPlus m => Name -> (Arguments -> m [T.Text]) -> Resolver m
-enumA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
+enumA name f fld@(Field _ _ args []) = withField name (lift $ f args) fld
 enumA _ _ _ = empty
 
 -- | Helper function to facilitate 'Argument' handling.
-withField
+withField :: (MonadPlus m, Aeson.ToJSON a)
-  :: (Alternative f, Aeson.ToJSON a)
+          => Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap T.Text Aeson.Value)
-  => Name -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap T.Text Aeson.Value)
 withField name v (Field alias name' _ _)
-    | name == name' = fmap getValue v
+    | name == name' = do
+        collection <- HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v
+        errors <- get
+        if null errors
+           then return collection
+           -- TODO: Report error when Non-Nullable type for field argument.
+           else put [] >> return (HashMap.singleton aliasOrName Aeson.Null)
     | otherwise = empty
   where
     aliasOrName = fromMaybe name alias
-    getValue (x, []) = (HashMap.singleton aliasOrName $ Aeson.toJSON x, [])
-         -- TODO: Report error when Non-Nullable type for field argument.
-    getValue (_, _) = (HashMap.singleton aliasOrName Aeson.Null, [])
 
 -- | Takes a list of 'Resolver's and a list of 'Field's and applies each
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.
-resolve :: Alternative f => Resolvers f -> Fields -> CollectErrsT f Aeson.Value
+resolve :: MonadPlus m => Resolvers m -> Fields -> CollectErrsT m Aeson.Value
 resolve resolvers =
-    fmap (first Aeson.toJSON . fold)
+    fmap (Aeson.toJSON . fold)
   . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers) <|> errmsg fld)
   where
-    errmsg (Field alias name _ _) = addErrMsg msg $ (errWrap . pure) val
+    errmsg (Field alias name _ _) = do
-      where
+        addErrMsg $ T.unwords ["field", name, "not resolved."]
-        val = HashMap.singleton aliasOrName Aeson.Null
+        return $ HashMap.singleton aliasOrName Aeson.Null
-        msg = T.unwords ["field", name, "not resolved."]
+          where
-        aliasOrName = fromMaybe name alias
+            aliasOrName = fromMaybe name alias

graphql.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.1.
+-- This file has been generated from package.yaml by hpack version 0.31.2.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 06d3fa29e37864ef5e4254215c50d95942b4a33b0ea4f4d4c930a071fdcd2872
+-- hash: aba9e6c1a0e250a7d0dbabbbdae5dceb119343f6acf06744da66677a487fcca6
 
 name:           graphql
 version:        0.3
@@ -57,6 +57,7 @@ library
     , megaparsec
     , scientific
     , text
+    , transformers
     , unordered-containers
   default-language: Haskell2010
 
@@ -81,5 +82,6 @@ test-suite tasty
     , tasty
     , tasty-hunit
     , text
+    , transformers
     , unordered-containers
   default-language: Haskell2010

package.yaml

@@ -30,6 +30,7 @@ dependencies:
 - base >= 4.7 && < 5
 - megaparsec
 - text
+- transformers
 - unordered-containers
 
 library:

tests/Test/StarWars/Schema.hs

@@ -2,10 +2,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Test.StarWars.Schema where
 
-import Control.Applicative (Alternative, empty)
+import Control.Applicative (Alternative(..))
+import Control.Monad (MonadPlus)
 import Data.List.NonEmpty (NonEmpty((:|)))
 
-import Data.GraphQL.Schema (Schema, Resolver, Argument(..), Value(..))
+import Data.GraphQL.Schema ( Schema
+                           , Resolver
+                           , Argument(..)
+                           , Value(..)
+                           )
 import qualified Data.GraphQL.Schema as Schema
 
 import Test.StarWars.Data
@@ -13,10 +18,10 @@ import Test.StarWars.Data
 -- * Schema
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
 
-schema :: Alternative f => Schema f
+schema :: MonadPlus m => Schema m
 schema = hero :| [human, droid]
 
-hero :: Alternative f => Resolver f
+hero :: MonadPlus m => Resolver m
 hero = Schema.objectA "hero" $ \case
   [] -> character artoo
   [Argument "episode" (ValueInt n)]   -> character . getHero $ fromIntegral n
@@ -25,17 +30,17 @@ hero = Schema.objectA "hero" $ \case
   [Argument "episode" (ValueEnum "JEDI"   )] -> character $ getHero 6
   _ -> empty
 
-human :: Alternative f => Resolver f
+human :: MonadPlus m => Resolver m
 human = Schema.objectA "human" $ \case
   [Argument "id" (ValueString i)] -> character =<< getHuman i
   _ -> empty
 
-droid :: Alternative f => Resolver f
+droid :: MonadPlus m => Resolver m
 droid = Schema.objectA "droid" $ \case
    [Argument "id" (ValueString i)] -> character =<< getDroid i
    _ -> empty
 
-character :: Alternative f => Character -> [Resolver f]
+character :: MonadPlus m => Character -> [Resolver m]
 character char =
   [ Schema.scalar "id"              $ id_ char
   , Schema.scalar "name"            $ name char