Make TcRnMonad independent of TcSplice (#14391)

Test Plan: validate

Reviewers: simonpj, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, carter

GHC Trac Issues: #14391

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

4 files changed, 20 insertions, 15 deletions

diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 19bf763f63..c26d03a645 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -51,7 +51,6 @@ import {-# SOURCE #-} TcSplice
     , runMetaE
     , runMetaP
     , runMetaT
-    , runRemoteModFinalizers
     , tcTopSpliceExpr
     )
 
@@ -638,9 +637,16 @@ rnTopSpliceDecls splice
                                rnSplice splice
            -- As always, be sure to checkNoErrs above lest we end up with
            -- holes making it to typechecking, hence #12584.
+           --
+           -- Note that we cannot call checkNoErrs for the whole duration
+           -- of rnTopSpliceDecls. The reason is that checkNoErrs changes
+           -- the local environment to temporarily contain a new
+           -- reference to store errors, and add_mod_finalizers would
+           -- cause this reference to be stored after checkNoErrs finishes.
+           -- This is checked by test TH_finalizer.
          ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty
-         ; (decls, mod_finalizers) <-
-              runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
+         ; (decls, mod_finalizers) <- checkNoErrs $
+               runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
          ; add_mod_finalizers_now mod_finalizers
          ; return (decls,fvs) }
    where
@@ -658,8 +664,9 @@ rnTopSpliceDecls splice
      add_mod_finalizers_now []             = return ()
      add_mod_finalizers_now mod_finalizers = do
        th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+       env <- getLclEnv
        updTcRef th_modfinalizers_var $ \fins ->
-         runRemoteModFinalizers (ThModFinalizers mod_finalizers) : fins
+         (env, ThModFinalizers mod_finalizers) : fins
 
 
 {-
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 74319c0229..e53314dedc 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -47,7 +47,7 @@ module TcRnDriver (
 
 import GhcPrelude
 
-import {-# SOURCE #-} TcSplice ( finishTH )
+import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers )
 import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
 import IfaceEnv( externaliseName )
 import TcHsType
@@ -470,8 +470,10 @@ run_th_modfinalizers = do
   then getEnvs
   else do
     writeTcRef th_modfinalizers_var []
-    (_, lie_th) <- captureTopConstraints $
-                   sequence_ th_modfinalizers
+    let run_finalizer (lcl_env, f) =
+            setLclEnv lcl_env (runRemoteModFinalizers f)
+
+    (_, lie_th) <- captureTopConstraints $ mapM_ run_finalizer th_modfinalizers
       -- Finalizers can add top-level declarations with addTopDecls, so
       -- we have to run tc_rn_src_decls to get them
     (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
@@ -550,8 +552,7 @@ tc_rn_src_decls ds
             do { recordTopLevelSpliceLoc loc
 
                  -- Rename the splice expression, and get its supporting decls
-               ; (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls
-                                                             splice)
+               ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice
 
                  -- Glue them on the front of the remaining decls and loop
                ; (tcg_env, tcl_env, lie2) <-
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 12b88dd30b..b93652fb3c 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -183,7 +183,6 @@ import Control.Monad
 import Data.Set ( Set )
 import qualified Data.Set as Set
 
-import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers )
 import {-# SOURCE #-} TcEnv    ( tcInitTidyEnv )
 
 import qualified Data.Map as Map
@@ -1715,8 +1714,7 @@ addModFinalizersWithLclEnv mod_finalizers
   = do lcl_env <- getLclEnv
        th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
        updTcRef th_modfinalizers_var $ \fins ->
-         setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)
-         : fins
+         (lcl_env, mod_finalizers) : fins
 
 {-
 ************************************************************************
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 322e4e0bba..695d2aea8a 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -633,11 +633,10 @@ data TcGblEnv
         tcg_th_topnames :: TcRef NameSet,
         -- ^ Exact names bound in top-level declarations in tcg_th_topdecls
 
-        tcg_th_modfinalizers :: TcRef [TcM ()],
+        tcg_th_modfinalizers :: TcRef [(TcLclEnv, ThModFinalizers)],
         -- ^ Template Haskell module finalizers.
         --
-        -- They are computations in the @TcM@ monad rather than @Q@ because we
-        -- set them to use particular local environments.
+        -- They can use particular local environments.
 
         tcg_th_coreplugins :: TcRef [String],
         -- ^ Core plugins added by Template Haskell code.