[commit: ghc] th-new: Allow splices to add additional top-level declarations. (f59519a)

[Geoffrey Mainland]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : th-new

https://github.com/ghc/ghc/commit/f59519af50cb2495244a3ce5e51c1d6913fbfaef

>---------------------------------------------------------------

commit f59519af50cb2495244a3ce5e51c1d6913fbfaef
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 6e750cb..8ddb03e 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 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}