Commit 671b39c5 authored by Simon Marlow's avatar Simon Marlow
Browse files

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).
parent 808e6d4e
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment