From 646b6301f24a66a50b24828dfe8137fc3975c019 Mon Sep 17 00:00:00 2001
From: Geoffrey Mainland <mainland@apeiron.net>
Date: Tue, 4 Jun 2013 14:15:00 +0100
Subject: [PATCH] Add support for Template Haskell module finalizers.

Template Haskell module finalizers are run after a module is type checked.
---
 compiler/typecheck/TcRnDriver.lhs    | 11 ++++++++++-
 compiler/typecheck/TcRnMonad.lhs     | 10 ++++++----
 compiler/typecheck/TcRnTypes.lhs     |  6 ++++++
 compiler/typecheck/TcSplice.lhs      | 12 +++++++++++-
 compiler/typecheck/TcSplice.lhs-boot |  1 +
 5 files changed, 34 insertions(+), 6 deletions(-)

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index d65d6c34e3f8..4a206d839ed4 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -22,7 +22,7 @@ module TcRnDriver (
     ) where
 
 #ifdef GHCI
-import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
+import {-# SOURCE #-} TcSplice ( tcSpliceDecls, runQuasi )
 import RnSplice ( rnSplice )
 #endif
 
@@ -521,6 +521,15 @@ tc_rn_src_decls boot_details ds
       ; setEnvs (tcg_env, tcl_env) $
         case group_tail of
           { Nothing -> do { tcg_env <- checkMain       -- Check for `main'
+                          ; traceTc "returning from tc_rn_src_decls: " $
+                            ppr $ nameEnvElts $ tcg_type_env tcg_env -- RAE
+#ifdef GHCI
+                            -- Run all module finalizers
+                          ; th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+                          ; modfinalizers <- readTcRef th_modfinalizers_var
+                          ; writeTcRef th_modfinalizers_var []
+                          ; mapM_ runQuasi modfinalizers
+#endif /* GHCI */
                           ; return (tcg_env, tcl_env)
                           }
 
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index cb40aaa14a31..3ceebab733ed 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -92,8 +92,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 
         dependent_files_var <- newIORef [] ;
 #ifdef GHCI
-        th_topdecls_var     <- newIORef [] ;
-        th_topnames_var     <- newIORef emptyNameSet ;
+        th_topdecls_var      <- newIORef [] ;
+        th_topnames_var      <- newIORef emptyNameSet ;
+        th_modfinalizers_var <- newIORef [] ;
 #endif /* GHCI */
         let {
              maybe_rn_syntax :: forall a. a -> Maybe a ;
@@ -103,8 +104,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 
              gbl_env = TcGblEnv {
 #ifdef GHCI
-                tcg_th_topdecls    = th_topdecls_var,
-                tcg_th_topnames    = th_topnames_var,
+                tcg_th_topdecls      = th_topdecls_var,
+                tcg_th_topnames      = th_topnames_var,
+                tcg_th_modfinalizers = th_modfinalizers_var,
 #endif /* GHCI */
 
                 tcg_mod            = mod,
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index b047e0a282e3..a4be867dc571 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -117,6 +117,9 @@ import Util
 
 import Data.Set (Set)
 
+#ifdef GHCI
+import qualified Language.Haskell.TH as TH
+#endif
 \end{code}
 
 
@@ -303,6 +306,9 @@ data TcGblEnv
 
         tcg_th_topnames :: TcRef NameSet,
         -- ^ Exact names bound in top-level declarations in tcg_th_topdecls
+
+        tcg_th_modfinalizers :: TcRef [TH.Q ()],
+        -- ^ Template Haskell module finalizers
 #endif /* GHCI */
 
         tcg_ev_binds  :: Bag EvBind,        -- Top-level evidence bindings
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 041df8413a60..7807f58af725 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -13,7 +13,7 @@ module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
                  runQuasiQuoteExpr, runQuasiQuotePat,
                  runQuasiQuoteDecl, runQuasiQuoteType,
                  runAnnotation,
-                 runMetaE, runMetaP, runMetaT, runMetaD ) where
+                 runQuasi, runMetaE, runMetaP, runMetaT, runMetaD ) where
 
 #include "HsVersions.h"
 
@@ -832,6 +832,12 @@ deprecatedDollar quoter
 %*                                                                      *
 %************************************************************************
 
+
+\begin{code}
+runQuasi :: TH.Q a -> TcM a
+runQuasi act = TH.runQ act
+\end{code}
+
 \begin{code}
 data MetaOps th_syn hs_syn
   = MT { mt_desc :: String             -- Type of beast (expression, type etc)
@@ -1079,6 +1085,10 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
           addErr $
           hang (ptext (sLit "The binder") <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
              2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
+
+  qAddModFinalizer fin = do
+      th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+      updTcRef th_modfinalizers_var (\fins -> fin:fins)
 \end{code}
 
 
diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot
index d33641ff6889..9bacd1f7076c 100644
--- a/compiler/typecheck/TcSplice.lhs-boot
+++ b/compiler/typecheck/TcSplice.lhs-boot
@@ -35,6 +35,7 @@ runQuasiQuoteType :: HsQuasiQuote RdrName -> TcM (LHsType RdrName)
 runQuasiQuotePat  :: HsQuasiQuote RdrName -> TcM (LPat RdrName)
 runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
 
+runQuasi :: TH.Q a -> TcM a
 runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName)
 runMetaP :: LHsExpr Id -> TcM (LPat RdrName)
 runMetaT :: LHsExpr Id  -> TcM (LHsType RdrName)