Commit 40739684 authored by mnislaih's avatar mnislaih
Browse files

Fix Trac 1865: GHCi debugger crashes with :print

parent f0cecc6c
...@@ -81,7 +81,7 @@ pprintClosureCommand session bindThings force str = do ...@@ -81,7 +81,7 @@ pprintClosureCommand session bindThings force str = do
-- Then, we extract a substitution, -- Then, we extract a substitution,
-- mapping the old tyvars to the reconstructed types. -- mapping the old tyvars to the reconstructed types.
let Just reconstructed_type = termType term let Just reconstructed_type = termType term
Just subst = computeRTTIsubst (idType id) (reconstructed_type) subst = computeRTTIsubst (idType id) (reconstructed_type)
return (term',subst) return (term',subst)
tidyTermTyVars :: Session -> Term -> IO Term tidyTermTyVars :: Session -> Term -> IO Term
......
...@@ -736,16 +736,20 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do ...@@ -736,16 +736,20 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
-- improved rtti_t computed by RTTI -- improved rtti_t computed by RTTI
-- The main difference between RTTI types and their normal counterparts -- The main difference between RTTI types and their normal counterparts
-- is that the former are _not_ polymorphic, thus polymorphism must -- is that the former are _not_ polymorphic, thus polymorphism must
-- be stripped. Syntactically, forall's must be stripped -- be stripped. Syntactically, forall's must be stripped.
computeRTTIsubst :: Type -> Type -> Maybe TvSubst -- We also remove predicates.
computeRTTIsubst :: Type -> Type -> TvSubst
computeRTTIsubst ty rtti_ty = 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 -- In addition, we strip newtypes too, since the reconstructed type might
-- not have recovered them all -- not have recovered them all
tcUnifyTys (const BindMe) -- TODO stripping newtypes shouldn't be necessary, test
[repType' $ dropForAlls$ ty] where mb_subst = tcUnifyTys (const BindMe)
[repType' $ rtti_ty] [rttiView ty]
-- TODO stripping newtypes shouldn't be necessary, test [rttiView rtti_ty]
-- Dealing with newtypes -- Dealing with newtypes
{- {-
......
...@@ -609,7 +609,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do ...@@ -609,7 +609,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
let substs = [computeRTTIsubst ty ty' let substs = [computeRTTIsubst ty ty'
| (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys] | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
ic' = foldr (flip substInteractiveContext) ic ic' = foldr (flip substInteractiveContext) ic
(map skolemiseSubst $ catMaybes substs) (map skolemiseSubst substs)
return hsc_env{hsc_IC=ic'} return hsc_env{hsc_IC=ic'}
skolemiseSubst subst = subst `setTvSubstEnv` skolemiseSubst subst = subst `setTvSubstEnv`
......
...@@ -55,7 +55,7 @@ module Type ( ...@@ -55,7 +55,7 @@ module Type (
splitTyConApp_maybe, splitTyConApp, splitTyConApp_maybe, splitTyConApp,
splitNewTyConApp_maybe, splitNewTyConApp, splitNewTyConApp_maybe, splitNewTyConApp,
repType, repType', typePrimRep, coreView, tcView, kindView, repType, typePrimRep, coreView, tcView, kindView, rttiView,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy, dropForAlls, applyTy, applyTys, isForAllTy, dropForAlls,
...@@ -189,6 +189,18 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys ...@@ -189,6 +189,18 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
tcView ty = Nothing 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 #-} {-# INLINE kindView #-}
kindView :: Kind -> Maybe Kind kindView :: Kind -> Maybe Kind
...@@ -483,16 +495,6 @@ repType (TyConApp tc tys) ...@@ -483,16 +495,6 @@ repType (TyConApp tc tys)
repType ty = ty 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 -- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly. -- of inspecting the type directly.
typePrimRep :: Type -> PrimRep typePrimRep :: Type -> PrimRep
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment