Give a better error message when we try to print a value of unknown type

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

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 3c14bb7..ef19889 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -2207,9 +2207,12 @@ handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status =
         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
+        let index  = breakInfo_number info
+            occs   = modBreaks_vars breaks ! index
+            span   = modBreaks_locs breaks ! index
+        (new_hsc_env, names) <- extendEnvironment hsc_env apStack span
+                                        (breakInfo_vars info) 
+                                        (breakInfo_resty info) occs
         writeIORef ref new_hsc_env 
         let res = ResumeHandle breakMVar statusMVar final_names
                                final_ic resume_ic names
@@ -2315,46 +2318,45 @@ getIdValFromApStack apStack (identifier, stackDepth) = do
 extendEnvironment
         :: HscEnv
         -> a            -- the AP_STACK object built by the interpreter
+        -> SrcSpan
         -> [(Id, Int)]  -- free variables and offsets into the AP_STACK
+        -> Type
         -> [OccName]    -- names for the variables (from the source code)
         -> IO (HscEnv, [Name])
-extendEnvironment hsc_env apStack idsOffsets occs = do
+extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do
    idsVals <- mapM (getIdValFromApStack apStack) idsOffsets 
    let (ids, hValues) = unzip idsVals 
    new_ids <- zipWithM mkNewId occs ids
    let names = map idName ids
 
-   let tyvars = varSetElems (tyVarsOfTypes (map idType new_ids))
-       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_tyvar_tys))
-       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
-       type_env = ic_type_env ictxt
-       all_new_ids  = result_id : subst_ids
-       bound_names = map idName all_new_ids
-       -- 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,
-                         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
-       old_tyvars = ic_tyvars ictxt
-       new_ic = ictxt { ic_type_env = new_type_env,
-                        ic_tyvars = extendVarSetList old_tyvars new_tyvars }
+   -- make an Id for _result.  We use the Unique of the FastString "_result";
+   -- we don't care about uniqueness here, because there will only be one
+   -- _result in scope at any time.
+   let result_fs = FSLIT("_result")
+       result_name = mkInternalName (getUnique result_fs)
+                          (mkVarOccFS result_fs) (srcSpanStart span)
+       result_id   = Id.mkLocalId result_name result_ty
+
+   -- for each Id we're about to bind in the local envt:
+   --    - skolemise the type variables in its type, so they can't
+   --      be randomly unified with other types.  These type variables
+   --      can only be resolved by type reconstruction in RtClosureInspect
+   --    - tidy the type variables
+   --    - globalise the Id (Ids are supposed to be Global, apparently).
+   --
+   let all_ids = result_id : ids
+       (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
+       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
+       new_tyvars = unionVarSets tyvarss             
+       new_ids = zipWith setIdType all_ids tidy_tys
+       global_ids = map (globaliseId VanillaGlobal) new_ids
+
+   let ictxt = extendInteractiveContext (hsc_IC hsc_env) 
+                                        global_ids new_tyvars
+
    Linker.extendLinkEnv (zip names hValues)
    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
-   return (hsc_env{hsc_IC = new_ic}, result_name:names)
+   return (hsc_env{hsc_IC = ictxt}, result_name:names)
   where
    mkNewId :: OccName -> Id -> IO Id
    mkNewId occ id = do
@@ -2365,6 +2367,18 @@ extendEnvironment hsc_env apStack idsOffsets occs = do
          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
      return new_id
 
+skolemiseTy :: Type -> (Type, TyVarSet)
+skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
+  where env           = mkVarEnv (zip tyvars new_tyvar_tys)
+        subst         = mkTvSubst emptyInScopeSet env
+        tyvars        = varSetElems (tyVarsOfType ty)
+        new_tyvars    = map skolemiseTyVar tyvars
+        new_tyvar_tys = map mkTyVarTy new_tyvars
+
+skolemiseTyVar :: TyVar -> TyVar
+skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) 
+                                 (SkolemTv RuntimeUnkSkol)
+
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames