From f59519af50cb2495244a3ce5e51c1d6913fbfaef Mon Sep 17 00:00:00 2001 From: Geoffrey Mainland Date: Tue, 21 May 2013 13:38:15 +0100 Subject: [PATCH] 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 6e750cb1fdf4..8ddb03e12eaa 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -252,9 +252,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 9b7455002695..a9f64e8a1c84 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 cd164b9ccb6a..4b8e22d62e9f 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 df5dfff88448..d095e6ae19da 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 3a3b2897c6ff..24ead6f9eeb9 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}