From 67bebf853ca5a248358ea1854124a46b70c677cd Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sat, 1 Feb 2020 20:46:35 +0100 Subject: [PATCH] Replace MonadIO constraint with just Monad And make the tests use Identity instead of IO. --- CHANGELOG.md | 2 ++ src/Language/GraphQL.hs | 5 ++--- src/Language/GraphQL/Execute.hs | 9 ++++----- src/Language/GraphQL/Schema.hs | 19 +++++++++---------- src/Language/GraphQL/Trans.hs | 2 +- tests/Test/StarWars/Data.hs | 12 +++--------- tests/Test/StarWars/QuerySpec.hs | 6 ++++-- tests/Test/StarWars/Schema.hs | 14 +++++++------- 8 files changed, 32 insertions(+), 37 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 87c6423..52b95ad 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,6 +23,8 @@ and this project adheres to `key -> Maybe value` before). - Make `AST.Lexer.at` a text (symbol) parser. It was a char before and is `symbol "@"` now. +- Replace `MonadIO` with a plain `Monad`. Since the tests don't use IO, + set the inner monad to `Identity`. ### Removed - `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`. diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 952f8ac..57c8bf1 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -4,7 +4,6 @@ module Language.GraphQL , graphqlSubs ) where -import Control.Monad.IO.Class (MonadIO) import qualified Data.Aeson as Aeson import Data.List.NonEmpty (NonEmpty) import qualified Data.Text as T @@ -16,7 +15,7 @@ import Text.Megaparsec (parse) -- | If the text parses correctly as a @GraphQL@ query the query is -- executed using the given 'Schema.Resolver's. -graphql :: MonadIO m +graphql :: Monad m => NonEmpty (Schema.Resolver m) -- ^ Resolvers. -> T.Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. @@ -25,7 +24,7 @@ graphql = flip graphqlSubs mempty -- | If the text parses correctly as a @GraphQL@ query the substitution is -- applied to the query and the query is then executed using to the given -- 'Schema.Resolver's. -graphqlSubs :: MonadIO m +graphqlSubs :: Monad m => NonEmpty (Schema.Resolver m) -- ^ Resolvers. -> Schema.Subs -- ^ Variable substitution function. -> T.Text -- ^ Text representing a @GraphQL@ request document. diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 5278606..de937ee 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -6,7 +6,6 @@ module Language.GraphQL.Execute , executeWithName ) where -import Control.Monad.IO.Class (MonadIO) import qualified Data.Aeson as Aeson import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty(..)) @@ -24,7 +23,7 @@ import qualified Language.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 :: MonadIO m +execute :: Monad m => NonEmpty (Schema.Resolver m) -- ^ Resolvers. -> Schema.Subs -- ^ Variable substitution function. -> Document -- @GraphQL@ document. @@ -40,7 +39,7 @@ execute schema subs doc = -- -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. -executeWithName :: MonadIO m +executeWithName :: Monad m => NonEmpty (Schema.Resolver m) -- ^ Resolvers -> Text -- ^ Operation name. -> Schema.Subs -- ^ Variable substitution function. @@ -51,7 +50,7 @@ executeWithName schema name subs doc = where transformError = return $ singleError "Schema transformation error." -document :: MonadIO m +document :: Monad m => NonEmpty (Schema.Resolver m) -> Maybe Text -> AST.Core.Document @@ -67,7 +66,7 @@ document schema (Just name) operations = case NE.dropWhile matchingName operatio matchingName _ = False document _ _ _ = return $ singleError "Missing operation name." -operation :: MonadIO m +operation :: Monad m => NonEmpty (Schema.Resolver m) -> AST.Core.Operation -> m Aeson.Value diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 661e452..8bde54d 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -15,7 +15,6 @@ module Language.GraphQL.Schema , Value(..) ) where -import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) @@ -33,8 +32,8 @@ import Language.GraphQL.Trans import qualified Language.GraphQL.Type as Type -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error --- information (if an error has occurred). @m@ is usually expected to be an --- instance of 'MonadIO'. +-- information (if an error has occurred). @m@ is an arbitrary monad, usually +-- 'IO'. data Resolver m = Resolver Text -- ^ Name (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver @@ -44,14 +43,14 @@ data Resolver m = Resolver type Subs = HashMap Name Value -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. -object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m +object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m object name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld -- | Like 'object' but can be null or a list of objects. wrappedObject :: - MonadIO m => + Monad m => Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m @@ -61,14 +60,14 @@ wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight = withField (traverse (`resolve` sels) resolver) fld -- | A scalar represents a primitive value, like a string or an integer. -scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m +scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m scalar name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld result = withField (return result) fld -- | Like 'scalar' but can be null or a list of scalars. wrappedScalar :: - (MonadIO m, Aeson.ToJSON a) => + (Monad m, Aeson.ToJSON a) => Name -> ActionT m (Type.Wrapping a) -> Resolver m @@ -80,7 +79,7 @@ wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight resolveRight fld (Type.List result) = withField (return result) fld resolveFieldValue :: - MonadIO m => + Monad m => ActionT m a -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) -> Field -> @@ -95,7 +94,7 @@ resolveFieldValue f resolveRight fld@(Field _ _ args _) = do return $ HashMap.singleton (aliasOrName fld) Aeson.Null -- | Helper function to facilitate error handling and result emitting. -withField :: (MonadIO m, Aeson.ToJSON a) +withField :: (Monad m, Aeson.ToJSON a) => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value) withField v fld = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v @@ -103,7 +102,7 @@ withField v fld -- | 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 :: MonadIO m +resolve :: Monad m => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers where diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs index 24752a2..09c012b 100644 --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -56,7 +56,7 @@ instance Monad m => MonadPlus (ActionT m) where -- | Retrieves an argument by its name. If the argument with this name couldn't -- be found, returns 'Value.Null' (i.e. the argument is assumed to -- be optional then). -argument :: MonadIO m => Name -> ActionT m Value +argument :: Monad m => Name -> ActionT m Value argument argumentName = do argumentValue <- ActionT $ lift $ asks $ lookup . arguments pure $ fromMaybe Null argumentValue diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index 4854f8f..0318d78 100644 --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -8,7 +8,6 @@ module Test.StarWars.Data , getEpisode , getFriends , getHero - , getHeroIO , getHuman , id_ , homePlanet @@ -18,10 +17,8 @@ module Test.StarWars.Data ) where import Data.Monoid (mempty) -import Control.Applicative ( Alternative(..) - , liftA2 - ) -import Control.Monad.IO.Class (MonadIO(..)) +import Data.Functor.Identity (Identity) +import Control.Applicative (Alternative(..), liftA2) import Control.Monad.Trans.Except (throwE) import Data.Maybe (catMaybes) import Data.Text (Text) @@ -71,7 +68,7 @@ appearsIn :: Character -> [Int] appearsIn (Left x) = _appearsIn . _droidChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x -secretBackstory :: MonadIO m => Character -> ActionT m Text +secretBackstory :: Character -> ActionT Identity Text secretBackstory = const $ ActionT $ throwE "secretBackstory is secret." typeName :: Character -> Text @@ -166,9 +163,6 @@ getHero :: Int -> Character getHero 5 = luke getHero _ = artoo -getHeroIO :: Int -> IO Character -getHeroIO = pure . getHero - getHuman :: Alternative f => ID -> f Character getHuman = fmap Right . getHuman' diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs index 4f92801..45fcf42 100644 --- a/tests/Test/StarWars/QuerySpec.hs +++ b/tests/Test/StarWars/QuerySpec.hs @@ -6,6 +6,7 @@ module Test.StarWars.QuerySpec import qualified Data.Aeson as Aeson import Data.Aeson ((.=)) +import Data.Functor.Identity (Identity(..)) import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Language.GraphQL @@ -357,7 +358,8 @@ spec = describe "Star Wars Query Tests" $ do alderaan = "homePlanet" .= ("Alderaan" :: Text) testQuery :: Text -> Aeson.Value -> Expectation -testQuery q expected = graphql schema q >>= flip shouldBe expected +testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation -testQueryParams f q expected = graphqlSubs schema f q >>= flip shouldBe expected +testQueryParams f q expected = + runIdentity (graphqlSubs schema f q) `shouldBe` expected diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index e45d7ff..7986a30 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -7,9 +7,9 @@ module Test.StarWars.Schema , schema ) where -import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Class (lift) +import Data.Functor.Identity (Identity) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes) import qualified Language.GraphQL.Schema as Schema @@ -19,10 +19,10 @@ import Test.StarWars.Data -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -schema :: MonadIO m => NonEmpty (Schema.Resolver m) +schema :: NonEmpty (Schema.Resolver Identity) schema = hero :| [human, droid] -hero :: MonadIO m => Schema.Resolver m +hero :: Schema.Resolver Identity hero = Schema.object "hero" $ do episode <- argument "episode" character $ case episode of @@ -31,7 +31,7 @@ hero = Schema.object "hero" $ do Schema.Enum "JEDI" -> getHero 6 _ -> artoo -human :: MonadIO m => Schema.Resolver m +human :: Schema.Resolver Identity human = Schema.wrappedObject "human" $ do id' <- argument "id" case id' of @@ -42,14 +42,14 @@ human = Schema.wrappedObject "human" $ do Just e -> Type.Named <$> character e _ -> ActionT $ throwE "Invalid arguments." -droid :: MonadIO m => Schema.Resolver m +droid :: Schema.Resolver Identity droid = Schema.object "droid" $ do id' <- argument "id" case id' of - Schema.String i -> character =<< liftIO (getDroid i) + Schema.String i -> character =<< getDroid i _ -> ActionT $ throwE "Invalid arguments." -character :: MonadIO m => Character -> ActionT m [Schema.Resolver m] +character :: Character -> ActionT Identity [Schema.Resolver Identity] character char = return [ Schema.scalar "id" $ return $ id_ char , Schema.scalar "name" $ return $ name char