[commit: ghc] wip/th-new: Add support for Template Haskell module finalizers. (2d1b4a7)

[git at git.haskell.org]

Repository : ssh://git at git.haskell.org/ghc

On branch  : wip/th-new
Link       : http://ghc.haskell.org/trac/ghc/changeset/2d1b4a71fc6d4cb69744fe056a62013f68673dbd/ghc

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

commit 2d1b4a71fc6d4cb69744fe056a62013f68673dbd
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.


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

2d1b4a71fc6d4cb69744fe056a62013f68673dbd
 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 482885d..314d50f 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
 
@@ -532,6 +532,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 97c6fb1..a628510 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 5889f74..357bb11 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 d64b456..b91cbf6 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"
 
@@ -836,6 +836,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)
@@ -1084,6 +1090,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)