From: simonpj@microsoft.com <unknown>
Date: Wed, 23 May 2007 11:42:53 +0000 (+0000)
Subject: In GHCi, bind identifiers at TH level 'impLevel'
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=800dba35d6ad4dde3d54a293687307f160a05dea

In GHCi, bind identifiers at TH level 'impLevel'

Consder Trac #1265, which does this in GHCi:

	Prelude> let doit = fail "Code not written yet" :: ExpQ
	Prelude> $(doit)

Even though 'doit' is defined "in the same module", it's OK to use it in a splice
because it'll have been fully compiled to bytecode.  (Contrast the situation if
these two lines appeared in a single, compiled module.)

Hence we want to bind 'doit' at TH's "imported level" (TcRnTypes.impLevel).
This used to happen because GHCi-bound Ids were in the *global* type
env (and hence at "imported level").  But since SimonM moved
GHCi-bound ids to the *local* type env (for good reasons) the above
program has been rejected.

This patch makes it work again.
---

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 0f9bf23..28a8758 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -22,6 +22,7 @@ module TcEnv(
 	-- Local environment
 	tcExtendKindEnv, tcExtendKindEnvTvs,
 	tcExtendTyVarEnv, tcExtendTyVarEnv2, 
+	tcExtendGhciEnv,
 	tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
 	tcLookup, tcLookupLocated, tcLookupLocalIds, 
 	tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
@@ -334,12 +335,6 @@ getScopedTyVarBinds
 
 \begin{code}
 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
--- Invariant: the TcIds are fully zonked. Reasons:
---	(a) The kinds of the forall'd type variables are defaulted
---	    (see Kind.defaultKind, done in zonkQuantifiedTyVar)
---	(b) There are no via-Indirect occurrences of the bound variables
---	    in the types, because instantiation does not look through such things
---	(c) The call to tyVarsOfTypes is ok without looking through refs
 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
 
 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
@@ -348,25 +343,47 @@ tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
 tcExtendIdEnv2 names_w_ids thing_inside
-  = getLclEnv		`thenM` \ env ->
-    let
-	extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
-	th_lvl		    = thLevel (tcl_th_ctxt   env)
-	extra_env	    = [ (name, ATcId { tct_id = id, 
-					       tct_level = th_lvl,
-					       tct_type = id_ty, 
-					       tct_co = if isRefineableTy id_ty 
-							then Just idHsWrapper
-							else Nothing })
-			      | (name,id) <- names_w_ids, let id_ty = idType id]
-	le'		    = extendNameEnvList (tcl_env env) extra_env
-	rdr_env'	    = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
-    in
-    traceTc (text "env2") `thenM_`
-    traceTc (text "env3" <+> ppr extra_env) `thenM_`
-    tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars	`thenM` \ gtvs' ->
-    (traceTc (text "env4") `thenM_`
-    setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
+  = do	{ env <- getLclEnv
+	; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside }
+
+tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
+-- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
+-- Note especially that we bind them at TH level 'impLevel'.  That's because it's
+-- OK to use a variable bound earlier in the interaction in a splice, becuase
+-- GHCi has already compiled it to bytecode
+tcExtendGhciEnv ids thing_inside
+  = do	{ env <- getLclEnv
+	; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside }
+
+tc_extend_local_id_env		-- This is the guy who does the work
+	:: TcLclEnv
+	-> ThLevel
+	-> [(Name,TcId)]
+	-> TcM a -> TcM a
+-- Invariant: the TcIds are fully zonked. Reasons:
+--	(a) The kinds of the forall'd type variables are defaulted
+--	    (see Kind.defaultKind, done in zonkQuantifiedTyVar)
+--	(b) There are no via-Indirect occurrences of the bound variables
+--	    in the types, because instantiation does not look through such things
+--	(c) The call to tyVarsOfTypes is ok without looking through refs
+
+tc_extend_local_id_env env th_lvl names_w_ids thing_inside
+  = do	{ traceTc (text "env2")
+	; traceTc (text "env3" <+> ppr extra_env)
+	; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars
+	; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}
+	; setLclEnv env' thing_inside }
+  where
+    extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
+    extra_env	    = [ (name, ATcId { tct_id = id, 
+    				       tct_level = th_lvl,
+    				       tct_type = id_ty, 
+    				       tct_co = if isRefineableTy id_ty 
+    						then Just idHsWrapper
+    						else Nothing })
+    		      | (name,id) <- names_w_ids, let id_ty = idType id]
+    le'		    = extendNameEnvList (tcl_env env) extra_env
+    rdr_env'	    = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
 \end{code}
 
 
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index d526fc5..8bb8d3e 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -840,8 +840,8 @@ setInteractiveContext hsc_env icxt thing_inside
 	tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
 
 
-    tcExtendIdEnv (ic_tmp_ids icxt) $
-        -- tcExtendIdEnv does lots: 
+    tcExtendGhciEnv (ic_tmp_ids icxt) $
+        -- tcExtendGhciEnv does lots: 
         --   - it extends the local type env (tcl_env) with the given Ids,
         --   - it extends the local rdr env (tcl_rdr) with the Names from 
         --     the given Ids