[commit: ghc] th-new: Allow splices to add additional top-level declarations. (1211967)
Geoffrey Mainland
gmainlan at microsoft.com
Wed May 22 11:03:11 CEST 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch : th-new
https://github.com/ghc/ghc/commit/1211967f453a2945e340b960b9759c7ebc1caa21
>---------------------------------------------------------------
commit 1211967f453a2945e340b960b9759c7ebc1caa21
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 | 11 ++++++++---
compiler/typecheck/TcRnDriver.lhs | 32 +++++++++++++++++++++++++++++++-
compiler/typecheck/TcRnMonad.lhs | 6 +++++-
compiler/typecheck/TcRnTypes.lhs | 7 +++++++
compiler/typecheck/TcSplice.lhs | 31 +++++++++++++++++++++++++++++++
5 files changed, 82 insertions(+), 5 deletions(-)
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 41dfb80..46d7b44 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -251,9 +251,14 @@ 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) $
+ do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
+ ; th_topnames <- readTcRef th_topnames_var
+ ; unless (name `elemNameSet` th_topnames)
+ (addErr exact_nm_err)
+ }
+ ; 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 9b74550..a9f64e8 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -480,8 +480,38 @@ tc_rn_src_decls boot_details ds
; (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group
-- rnTopSrcDecls fails if there are any errors
+ -- 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_all_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)
+ }
+
+ -- Type check all declarations
; (tcg_env, tcl_env) <- setGblEnv tcg_env $
- tcTopSrcDecls boot_details rn_decls
+ tcTopSrcDecls boot_details rn_all_decls
-- If there is no splice, we're nearly done
; setEnvs (tcg_env, tcl_env) $
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index cd164b9..4b8e22d 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -90,6 +90,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
Nothing -> newIORef emptyNameEnv } ;
dependent_files_var <- newIORef [] ;
+ th_topdecls_var <- newIORef [] ;
+ th_topnames_var <- newIORef emptyNameSet ;
let {
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax empty_val
@@ -136,7 +138,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcg_hpc = False,
tcg_main = Nothing,
tcg_safeInfer = infer_var,
- tcg_dependent_files = dependent_files_var
+ tcg_dependent_files = dependent_files_var,
+ tcg_th_topdecls = th_topdecls_var,
+ tcg_th_topnames = th_topnames_var
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index df5dfff..d095e6a 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -290,6 +290,13 @@ data TcGblEnv
tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile
+
+ 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
+
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 3a3b289..24ead6f 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1047,6 +1047,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