[commit: ghc] th-new-7.6: Allow splices to add additional top-level declarations. (97a0e63)
Geoffrey Mainland
gmainlan at microsoft.com
Thu Jun 27 11:41:16 CEST 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch : th-new-7.6
https://github.com/ghc/ghc/commit/97a0e633ea39f84fbfc0712075cddade96583b7c
>---------------------------------------------------------------
commit 97a0e633ea39f84fbfc0712075cddade96583b7c
Author: Geoffrey Mainland <mainland at apeiron.net>
Date: Tue May 21 13:38:15 2013 +0100
Allow splices to add additional top-level declarations.
>---------------------------------------------------------------
compiler/rename/RnEnv.lhs | 15 ++++++++++++---
compiler/typecheck/TcRnDriver.lhs | 32 ++++++++++++++++++++++++++++++++
compiler/typecheck/TcRnMonad.lhs | 9 +++++++++
compiler/typecheck/TcRnTypes.lhs | 8 ++++++++
compiler/typecheck/TcSplice.lhs | 31 +++++++++++++++++++++++++++++++
5 files changed, 92 insertions(+), 3 deletions(-)
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index bf32dba..b34ba9f 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -256,9 +256,18 @@ lookupExactOcc name
; case gres of
[] -> -- See Note [Splicing Exact names]
do { lcl_env <- getLocalRdrEnv
- ; unless (name `inLocalRdrEnvScope` lcl_env)
- (addErr exact_nm_err)
- ; return name }
+ ; unless (name `inLocalRdrEnvScope` lcl_env) $
+#ifdef GHCI
+ do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
+ ; th_topnames <- readTcRef th_topnames_var
+ ; unless (name `elemNameSet` th_topnames)
+ (addErr exact_nm_err)
+ }
+#else /* !GHCI */
+ addErr exact_nm_err
+#endif /* !GHCI */
+ ; return name
+ }
[gre] -> return (gre_name gre)
_ -> pprPanic "lookupExactOcc" (ppr name $$ ppr gres) }
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index f9c093d..d65d6c3 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -482,6 +482,38 @@ tc_rn_src_decls boot_details ds
; (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group
-- rnTopSrcDecls fails if there are any errors
+#ifdef GHCI
+ -- Get TH-generated top-level declarations and make sure they don't
+ -- contain any splices since we don't handle that at the moment
+ ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
+ ; th_ds <- readTcRef th_topdecls_var
+ ; writeTcRef th_topdecls_var []
+
+ ; (tcg_env, rn_decls) <-
+ if null th_ds
+ then return (tcg_env, rn_decls)
+ else do { (th_group, th_group_tail) <- findSplice th_ds
+ ; case th_group_tail of
+ { Nothing -> return () ;
+ ; Just (SpliceDecl (L loc _) _, _)
+ -> setSrcSpan loc $
+ addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls"))
+ } ;
+
+ -- Rename TH-generated top-level declarations
+ ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $
+ rnTopSrcDecls extra_deps th_group
+
+ -- Dump generated top-level declarations
+ ; loc <- getSrcSpanM
+ ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing top-level declarations added with addTopDecls ",
+ nest 2 (nest 2 (ppr th_rn_decls))])
+
+ ; return (tcg_env, appendGroups rn_decls th_rn_decls)
+ }
+#endif /* GHCI */
+
+ -- Type check all declarations
; (tcg_env, tcl_env) <- setGblEnv tcg_env $
tcTopSrcDecls boot_details rn_decls
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 1b60061..cb40aaa 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -91,6 +91,10 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
Nothing -> newIORef emptyNameEnv } ;
dependent_files_var <- newIORef [] ;
+#ifdef GHCI
+ th_topdecls_var <- newIORef [] ;
+ th_topnames_var <- newIORef emptyNameSet ;
+#endif /* GHCI */
let {
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax empty_val
@@ -98,6 +102,11 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
| otherwise = Nothing ;
gbl_env = TcGblEnv {
+#ifdef GHCI
+ tcg_th_topdecls = th_topdecls_var,
+ tcg_th_topnames = th_topnames_var,
+#endif /* GHCI */
+
tcg_mod = mod,
tcg_src = hsc_src,
tcg_rdr_env = emptyGlobalRdrEnv,
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 9df3e48..b047e0a 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -297,6 +297,14 @@ data TcGblEnv
tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile
+#ifdef GHCI
+ tcg_th_topdecls :: TcRef [LHsDecl RdrName],
+ -- ^ Top-level declarations from addTopDecls
+
+ tcg_th_topnames :: TcRef NameSet,
+ -- ^ Exact names bound in top-level declarations in tcg_th_topdecls
+#endif /* GHCI */
+
tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings
tcg_binds :: LHsBinds Id, -- Value bindings in this module
tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 589fdd1..a7abfbb 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1046,6 +1046,37 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
ref <- fmap tcg_dependent_files getGblEnv
dep_files <- readTcRef ref
writeTcRef ref (fp:dep_files)
+
+ qAddTopDecls thds = do
+ l <- getSrcSpanM
+ let either_hval = convertToHsDecls l thds
+ ds <- case either_hval of
+ Left exn -> pprPanic "qAddTopDecls: can't convert top-level declarations" exn
+ Right ds -> return ds
+ mapM_ (checkTopDecl . unLoc) ds
+ th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
+ updTcRef th_topdecls_var (\topds -> ds ++ topds)
+ where
+ checkTopDecl :: HsDecl RdrName -> TcM ()
+ checkTopDecl (ValD binds)
+ = mapM_ bindName (collectHsBindBinders binds)
+ checkTopDecl (SigD _)
+ = return ()
+ checkTopDecl (ForD (ForeignImport (L _ name) _ _ _))
+ = bindName name
+ checkTopDecl _
+ = addErr $ text "Only function, value, and foreign import declarations may be added with addTopDecl"
+
+ bindName :: RdrName -> TcM ()
+ bindName (Exact n)
+ = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
+ ; updTcRef th_topnames_var (\ns -> addOneToNameSet ns n)
+ }
+
+ bindName name =
+ 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.")
\end{code}
More information about the ghc-commits
mailing list