Replace Alternative with MonadPlus

This commit is contained in:
Eugen Wissner 2019-06-28 11:12:28 +02:00
parent ae4038eb47
commit 79c734fa62
7 changed files with 115 additions and 100 deletions

View File

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

View File

@ -1,57 +1,57 @@
{-# LANGUAGE OverloadedStrings #-} {-# 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 ) where
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.Text (Text, pack) 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. -- | Wraps a parse error into a list of errors.
parseError :: Applicative f => String -> f Aeson.Value parseError :: Applicative f => String -> f Aeson.Value
parseError s = parseError s =
pure $ Aeson.object [("errors", Aeson.toJSON [makeErrorMsg $ pack 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. -- | 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 :: 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. -- | 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 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

View File

@ -3,7 +3,7 @@
-- according to a 'Schema'. -- according to a 'Schema'.
module Data.GraphQL.Execute (execute) where module Data.GraphQL.Execute (execute) where
import Control.Applicative (Alternative, empty) import Control.Monad (MonadPlus(..))
import Data.GraphQL.Error import Data.GraphQL.Error
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty((:|))) 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 -- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
-- errors wrapped in an /errors/ field. -- errors wrapped in an /errors/ field.
execute 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 schema (op :| []) = operation schema op
document _ _ = error "Multiple operations not supported yet" 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) operation schema (AST.Core.Query flds)
= runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds)) = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
operation schema (AST.Core.Mutation flds) operation schema (AST.Core.Mutation flds)

View File

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

View File

@ -1,10 +1,10 @@
cabal-version: 1.12 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 -- see: https://github.com/sol/hpack
-- --
-- hash: 06d3fa29e37864ef5e4254215c50d95942b4a33b0ea4f4d4c930a071fdcd2872 -- hash: aba9e6c1a0e250a7d0dbabbbdae5dceb119343f6acf06744da66677a487fcca6
name: graphql name: graphql
version: 0.3 version: 0.3
@ -57,6 +57,7 @@ library
, megaparsec , megaparsec
, scientific , scientific
, text , text
, transformers
, unordered-containers , unordered-containers
default-language: Haskell2010 default-language: Haskell2010
@ -81,5 +82,6 @@ test-suite tasty
, tasty , tasty
, tasty-hunit , tasty-hunit
, text , text
, transformers
, unordered-containers , unordered-containers
default-language: Haskell2010 default-language: Haskell2010

View File

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

View File

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