Commit cb441238 authored by gmainland's avatar gmainland

Allow splices to add additional top-level declarations.

parent 91456299
......@@ -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) }
......
......@@ -491,6 +491,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
......
......@@ -90,6 +90,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
......@@ -97,6 +101,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,
......
......@@ -290,6 +290,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
......
......@@ -1051,6 +1051,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}
......
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