convert type variables to TcTyVars, otherwise the typechecker gets confused

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 4f181b2..d976152 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -204,7 +204,6 @@ import Linker           ( HValue )
 import Data.Dynamic     ( Dynamic )
 
 import ByteCodeInstr
-import DebuggerTys
 import IdInfo
 import HscMain          ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt )
 import BreakArray
@@ -215,8 +214,11 @@ import NameSet
 import RdrName
 import HsSyn 
 import Type             hiding (typeKind)
+import TcType           hiding (typeKind)
 import Id
 import Var              hiding (setIdType)
+import VarEnv
+import VarSet
 import TysPrim         ( alphaTyVars )
 import TyCon
 import Class
@@ -255,7 +257,10 @@ import TcType           ( tcSplitSigmaTy, isDictTy )
 import Maybes          ( expectJust, mapCatMaybes )
 import HaddockParse
 import HaddockLex       ( tokenise )
+import PrelNames
+import Unique
 
+import Data.Array
 import Control.Concurrent
 import System.Directory ( getModificationTime, doesFileExist )
 import Data.Maybe
@@ -2199,13 +2204,16 @@ handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status =
    case status of  
       -- did we hit a breakpoint or did we complete?
       (Break apStack info tid) -> do
-                hsc_env <- readIORef ref
-                (new_hsc_env, names) <- extendEnvironment hsc_env apStack 
-                                                (breakInfo_vars info)
-                writeIORef ref new_hsc_env 
-                let res = ResumeHandle breakMVar statusMVar final_names
-                                       final_ic resume_ic names
-                return (RunBreak tid names info res)
+        hsc_env <- readIORef ref
+        mod_info <- getHomeModuleInfo hsc_env (moduleName (breakInfo_module info))
+        let breaks = minf_modBreaks (expectJust "handlRunStatus" mod_info)
+        let occs = modBreaks_vars breaks ! breakInfo_number info
+        (new_hsc_env, names) <- extendEnvironment hsc_env apStack 
+                                        (breakInfo_vars info) occs
+        writeIORef ref new_hsc_env 
+        let res = ResumeHandle breakMVar statusMVar final_names
+                               final_ic resume_ic names
+        return (RunBreak tid names info res)
       (Complete either_hvals) ->
                case either_hvals of
                    Left e -> return (RunException e)
@@ -2304,17 +2312,34 @@ getIdValFromApStack apStack (identifier, stackDepth) = do
    freeStablePtr resultSptr 
    return (identifier, unsafeCoerce# result)
 
-extendEnvironment :: HscEnv -> a -> [(Id, Int)] -> IO (HscEnv, [Name])
-extendEnvironment hsc_env apStack idsOffsets = do
+extendEnvironment
+        :: HscEnv
+        -> a            -- the AP_STACK object built by the interpreter
+        -> [(Id, Int)]  -- free variables and offsets into the AP_STACK
+        -> [OccName]    -- names for the variables (from the source code)
+        -> IO (HscEnv, [Name])
+extendEnvironment hsc_env apStack idsOffsets occs = do
    idsVals <- mapM (getIdValFromApStack apStack) idsOffsets 
    let (ids, hValues) = unzip idsVals 
+   new_ids <- zipWithM mkNewId occs ids
    let names = map idName ids
-   let global_ids = map globaliseAndTidy ids
-   typed_ids  <- mapM instantiateIdType global_ids
+
+   let tyvars = varSetElems (tyVarsOfTypes (map idType new_ids))
+       new_tyvars = map (mkTyVarTy . mk_skol) tyvars
+       mk_skol tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) 
+                         (SkolemTv UnkSkol)
+       subst = mkTvSubst emptyInScopeSet (mkVarEnv (zip tyvars new_tyvars))
+       subst_id id = id `setIdType` substTy subst (idType id)
+       subst_ids = map subst_id new_ids
+
+   Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknownTyConName
+   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
-       bound_names = map idName typed_ids
+       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 
@@ -2323,22 +2348,21 @@ extendEnvironment hsc_env apStack idsOffsets = do
                     let rdr_name = mkRdrUnqual (nameOccName name),
                     Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
        filtered_type_env = delListFromNameEnv type_env shadowed
-       new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
+       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 }
-   Linker.extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
-   return (hsc_env{hsc_IC = new_ic}, names)
+   Linker.extendLinkEnv (zip names hValues)
+   Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
+   return (hsc_env{hsc_IC = new_ic}, result_name:names)
   where
-   globaliseAndTidy :: Id -> Id
-   globaliseAndTidy id
-      = let tidied_type = tidyTopType$ idType id
-        in setIdType (globaliseId VanillaGlobal id) tidied_type
-
-   -- | Instantiate the tyVars with GHC.Base.Unknown
-   instantiateIdType :: Id -> IO Id
-   instantiateIdType id = do
-      instantiatedType <- instantiateTyVarsToUnknown hsc_env (idType id)
-      return$ setIdType id instantiatedType
+   mkNewId :: OccName -> Id -> IO Id
+   mkNewId occ id = do
+     let uniq = idUnique id
+         loc = nameSrcLoc (idName id)
+         name = mkInternalName uniq occ loc
+         ty = tidyTopType (idType id)
+         new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
+     return new_id
 
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames