From: Simon Marlow Date: Wed, 25 Apr 2007 13:03:32 +0000 (+0000) Subject: Keep track of free type variables in the interactive bindings X-Git-Tag: 2007-05-06~109 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=671b39c5b40e5a3105e4ffb49b673b20ce96ba15 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). --- diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 52c6030..7a686f3 100644 --- a/compiler/ghci/Debugger.hs +++ b/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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index d976152..3c14bb7 100644 --- a/compiler/main/GHC.hs +++ b/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) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 20a0b5a..50a015f 100644 --- a/compiler/main/HscMain.lhs +++ b/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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 99495fe..04f2b7c 100644 --- a/compiler/main/HscTypes.lhs +++ b/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) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 2595963..08ea437 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/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)