Add MonadIO Q - by requiring MonadIO => Quasi

Summary: This is follow-up to https://ghc.haskell.org/trac/ghc/ticket/10773

Reviewers: austin, goldfire, bgamari, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: RyanGlScott, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3816

5 files changed, 18 insertions, 7 deletions

diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 266a4dfe3a..77c97f70df 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -869,7 +869,6 @@ instance TH.Quasi TcM where
         -- the recovery action is chosen.  Otherwise
         -- we'll only fail higher up.
   qRecover recover main = tryTcDiscardingErrs recover main
-  qRunIO io = liftIO io
 
   qAddDependentFile fp = do
     ref <- fmap tcg_dependent_files getGblEnv
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 1b08501580..09fbca7e32 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -97,6 +97,7 @@ import GHC.Serialized
 
 import Control.Exception
 import qualified Control.Monad.Fail as Fail
+import Control.Monad.IO.Class (MonadIO (..))
 import Data.Binary
 import Data.Binary.Put
 import Data.ByteString (ByteString)
@@ -160,6 +161,9 @@ ghcCmd m = GHCiQ $ \s -> do
     THException str -> throwIO (GHCiQException s str)
     THComplete res -> return (res, s)
 
+instance MonadIO GHCiQ where
+  liftIO m = GHCiQ $ \s -> fmap (,s) m
+
 instance TH.Quasi GHCiQ where
   qNewName str = ghcCmd (NewName str)
   qReport isError msg = ghcCmd (Report isError msg)
@@ -190,7 +194,6 @@ instance TH.Quasi GHCiQ where
   qReifyModule m = ghcCmd (ReifyModule m)
   qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
   qLocation = fromMaybe noLoc . qsLocation <$> getState
-  qRunIO m = GHCiQ $ \s -> fmap (,s) m
   qAddDependentFile file = ghcCmd (AddDependentFile file)
   qAddTopDecls decls = ghcCmd (AddTopDecls decls)
   qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 90c728296b..b8e1601456 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -30,6 +30,7 @@ import Data.Data hiding (Fixity(..))
 import Data.IORef
 import System.IO.Unsafe ( unsafePerformIO )
 import Control.Monad (liftM)
+import Control.Monad.IO.Class (MonadIO (..))
 import System.IO        ( hPutStrLn, stderr )
 import Data.Char        ( isAlpha, isAlphaNum, isUpper )
 import Data.Int
@@ -49,7 +50,7 @@ import qualified Control.Monad.Fail as Fail
 --
 -----------------------------------------------------
 
-class Fail.MonadFail m => Quasi m where
+class (MonadIO m, Fail.MonadFail m) => Quasi m where
   qNewName :: String -> m Name
         -- ^ Fresh names
 
@@ -78,6 +79,7 @@ class Fail.MonadFail m => Quasi m where
   qLocation :: m Loc
 
   qRunIO :: IO a -> m a
+  qRunIO = liftIO
   -- ^ Input/output (dangerous)
 
   qAddDependentFile :: FilePath -> m ()
@@ -132,8 +134,6 @@ instance Quasi IO where
   qIsExtEnabled _       = badIO "isExtEnabled"
   qExtsEnabled          = badIO "extsEnabled"
 
-  qRunIO m = m
-
 badIO :: String -> IO a
 badIO op = do   { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
                 ; fail "Template Haskell failure" }
@@ -494,6 +494,9 @@ isExtEnabled ext = Q (qIsExtEnabled ext)
 extsEnabled :: Q [Extension]
 extsEnabled = Q qExtsEnabled
 
+instance MonadIO Q where
+  liftIO = runIO
+
 instance Quasi Q where
   qNewName            = newName
   qReport             = report
@@ -507,7 +510,6 @@ instance Quasi Q where
   qReifyConStrictness = reifyConStrictness
   qLookupName         = lookupName
   qLocation           = location
-  qRunIO              = runIO
   qAddDependentFile   = addDependentFile
   qAddTopDecls        = addTopDecls
   qAddForeignFile     = addForeignFile
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 0e3429caa9..e003f1b47e 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -14,6 +14,11 @@
     with Template Haskell. This is not a part of the public API, and as
     such, there are no API guarantees for this module from version to version.
 
+  * `MonadIO` is now a superclass of `Quasi`, `qRunIO` has a default
+    implementation `qRunIO = liftIO`
+
+  * Add `MonadIO Q` instance
+
 ## 2.12.0.0 *TBA*
 
   * Bundled with GHC *TBA*
diff --git a/testsuite/tests/stranal/should_compile/T9208.hs b/testsuite/tests/stranal/should_compile/T9208.hs
index b8ec6df6d1..5243445c96 100644
--- a/testsuite/tests/stranal/should_compile/T9208.hs
+++ b/testsuite/tests/stranal/should_compile/T9208.hs
@@ -25,6 +25,7 @@ import           Control.Monad
 #if __GLASGOW_HASKELL__ >= 800
 import           Control.Monad.Fail (MonadFail(fail))
 #endif
+import           Control.Monad.IO.Class (MonadIO (..))
 
 import           Data.Binary
 import           Data.Binary.Get
@@ -81,7 +82,8 @@ instance MonadFail GHCJSQ where
   fail = undefined
 #endif
 
-instance TH.Quasi GHCJSQ where qRunIO m = GHCJSQ $ \s -> fmap (,s) m
+instance MonadIO GHCJSQ where liftIO m = GHCJSQ $ \s -> fmap (,s) m
+instance TH.Quasi GHCJSQ
 
 -- | the Template Haskell server
 runTHServer :: IO ()