Fix GADT refinement fix-pointing, add ASSERTs and a WARN, make type equality function...

[ghc-hetmet.git] / compiler / basicTypes / DataCon.lhs

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 289fdef..5da66d9 100644 (file)
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -23,7 +23,8 @@ module DataCon (
        isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
        isVanillaDataCon, classDataCon, 
 
-       splitProductType_maybe, splitProductType,
+       splitProductType_maybe, splitProductType, deepSplitProductType,
+        deepSplitProductType_maybe
     ) where
 
 #include "HsVersions.h"
@@ -31,16 +32,17 @@ module DataCon (
 import Type            ( Type, ThetaType, 
                          substTyWith, substTyVar, mkTopTvSubst, 
                          mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys, 
-                         splitTyConApp_maybe, 
-                         mkPredTys, isStrictPred, pprType
+                         splitTyConApp_maybe, newTyConInstRhs,
+                         mkPredTys, isStrictPred, pprType, mkPredTy
                        )
 import Coercion                ( isEqPred, mkEqPred )
 import TyCon           ( TyCon, FieldLabel, tyConDataCons, 
                          isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
-                          isNewTyCon )
+                          isNewTyCon, isRecursiveTyCon )
 import Class           ( Class, classTyCon )
-import Name            ( Name, NamedThing(..), nameUnique )
-import Var             ( TyVar, Id )
+import Name            ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName )
++ import Var           ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique,
++                           mkCoVar )
 import BasicTypes      ( Arity, StrictnessMark(..) )
 import Outputable
 import Unique          ( Unique, Uniquable(..) )
@@ -48,6 +50,7 @@ import ListSetOps     ( assoc, minusList )
 import Util            ( zipEqual, zipWithEqual )
 import List            ( partition )
 import Maybes           ( expectJust )
+import FastString
 \end{code}
 
 
@@ -601,6 +604,7 @@ dataConInstArgTys (MkData {dcRepArgTys = arg_tys,
  where
    tyvars = univ_tvs ++ ex_tvs
 
+
 -- And the same deal for the original arg tys
 dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
 dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
@@ -687,6 +691,21 @@ splitProductType str ty
        Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
 
 
+deepSplitProductType_maybe ty
+  = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
+       ; let {result 
+             | isNewTyCon tycon && not (isRecursiveTyCon tycon)
+             = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args)
+             | isNewTyCon tycon = Nothing  -- cannot unbox through recursive newtypes
+             | otherwise = Just res}
+       ; result
+       }
+          
+deepSplitProductType str ty 
+  = case deepSplitProductType_maybe ty of
+      Just stuff -> stuff
+      Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+
 computeRep :: [StrictnessMark]         -- Original arg strictness
           -> [Type]                    -- and types
           -> ([StrictnessMark],        -- Representation arg strictness
@@ -698,6 +717,7 @@ computeRep stricts tys
     unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
     unbox MarkedStrict    ty = [(MarkedStrict,    ty)]
     unbox MarkedUnboxed   ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
-                            where
-                              (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
+                               where
+                                 (tycon, tycon_args, arg_dc, arg_tys) 
+                                     = deepSplitProductType "unbox_strict_arg_ty" ty
 \end{code}