From 67bebf853ca5a248358ea1854124a46b70c677cd Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
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