Keep track of free type variables in the interactive bindings

Now, the type checker won't attempt to generalise over the skolem
variables in the interactive bindings.  If we end up trying to show
one of these types, there will be an unresolved predicate 'Show t'
which causes a type error (albeit a strange one, I'll fix that
later).

compiler/ghci/Debugger.hs

@@ -105,7 +105,6 @@ bindSuspensions cms@(Session ref) t = do
       hsc_env <- readIORef ref
       inScope <- GHC.getBindings cms
       let ictxt        = hsc_IC hsc_env
-          rn_env       = ic_rn_local_env ictxt
           type_env     = ic_type_env ictxt
           prefix       = "_t"
           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
@@ -113,12 +112,14 @@ bindSuspensions cms@(Session ref) t = do
       availNames_var  <- newIORef availNames
       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
-      let ids = [ mkGlobalId VanillaGlobal name (mk_skol_ty ty) vanillaIdInfo
-                  | (name,ty) <- zip names tys]
+      let tys' = map mk_skol_ty tys
+      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
+                | (name,ty) <- zip names tys']
+          new_tyvars   = tyVarsOfTypes tys'
           new_type_env = extendTypeEnvWithIds type_env ids 
-          new_rn_env   = extendLocalRdrEnv rn_env names
-          new_ic       = ictxt { ic_rn_local_env = new_rn_env, 
-                                 ic_type_env     = new_type_env }
+          old_tyvars   = ic_tyvars ictxt
+          new_ic       = ictxt { ic_type_env = new_type_env,
+                                 ic_tyvars   = old_tyvars `unionVarSet` new_tyvars }
       extendLinkEnv (zip names hvals)
       writeIORef ref (hsc_env {hsc_IC = new_ic })
       return t'
@@ -174,13 +175,10 @@ printTerm cms@(Session ref) = cPprTerm cPpr
   bindToFreshName hsc_env ty userName = do
     name <- newGrimName cms userName 
     let ictxt    = hsc_IC hsc_env
-        rn_env   = ic_rn_local_env ictxt
         type_env = ic_type_env ictxt
         id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
         new_type_env = extendTypeEnv type_env (AnId id)
-        new_rn_env   = extendLocalRdrEnv rn_env [name]
-        new_ic       = ictxt { ic_rn_local_env = new_rn_env, 
-                               ic_type_env     = new_type_env }
+        new_ic       = ictxt { ic_type_env     = new_type_env }
     return (hsc_env {hsc_IC = new_ic }, name)
 
 --    Create new uniques and give them sequentially numbered names

compiler/main/GHC.hs

@@ -2325,10 +2325,11 @@ extendEnvironment hsc_env apStack idsOffsets occs = do
    let names = map idName ids
 
    let tyvars = varSetElems (tyVarsOfTypes (map idType new_ids))
-       new_tyvars = map (mkTyVarTy . mk_skol) tyvars
+       new_tyvars = map mk_skol tyvars
+       new_tyvar_tys = map mkTyVarTy new_tyvars
        mk_skol tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) 
                          (SkolemTv UnkSkol)
-       subst = mkTvSubst emptyInScopeSet (mkVarEnv (zip tyvars new_tyvars))
+       subst = mkTvSubst emptyInScopeSet (mkVarEnv (zip tyvars new_tyvar_tys))
        subst_id id = id `setIdType` substTy subst (idType id)
        subst_ids = map subst_id new_ids
 
@@ -2336,21 +2337,21 @@ extendEnvironment hsc_env apStack idsOffsets occs = do
    let result_name = mkSystemVarName (mkBuiltinUnique 33) FSLIT("_result")
        result_id   = Id.mkLocalId result_name (mkTyConApp unknown_tc [])
    let ictxt = hsc_IC hsc_env
-       rn_env   = ic_rn_local_env ictxt
        type_env = ic_type_env ictxt
        all_new_ids  = result_id : subst_ids
        bound_names = map idName all_new_ids
