X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=ea882d5cab55444f7dc220e7b6ce60a2f758e66b;hb=a4d1f3a5a560ee8f4cbf32e2d6a9e9d158c8d8ee;hp=c495229b5dffc6ae2512129cf57cce5ef4d2d1f6;hpb=ae5a7e5fe428fdf56c4c5228d5ff13b2e6c3f885;p=ghc-hetmet.git

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index c495229..ea882d5 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -335,7 +335,7 @@ pprTermM, pprNewtypeWrap :: Monad m =>
                            (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
 pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
   tt_docs <- mapM (y app_prec) tt
-  return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
+  return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> fsep tt_docs)
   
 pprTermM y p Term{dc=Right dc, subTerms=tt} 
 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
@@ -345,7 +345,7 @@ pprTermM y p Term{dc=Right dc, subTerms=tt}
   | null tt   = return$ ppr dc
   | otherwise = do
          tt_docs <- mapM (y app_prec) tt
-         return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
+         return$ cparen (p >= app_prec) (ppr dc <+> fsep tt_docs)
 
 pprTermM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
 
@@ -446,10 +446,10 @@ cPprTermBase y =
                print_elems <- mapM (y cons_prec) elems
                return$ if isConsLast
                      then cparen (p >= cons_prec) 
-                        . hsep 
+                        . fsep 
                         . punctuate (space<>colon)
                         $ print_elems
-                     else brackets (hcat$ punctuate comma print_elems)
+                     else brackets (fsep$ punctuate comma print_elems)
 
                 where Just a /= Just b = not (a `coreEqType` b)
                       _      /=   _    = True
@@ -649,11 +649,11 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
    | isPointed ty = ASSERT2(not(null pointed)
                             , ptext SLIT("reOrderTerms") $$ 
                                         (ppr pointed $$ ppr unpointed))
-                    head pointed : reOrderTerms (tail pointed) unpointed tys
+                    let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
    | otherwise    = ASSERT2(not(null unpointed)
                            , ptext SLIT("reOrderTerms") $$ 
                                        (ppr pointed $$ ppr unpointed))
-                    head unpointed : reOrderTerms pointed (tail unpointed) tys
+                    let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
   
   expandNewtypes t@Term{ ty=ty, subTerms=tt }
    | Just (tc, args) <- splitNewTyConApp_maybe ty
@@ -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
 {-