Fix Trac 1865: GHCi debugger crashes with :print

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index d31d4d6..9fbee36 100644 (file)
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -81,7 +81,7 @@ pprintClosureCommand session bindThings force str = do
      --  Then, we extract a substitution,
      --  mapping the old tyvars to the reconstructed types.
        let Just reconstructed_type = termType term
-           Just subst = computeRTTIsubst (idType id) (reconstructed_type)
+           subst = computeRTTIsubst (idType id) (reconstructed_type)
        return (term',subst)
 
    tidyTermTyVars :: Session -> Term -> IO Term

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index b9fd192..d772eb3 100644 (file)
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -736,16 +736,20 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
      -- improved rtti_t computed by RTTI
      -- The main difference between RTTI types and their normal counterparts
      --  is that the former are _not_ polymorphic, thus polymorphism must
-     --  be stripped. Syntactically, forall's must be stripped
-computeRTTIsubst :: Type -> Type -> Maybe TvSubst
+     --  be stripped. Syntactically, forall's must be stripped.
+     -- We also remove predicates.
+computeRTTIsubst :: Type -> Type -> TvSubst
 computeRTTIsubst ty rtti_ty = 
+    case mb_subst of
+      Just subst -> subst
+      Nothing    -> pprPanic "Failed to compute a RTTI substitution" 
+                             (ppr (ty, rtti_ty))
      -- In addition, we strip newtypes too, since the reconstructed type might
      --   not have recovered them all
-           tcUnifyTys (const BindMe) 
-                      [repType' $ dropForAlls$ ty]
-                      [repType' $ rtti_ty]  
--- TODO stripping newtypes shouldn't be necessary, test
-
+     -- TODO stripping newtypes shouldn't be necessary, test
+   where mb_subst = tcUnifyTys (const BindMe) 
+                               [rttiView ty]
+                               [rttiView rtti_ty]  
 
 -- Dealing with newtypes
 {-

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 9187f1a..bf7c7b4 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -609,7 +609,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
    let substs = [computeRTTIsubst ty ty' 
                  | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
        ic'    = foldr (flip substInteractiveContext) ic 
-                           (map skolemiseSubst $ catMaybes substs)
+                           (map skolemiseSubst substs)
    return hsc_env{hsc_IC=ic'}
 
 skolemiseSubst subst = subst `setTvSubstEnv` 

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index ab47c4c..662dd6f 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -55,7 +55,7 @@ module Type (
        splitTyConApp_maybe, splitTyConApp, 
         splitNewTyConApp_maybe, splitNewTyConApp,
 
-       repType, repType', typePrimRep, coreView, tcView, kindView,
+       repType, typePrimRep, coreView, tcView, kindView, rttiView,
 
        mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
        applyTy, applyTys, isForAllTy, dropForAlls,
@@ -190,6 +190,18 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
 tcView ty               = Nothing
 
 -----------------------------------------------
+rttiView :: Type -> Type
+-- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism
+rttiView (ForAllTy _ ty) = rttiView ty
+rttiView (NoteTy   _ ty) = rttiView ty
+rttiView (FunTy PredTy{} ty) = rttiView ty
+rttiView (FunTy NoteTy{} ty) = rttiView ty
+rttiView ty@TyConApp{} | Just ty' <- coreView ty 
+                           = rttiView ty'
+rttiView (TyConApp tc tys) = mkTyConApp tc (map rttiView tys)
+rttiView ty = ty
+
+-----------------------------------------------
 {-# INLINE kindView #-}
 kindView :: Kind -> Maybe Kind
 -- C.f. coreView, tcView
@@ -483,16 +495,6 @@ repType (TyConApp tc tys)
 
 repType ty = ty
 
--- repType' aims to be a more thorough version of repType
--- For now it simply looks through the TyConApp args too
-repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined
-            | otherwise = go1 ty 
- where 
-        go1 = go . repType
-        go (TyConApp tc tys) = mkTyConApp tc (map repType' tys)
-        go ty = ty
-
-
 -- ToDo: this could be moved to the code generator, using splitTyConApp instead
 -- of inspecting the type directly.
 typePrimRep :: Type -> PrimRep