Add transitional rules for the alternative layout rule

[ghc-hetmet.git] / compiler / ghci / RtClosureInspect.hs

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 94e6f08..95ae5ac 100644 (file)
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -46,6 +46,7 @@ import TyCon
 import Name
 import VarEnv
 import Util
+import ListSetOps
 import VarSet
 import TysPrim
 import PrelNames
@@ -53,13 +54,18 @@ import TysWiredIn
 import DynFlags
 import Outputable
 import FastString
-import Panic
+-- import Panic
 
 import Constants        ( wORD_SIZE )
 
 import GHC.Arr          ( Array(..) )
 import GHC.Exts
-import GHC.IOBase ( IO(IO) )
+
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO ( IO(..) )
+#else
+import GHC.IOBase ( IO(..) )
+#endif
 
 import Control.Monad
 import Data.Maybe
@@ -68,11 +74,10 @@ import Data.Ix
 import Data.List
 import qualified Data.Sequence as Seq
 import Data.Monoid
-import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
+import Data.Sequence (viewl, ViewL(..))
 import Foreign
-import System.IO.Unsafe
+-- import System.IO.Unsafe
 
-import System.IO
 ---------------------------------------------
 -- * A representation of semi evaluated Terms
 ---------------------------------------------
@@ -160,7 +165,7 @@ data Closure = Closure { tipe         :: ClosureType
 instance Outputable ClosureType where
   ppr = text . show 
 
-#include "../includes/ClosureTypes.h"
+#include "../includes/rts/storage/ClosureTypes.h"
 
 aP_CODE, pAP_CODE :: Int
 aP_CODE = AP
@@ -376,12 +381,12 @@ ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
 ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
 
-pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} 
+pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
   | Just (tc,_) <- tcSplitTyConApp_maybe ty
   , ASSERT(isNewTyCon tc) True
   , Just new_dc <- tyConSingleDataCon_maybe tc = do 
-         real_term <- y max_prec t
-         return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
+             real_term <- y max_prec t
+             return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 
 -------------------------------------------------------
@@ -432,10 +437,6 @@ cPprTermBase y =
                | pred t    = Just `liftM` f prec t
            ifTerm _ _ _ _  = return Nothing
 
-           isIntegerTy ty  = fromMaybe False $ do
-             (tc,_) <- tcSplitTyConApp_maybe ty 
-             return (tyConName tc == integerTyConName)
-
            isTupleTy ty    = fromMaybe False $ do 
              (tc,_) <- tcSplitTyConApp_maybe ty 
              return (isBoxedTupleTyCon tc)
@@ -444,6 +445,10 @@ cPprTermBase y =
              (tc,_) <- tcSplitTyConApp_maybe ty
              return (a_tc == tc)
 
+           isIntegerTy ty = fromMaybe False $ do
+             (tc,_) <- tcSplitTyConApp_maybe ty
+             return (tyConName tc == integerTyConName)
+
            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 
            --Note pprinting of list terms is not lazy
@@ -710,7 +715,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             -- to subterms is already being done via matching.
             when (not monomorphic) $ do
                let myType = mkFunTys subTermTvs my_ty
-               (signatureType,_) <- instScheme (rttiView $ dataConUserType dc)
+               (signatureType,_) <- instScheme (mydataConType dc)
             -- It is vital for newtype reconstruction that the unification step
             -- is done right here, _before_ the subterms are RTTI reconstructed
                addConstraint myType signatureType
@@ -837,7 +842,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
             -- It is vital for newtype reconstruction that the unification step
             -- is done right here, _before_ the subterms are RTTI reconstructed
             let myType         = mkFunTys subTtypes my_ty
-            (signatureType,_) <- instScheme(rttiView $ dataConUserType dc)
+            (signatureType,_) <- instScheme(mydataConType dc)
             addConstraint myType signatureType
             return $ [ appArr (\e->(t,e)) (ptrs clos) i
                        | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
@@ -849,11 +854,11 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
 -- In particular, we want them to unify with things.
 improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
 improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
-    traceTR $ fsep [text "improveRttiType", ppr _ty, ppr rtti_ty]
+    traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty])
     (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')
+    _ <- getLIE(boxyUnify rtti_ty' ty')
     tvs1_contents     <- zonkTcTyVars ty_tvs'
     let subst = (uncurry zipTopTvSubst . unzip)
                  [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
@@ -868,6 +873,24 @@ myDataConInstArgTys dc args
     | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
     | otherwise = dataConRepArgTys dc
 
+mydataConType :: DataCon -> Type
+-- ^ Custom version of DataCon.dataConUserType where we
+--    - remove the equality constraints
+--    - use the representation types for arguments, including dictionaries
+--    - keep the original result type
+mydataConType  dc
+  = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
+    mkFunTys arg_tys $
+    res_ty
+  where univ_tvs   = dataConUnivTyVars dc
+        ex_tvs     = dataConExTyVars dc
+        eq_spec    = dataConEqSpec dc
+        arg_tys    = [case a of
+                        PredTy p -> predTypeRep p
+                        _        -> a
+                     | a <- dataConRepArgTys dc]
+        res_ty     = dataConOrigResTy dc
+
 isRefType :: Type -> Bool
 isRefType ty
    | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
@@ -1075,7 +1098,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 (boxyUnify ty (repType ty'))
         -- assumes that reptype doesn't ^^^^ touch tyconApp args 
                return ty'
 
@@ -1094,13 +1117,6 @@ zonkTerm = foldTermM TermFoldM{
              }
 
 --------------------------------------------------------------------------------
--- representation types for thetas
-rttiView :: Type -> Type
-rttiView ty | Just ty' <- coreView ty  = rttiView ty'
-rttiView ty
-  | (tvs, theta, tau) <- tcSplitSigmaTy ty
-  =  mkForAllTys tvs (mkFunTys [predTypeRep p | p <- theta, isClassPred p] tau)
-
 -- Restore Class predicates out of a representation type
 dictsView :: Type -> Type
 -- dictsView ty = ty