Commit 2d1b4a71 authored by gmainland's avatar gmainland
Browse files

Add support for Template Haskell module finalizers.

Template Haskell module finalizers are run after a module is type checked.
parent c6033dcd
......@@ -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)
}
......
......@@ -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,
......
......@@ -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
......
......@@ -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}
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment