Allow splices to add additional top-level declarations.

5 files changed, 92 insertions, 3 deletions

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index bcdd276f1f..a442c87e0a 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 d32cf3fc14..482885d36b 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -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
 
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 11463025a8..97c6fb1bb9 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -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,
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 2484823079..5889f74359 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -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
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 129e560cd8..d5f6655e43 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -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}