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

[Geoffrey Mainland]

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

On branch  : th-new-7.6

https://github.com/ghc/ghc/commit/b926c85ac44c4779fdcd0877b207854f9d0ce28f

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

commit b926c85ac44c4779fdcd0877b207854f9d0ce28f
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    | 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 d65d6c3..4a206d8 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 cb40aaa..3ceebab 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 b047e0a..a4be867 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 041df84..7807f58 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 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)