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).
hsc_env <- readIORef ref
inScope <- GHC.getBindings cms
let ictxt = hsc_IC hsc_env
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
type_env = ic_type_env ictxt
prefix = "_t"
alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
availNames_var <- newIORef availNames
(t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
let (names, tys, hvals) = unzip3 stuff
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_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'
extendLinkEnv (zip names hvals)
writeIORef ref (hsc_env {hsc_IC = new_ic })
return t'
bindToFreshName hsc_env ty userName = do
name <- newGrimName cms userName
let ictxt = hsc_IC hsc_env
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)
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
return (hsc_env {hsc_IC = new_ic }, name)
-- Create new uniques and give them sequentially numbered names
let names = map idName ids
let tyvars = varSetElems (tyVarsOfTypes (map idType new_ids))
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)
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
subst_id id = id `setIdType` substTy subst (idType id)
subst_ids = map subst_id new_ids
let result_name = mkSystemVarName (mkBuiltinUnique 33) FSLIT("_result")
result_id = Id.mkLocalId result_name (mkTyConApp unknown_tc [])
let ictxt = hsc_IC hsc_env
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
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
-- 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,
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
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)
Linker.extendLinkEnv (zip names hValues)
Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
return (hsc_env{hsc_IC = new_ic}, result_name:names)
#include "HsVersions.h"
#ifdef GHCI
#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 )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
import VarEnv ( emptyTidyEnv )
#endif
import VarEnv ( emptyTidyEnv )
#endif
-- Lint if necessary
-- ToDo: improve SrcLoc
; if lint_on then
-- 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
Just err -> pprPanic "compileExpr" err
Nothing -> return ()
else
import FamInstEnv ( FamInstEnv, FamInst )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
import FamInstEnv ( FamInstEnv, FamInst )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
import Id ( Id, isImplicitId )
import Type ( TyThing(..) )
import Id ( Id, isImplicitId )
import Type ( TyThing(..) )
ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from
-- ic_toplev_scope and ic_exports
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,
}
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)
icPrintUnqual :: InteractiveContext -> PrintUnqualified
icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt)
in
updGblEnv (\env -> env {
tcg_rdr_env = ic_rn_gbl_env icxt,
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 }) $
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 }
do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
; thing_inside }
global_ids = map globaliseAndTidy zonked_ids ;
-- Update the interactive context
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 ;
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;
{- ---------------------------------------------
At one stage I removed any shadowed bindings from the type_env;
Hence this code is commented out
Hence this code is commented out
+-------------------------------------------------- -}
+
+ old_bound_names = map idName (typeEnvIds (ic_type_env ictxt)) ;
shadowed = [ n | name <- bound_names,
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 ;
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
} ;
dumpOptTcRn Opt_D_dump_tc
tcRnLookupName hsc_env name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
tcRnLookupName hsc_env name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ 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
tcRnGetInfo :: HscEnv
-> Name
-- in the home package all relevant modules are loaded.)
loadUnqualIfaces ictxt
-- 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)
fixity <- lookupFixityRn name
ispecs <- lookupInsts (icPrintUnqual ictxt) thing
return (thing, fixity, ispecs)