[commit: ghc] th-new: Add support for Template Haskell module finalizers. (418a334)

[Geoffrey Mainland]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : th-new

https://github.com/ghc/ghc/commit/418a3340029676228698766db28a686aed15048c

>---------------------------------------------------------------

commit 418a3340029676228698766db28a686aed15048c
Author: Geoffrey Mainland <mainland at apeiron.net>
Date:   Tue Jun 4 14:15:00 2013 +0100

    Add support for Template Haskell module finalizers.
    
    Template Haskell module finalizers are run after a module is type checked.

>---------------------------------------------------------------

 compiler/typecheck/TcRnDriver.lhs    |  9 ++++++++-
 compiler/typecheck/TcRnMonad.lhs     | 10 ++++++----
 compiler/typecheck/TcRnTypes.lhs     |  7 +++++++
 compiler/typecheck/TcSplice.lhs      | 12 +++++++++++-
 compiler/typecheck/TcSplice.lhs-boot |  1 +
 5 files changed, 33 insertions(+), 6 deletions(-)

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 53828f9..2e6c010 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,13 @@ tc_rn_src_decls boot_details ds
           { 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 6a58a4f..97c7e73 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -91,8 +91,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 ;
@@ -102,8 +103,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 fc62e93..46ded17 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -114,6 +114,10 @@ import ListSetOps
 import FastString
 
 import Data.Set (Set)
+
+#ifdef GHCI
+import qualified Language.Haskell.TH as TH
+#endif
 \end{code}
 
 
@@ -296,6 +300,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 5f0643d..a2359bc 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -14,7 +14,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"
 
@@ -833,6 +833,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)
@@ -1080,6 +1086,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 d33641f..9bacd1f 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)