-       new_rn_env  = extendLocalRdrEnv rn_env bound_names
        -- Remove any shadowed bindings from the type_env;
        -- they are inaccessible but might, I suppose, cause 
        -- a space leak if we leave them there
+       old_bound_names = map idName (typeEnvIds (ic_type_env ictxt)) ;
        shadowed = [ n | name <- bound_names,
-                    let rdr_name = mkRdrUnqual (nameOccName name),
-                    Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+                         n <- old_bound_names,
+                         nameOccName name == nameOccName n ] ;
        filtered_type_env = delListFromNameEnv type_env shadowed
        new_type_env = extendTypeEnvWithIds filtered_type_env all_new_ids
-       new_ic = ictxt { ic_rn_local_env = new_rn_env, 
-		        ic_type_env     = new_type_env }
+       old_tyvars = ic_tyvars ictxt
+       new_ic = ictxt { ic_type_env = new_type_env,
+                        ic_tyvars = extendVarSetList old_tyvars new_tyvars }
    Linker.extendLinkEnv (zip names hValues)
    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
    return (hsc_env{hsc_IC = new_ic}, result_name:names)

compiler/main/HscMain.lhs

@@ -25,8 +25,7 @@ module HscMain
 #include "HsVersions.h"
 
 #ifdef GHCI
-import HsSyn		( Stmt(..), LHsExpr, LStmt, LHsType )
-import Module		( Module )
+import HsSyn		( Stmt(..), LStmt, LHsType )
 import CodeOutput	( outputForeignStubs )
 import ByteCodeGen	( byteCodeGen, coreExprToBCOs )
 import Linker		( HValue, linkExpr )
@@ -43,6 +42,7 @@ import {- Kind parts of -} Type		( Kind )
 import CoreLint		( lintUnfolding )
 import DsMeta		( templateHaskellNames )
 import SrcLoc		( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
+import VarSet
 import VarEnv		( emptyTidyEnv )
 #endif
 
@@ -934,7 +934,10 @@ compileExpr hsc_env srcspan ds_expr
 		-- Lint if necessary
 		-- ToDo: improve SrcLoc
 	; if lint_on then 
-		case lintUnfolding noSrcLoc [] prepd_expr of
+                let ictxt = hsc_IC hsc_env
+                    tyvars = varSetElems (ic_tyvars ictxt)
+                in
+		case lintUnfolding noSrcLoc tyvars prepd_expr of
 		   Just err -> pprPanic "compileExpr" err
 		   Nothing  -> return ()
 	  else

compiler/main/HscTypes.lhs

@@ -85,6 +85,7 @@ import InstEnv		( InstEnv, Instance )
 import FamInstEnv	( FamInstEnv, FamInst )
 import Rules		( RuleBase )
 import CoreSyn		( CoreBind )
+import VarSet
 import Id		( Id, isImplicitId )
 import Type		( TyThing(..) )
 
@@ -614,18 +615,27 @@ data InteractiveContext
 	ic_rn_gbl_env :: GlobalRdrEnv,	-- The cached GlobalRdrEnv, built from
 					-- ic_toplev_scope and ic_exports
 
-	ic_rn_local_env :: LocalRdrEnv,	-- Lexical context for variables bound
-					-- during interaction
-
-	ic_type_env :: TypeEnv		-- Ditto for types
+	ic_type_env :: TypeEnv,         -- Type env for names bound during
+                                        -- interaction.  NB. the names from
+                                        -- these Ids are used to populate
+                                        -- the LocalRdrEnv used during
+                                        -- typechecking of a statement, so
+                                        -- there should be no duplicate
+                                        -- names in here.
+
+        ic_tyvars :: TyVarSet           -- skolem type variables free in
+                                        -- ic_type_env.  These arise at
+                                        -- breakpoints in a polymorphic 
+                                        -- context, where we have only partial
+                                        -- type information.
     }
 
 emptyInteractiveContext
   = InteractiveContext { ic_toplev_scope = [],
 			 ic_exports = [],
 			 ic_rn_gbl_env = emptyGlobalRdrEnv,
-			 ic_rn_local_env = emptyLocalRdrEnv,
-			 ic_type_env = emptyTypeEnv }
+			 ic_type_env = emptyTypeEnv,
+                         ic_tyvars = emptyVarSet }
 
 icPrintUnqual :: InteractiveContext -> PrintUnqualified
 icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt)

