Fix #2044 (:printing impredicatively typed things)

Switching to boxyUnify should be enough to fix this.

4 files changed, 37 insertions, 41 deletions

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index b5347dc1bb..c0ac9d3166 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -81,8 +81,9 @@ pprintClosureCommand session bindThings force str = do
      --  Then, we extract a substitution,
      --  mapping the old tyvars to the reconstructed types.
        let reconstructed_type = termType term
-           subst = unifyRTTI (idType id) (reconstructed_type)
-       return (term',subst)
+       mb_subst <- withSession cms $ \hsc_env ->
+                      improveRTTIType hsc_env (idType id) (reconstructed_type)
+       return (term', fromMaybe emptyTvSubst mb_subst)
 
    tidyTermTyVars :: Session -> Term -> IO Term
    tidyTermTyVars (Session ref) t = do
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 649e59dc7a..3702ec4b3b 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -31,7 +31,7 @@ module RtClosureInspect(
      termTyVars,
 --     unsafeDeepSeq, 
      cvReconstructType,
-     unifyRTTI, 
+     improveRTTIType,
      sigmaType,
      Closure(..),
      getClosureData,
@@ -55,7 +55,6 @@ import TcType
 import TcMType
 import TcUnify
 import TcEnv
-import Unify
 import DriverPhases
 import TyCon
 import Name
@@ -90,6 +89,7 @@ import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
 import Foreign
 import System.IO.Unsafe
 
+import System.IO
 ---------------------------------------------
 -- * A representation of semi evaluated Terms
 ---------------------------------------------
@@ -535,7 +535,7 @@ runTR hsc_env c = do
     Just x  -> return x
 
 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
-runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
+runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False  iNTERACTIVE
 
 traceTR :: SDoc -> TR ()
 traceTR = liftTcM . traceTc
@@ -547,7 +547,7 @@ liftTcM :: TcM a -> TR a
 liftTcM = id
 
 newVar :: Kind -> TR TcType
-newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
+newVar = liftTcM . fmap mkTyVarTy . newBoxyTyVar
 
 -- | Returns the instantiated type scheme ty', and the substitution sigma 
 --   such that sigma(ty') = ty 
@@ -562,7 +562,7 @@ instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
 -- Before unification, congruenceNewtypes needs to
 -- do its magic.
 addConstraint :: TcType -> TcType -> TR ()
-addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType 
+addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry boxyUnify 
 		       >> return () -- TOMDO: what about the coercion?
 				    -- we should consider family instances 
 
@@ -762,26 +762,26 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
                                      zip [0..] (filter isPointed subTtypes)]
       _ -> return []
 
-{-
- This helper computes the difference between a base type t and the 
- 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.
- We also remove predicates.
--}
-unifyRTTI :: Type -> Type -> TvSubst
-unifyRTTI 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
-     -- TODO stripping newtypes shouldn't be necessary, test
-   where mb_subst = tcUnifyTys (const BindMe) 
-                               [rttiView ty]
-                               [rttiView rtti_ty]  
+-- Compute the difference between a base type and the type found by RTTI
+-- improveType <base_type> <rtti_type>
+-- The types can contain skolem type variables, which need to be treated as normal vars.
+-- In particular, we want them to unify with things.
+improveRTTIType :: HscEnv -> Type -> Type -> IO (Maybe TvSubst)
+improveRTTIType hsc_env ty rtti_ty = runTR_maybe hsc_env $ do
+    let (_,ty0)     = splitForAllTys ty
+        ty_tvs      = varSetElems $ tyVarsOfType ty0
+    let (_,rtti_ty0)= splitForAllTys rtti_ty
+        rtti_tvs    = varSetElems $ tyVarsOfType rtti_ty0
+    (ty_tvs',_,ty')<- tcInstType (mapM tcInstTyVar) (mkSigmaTy ty_tvs   [] ty0)
+    (_,_,rtti_ty') <- tcInstType (mapM tcInstTyVar) (mkSigmaTy rtti_tvs [] rtti_ty0)
+    boxyUnify rtti_ty' ty'
+    tvs1_contents  <- zonkTcTyVars ty_tvs'
+    let subst = uncurry zipTopTvSubst
+                  (unzip [(tv,ty) | tv <- ty_tvs, ty <- tvs1_contents
+                                  , getTyVar_maybe ty /= Just tv
+                                  , not(isTyVarTy ty)])
+--    liftIO $ hPutStrLn stderr $ showSDocDebug $ text "unify " <+> sep [ppr ty, ppr rtti_ty, equals, ppr subst ]
+    return subst
 
 -- Dealing with newtypes
 {-
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index c006752949..4388c0b6bb 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -616,10 +616,15 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
    tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
           -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
    
-   let substs = [unifyRTTI ty ty' 
+   improvs <- sequence [improveRTTIType hsc_env ty ty'
                  | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
-       ic'    = foldr (flip substInteractiveContext) ic 
-                           (map skolemiseSubst substs)
+   let ic' = foldr (\mb_subst ic' ->
+                        maybe (WARN(True, text ("RTTI failed to calculate the "
+                                           ++  "improvement for a type")) ic')
+                              (substInteractiveContext ic' . skolemiseSubst)
+                              mb_subst)
+                   ic
+                   improvs
    return hsc_env{hsc_IC=ic'}
 
 skolemiseSubst :: TvSubst -> TvSubst
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 686bba849f..df9e3c7218 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -55,7 +55,7 @@ module Type (
 	splitTyConApp_maybe, splitTyConApp, 
         splitNewTyConApp_maybe, splitNewTyConApp,
 
-	repType, typePrimRep, coreView, tcView, kindView, rttiView,
+	repType, typePrimRep, coreView, tcView, kindView,
 
 	mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
 	applyTy, applyTys, isForAllTy, dropForAlls,
@@ -188,16 +188,6 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
 tcView _                 = Nothing
 
 -----------------------------------------------
-rttiView :: Type -> Type
--- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism
-rttiView (ForAllTy _ ty) = rttiView ty
-rttiView (FunTy PredTy{} 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