From 79c734fa629f6bb200e2d695200c5ec2967c997f Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 28 Jun 2019 11:12:28 +0200 Subject: [PATCH] Replace Alternative with MonadPlus --- Data/GraphQL.hs | 6 +-- Data/GraphQL/Error.hs | 76 ++++++++++++++-------------- Data/GraphQL/Execute.hs | 14 +++--- Data/GraphQL/Schema.hs | 93 ++++++++++++++++++----------------- graphql.cabal | 6 ++- package.yaml | 1 + tests/Test/StarWars/Schema.hs | 19 ++++--- 7 files changed, 115 insertions(+), 100 deletions(-) diff --git a/Data/GraphQL.hs b/Data/GraphQL.hs index c332b6c..47ca2b0 100644 --- a/Data/GraphQL.hs +++ b/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 "" diff --git a/Data/GraphQL/Error.hs b/Data/GraphQL/Error.hs index b19047b..08d1622 100644 --- a/Data/GraphQL/Error.hs +++ b/Data/GraphQL/Error.hs @@ -1,57 +1,57 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -module Data.GraphQL.Error ( - parseError, - CollectErrsT, - addErr, - addErrMsg, - runCollectErrs, - joinErrs, - errWrap +module Data.GraphQL.Error + ( parseError + , CollectErrsT + , addErr + , addErrMsg + , runCollectErrs + , runAppendErrs ) where import qualified Data.Aeson as Aeson import Data.Text (Text, pack) - -import Control.Arrow ((&&&)) +import Control.Monad.Trans.Class (lift) +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. -type CollectErrsT f a = f (a,[Aeson.Value]) - --- | 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 (, []) +-- | A wrapper to pass error messages around. +type CollectErrsT m = StateT [Aeson.Value] m -- | Adds an error to the list of errors. -addErr :: Functor f => Aeson.Value -> CollectErrsT f a -> CollectErrsT f a -addErr v = (fmap . fmap) (v :) +addErr :: Monad m => Aeson.Value -> CollectErrsT m () +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 --- list which is then sent back with the data. -runCollectErrs :: Functor f => CollectErrsT f Aeson.Value -> f Aeson.Value -runCollectErrs = fmap finalD - where - finalD (dat,errs) = - Aeson.object - $ if null errs - then [("data",dat)] - else [("data",dat),("errors",Aeson.toJSON $ reverse errs)] +-- | Appends the given list of errors to the current list of errors. +appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m () +appendErrs errs = modify (errs ++) + +-- | Runs the given query computation, but collects the errors into an error +-- list, which is then sent back with the data. +runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value +runCollectErrs res = do + (dat, errs) <- runStateT res [] + 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 diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index b227ce2..e6bb1c9 100644 --- a/Data/GraphQL/Execute.hs +++ b/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) - => Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value -execute schema subs doc = document schema =<< maybe empty pure (Transform.document subs doc) + :: (MonadPlus m) + => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value +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) diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index a63750d..4c31456 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -25,13 +25,17 @@ module Data.GraphQL.Schema , Value(..) ) where -import Control.Applicative (Alternative(empty), (<|>)) -import Data.Bifunctor (first) +import Control.Applicative (Alternative(..)) +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 - => Name -> (Arguments -> Resolvers f) -> Resolver f + :: MonadPlus m + => 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) - => T.Text -> ([Argument] -> f [Resolver f]) -> Resolver f + :: MonadPlus m + => 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) - => Name -> (Arguments -> f a) -> Resolver f -scalarA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld + :: (MonadPlus m, Aeson.ToJSON a) + => Name -> (Arguments -> m a) -> Resolver m +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 - => T.Text -> (Arguments -> [Resolvers f]) -> Resolver f + :: MonadPlus m + => 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) - => T.Text -> ([Argument] -> f [[Resolver f]]) -> Resolver f + :: MonadPlus m + => Name -> (Arguments -> m [Resolvers m]) -> Resolver m arrayA' name f fld@(Field _ _ args sels) = do - resolvs <- f args - withField name (joinErrs $ traverse (`resolve` sels) resolvs) fld + resolvs <- lift $ f args + 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 name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld +enumA :: MonadPlus m => Name -> (Arguments -> m [T.Text]) -> Resolver m +enumA name f fld@(Field _ _ args []) = withField name (lift $ f args) fld enumA _ _ _ = empty -- | Helper function to facilitate 'Argument' handling. -withField - :: (Alternative f, Aeson.ToJSON a) - => Name -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap T.Text Aeson.Value) +withField :: (MonadPlus m, Aeson.ToJSON a) + => Name -> CollectErrsT m a -> Field -> CollectErrsT m (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 - where - val = HashMap.singleton aliasOrName Aeson.Null - msg = T.unwords ["field", name, "not resolved."] - aliasOrName = fromMaybe name alias + errmsg (Field alias name _ _) = do + addErrMsg $ T.unwords ["field", name, "not resolved."] + return $ HashMap.singleton aliasOrName Aeson.Null + where + aliasOrName = fromMaybe name alias diff --git a/graphql.cabal b/graphql.cabal index 66c4720..49fdfeb 100644 --- a/graphql.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index 54e8c0a..2ad4c94 100644 --- a/package.yaml +++ b/package.yaml @@ -30,6 +30,7 @@ dependencies: - base >= 4.7 && < 5 - megaparsec - text +- transformers - unordered-containers library: diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 4d2fbf9..09344fc 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/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