compiler/typecheck/TcRnDriver.lhs

@@ -823,10 +823,20 @@ setInteractiveContext hsc_env icxt thing_inside
     in
     updGblEnv (\env -> env { 
 	tcg_rdr_env  = ic_rn_gbl_env icxt,
-	tcg_type_env = ic_type_env   icxt,
 	tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
 
-    updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt })	$
+
+    tcExtendIdEnv (typeEnvIds (ic_type_env icxt)) $
+        -- tcExtendIdEnv 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
+        --   - it adds the free tyvars of the Ids to the tcl_tyvars
+        --     set.
+        --
+        -- We should have no Ids with the same name in the
+        -- ic_type_env, otherwise we'll end up with shadowing in the
+        -- tcl_rdr, and it's random which one will be in scope.
 
     do	{ traceTc (text "setIC" <+> ppr (ic_type_env icxt))
  	; thing_inside }
@@ -875,11 +885,9 @@ tcRnStmt hsc_env ictxt rdr_stmt
 	global_ids = map globaliseAndTidy zonked_ids ;
     
 		-- Update the interactive context
-	rn_env   = ic_rn_local_env ictxt ;
 	type_env = ic_type_env ictxt ;
 
 	bound_names = map idName global_ids ;
-	new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
 
 {- ---------------------------------------------
    At one stage I removed any shadowed bindings from the type_env;
@@ -898,15 +906,17 @@ tcRnStmt hsc_env ictxt rdr_stmt
  
    Hence this code is commented out
 
+-------------------------------------------------- -}
+
+        old_bound_names = map idName (typeEnvIds (ic_type_env ictxt)) ;
 	shadowed = [ n | name <- bound_names,
-			 let rdr_name = mkRdrUnqual (nameOccName name),
-			 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
+                         n <- old_bound_names,
+                         nameOccName name == nameOccName n ] ;
+
 	filtered_type_env = delListFromNameEnv type_env shadowed ;
--------------------------------------------------- -}
 
-	new_type_env = extendTypeEnvWithIds type_env global_ids ;
-	new_ic = ictxt { ic_rn_local_env = new_rn_env, 
-		  	 ic_type_env     = new_type_env }
+	new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
+	new_ic = ictxt { ic_type_env = new_type_env }
     } ;
 
     dumpOptTcRn Opt_D_dump_tc 
@@ -1206,8 +1216,19 @@ tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
 tcRnLookupName hsc_env name
   = initTcPrintErrors hsc_env iNTERACTIVE $ 
     setInteractiveContext hsc_env (hsc_IC hsc_env) $
-    tcLookupGlobal name
+    tcRnLookupName' name
+
+-- To look up a name we have to look in the local environment (tcl_lcl)
+-- as well as the global environment, which is what tcLookup does. 
+-- But we also want a TyThing, so we have to convert:
 
+tcRnLookupName' :: Name -> TcRn TyThing
+tcRnLookupName' name = do
+   tcthing <- tcLookup name
+   case tcthing of
+     AGlobal thing    -> return thing
+     ATcId{tct_id=id} -> return (AnId id)
+     _ -> panic "tcRnLookupName'"
 
 tcRnGetInfo :: HscEnv
 	    -> Name
@@ -1231,7 +1252,7 @@ tcRnGetInfo hsc_env name
 	--  in the home package all relevant modules are loaded.)
     loadUnqualIfaces ictxt
 
-    thing  <- tcLookupGlobal name
+    thing <- tcRnLookupName' name
     fixity <- lookupFixityRn name
     ispecs <- lookupInsts (icPrintUnqual ictxt) thing
     return (thing, fixity, ispecs)