X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=ef25ad5644873f0abfb0afbdb4332e3d9ab52642;hb=f6a9f267230d8685b34e6a89b622904ebd60aba4;hp=e39a0bc7e324121d37247a282adad798ab926f54;hpb=ed7788bce80decefd43aa9cadf2e6a2db0be38da;p=ghc-hetmet.git

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index e39a0bc..ef25ad5 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -75,8 +75,8 @@ import Data.List
 import qualified Data.Sequence as Seq
 import Data.Monoid
 import Data.Sequence (viewl, ViewL(..))
-import Foreign
--- import System.IO.Unsafe
+import Foreign hiding (unsafePerformIO)
+import System.IO.Unsafe
 
 ---------------------------------------------
 -- * A representation of semi evaluated Terms
@@ -426,7 +426,7 @@ cPprTermBase y =
                                       . mapM (y (-1))
                                       . subTerms)
   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
-           (\ p Term{subTerms=[h,t]} -> doList p h t)
+           (\ p t -> doList p t)
   , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
   , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
   , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
@@ -452,7 +452,7 @@ cPprTermBase y =
            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 
            --Note pprinting of list terms is not lazy
-           doList p h t = do
+           doList p (Term{subTerms=[h,t]}) = do
                let elems      = h : getListTerms t
                    isConsLast = not(termType(last elems) `coreEqType` termType h)
                print_elems <- mapM (y cons_prec) elems
@@ -468,6 +468,7 @@ cPprTermBase y =
                       getListTerms Term{subTerms=[]}    = []
                       getListTerms t@Suspension{}       = [t]
                       getListTerms t = pprPanic "getListTerms" (ppr t)
+           doList _ _ = panic "doList"
 
 
 repPrim :: TyCon -> [Word] -> String
@@ -569,13 +570,13 @@ liftTcM :: TcM a -> TR a
 liftTcM = id
 
 newVar :: Kind -> TR TcType
-newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
+newVar = liftTcM . newFlexiTyVarTy
 
 -- | Returns the instantiated type scheme ty', and the substitution sigma 
 --   such that sigma(ty') = ty 
 instScheme :: Type -> TR (TcType, TvSubst)
 instScheme ty = liftTcM$ do
-   (tvs, _, _)      <- tcInstType return ty
+   (tvs, _, _)  <- tcInstType return ty
    (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 
@@ -590,7 +591,7 @@ addConstraint actual expected = do
     recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
                                     text "with", ppr expected])
               (congruenceNewtypes actual expected >>=
-                           (getLIE . uncurry boxyUnify) >> return ())
+                           (getConstraints . uncurry unifyType) >> return ())
      -- TOMDO: what about the coercion?
      -- we should consider family instances
 
@@ -861,7 +862,7 @@ improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
     (ty_tvs,  _, _)   <- tcInstType return ty
     (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
     (_, _, rtti_ty')  <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
-    _ <- getLIE(boxyUnify rtti_ty' ty')
+    _ <- getConstraints(unifyType rtti_ty' ty')
     tvs1_contents     <- zonkTcTyVars ty_tvs'
     let subst = (uncurry zipTopTvSubst . unzip)
                  [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
@@ -1101,7 +1102,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
                         text " in presence of newtype evidence " <> ppr new_tycon)
                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
                let ty' = mkTyConApp new_tycon vars
-               _ <- liftTcM (boxyUnify ty (repType ty'))
+               _ <- liftTcM (unifyType ty (repType ty'))
         -- assumes that reptype doesn't ^^^^ touch tyconApp args 
                return ty'