X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=af75ec99ad143f0b0548cefbb36814f5b4ae0d85;hb=71cad0e1783707f325973a537b3b0a74300bd866;hp=3eaadf759f533dbebeab04783778737ebd0b900c;hpb=d5bba9ee196f64a077e922680b16fe6f28fb79db;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 3eaadf7..af75ec9 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -11,7 +11,7 @@ module DataCon (
 	dataConRepType, dataConSig, dataConFullSig,
 	dataConName, dataConTag, dataConTyCon, dataConUserType,
 	dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys,
-	dataConEqSpec, dataConTheta, dataConStupidTheta, 
+	dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, 
 	dataConInstArgTys, dataConOrigArgTys, 
 	dataConInstOrigArgTys, dataConRepArgTys, 
 	dataConFieldLabels, dataConFieldType,
@@ -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}
 
 
@@ -409,7 +412,10 @@ mkDataCon name declared_infix
 	  eq_spec theta
 	  orig_arg_tys tycon
 	  stupid_theta ids
-  = con
+  = ASSERT( not (any isEqPred theta) )
+	-- We don't currently allow any equality predicates on
+	-- a data constructor (apart from the GADT ones in eq_spec)
+    con
   where
     is_vanilla = null ex_tvs && null eq_spec && null theta
     con = ASSERT( is_vanilla || not (isNewTyCon tycon) )
@@ -432,10 +438,9 @@ mkDataCon name declared_infix
 	-- The 'arg_stricts' passed to mkDataCon are simply those for the
 	-- source-language arguments.  We add extra ones for the
 	-- dictionary arguments right here.
-    (more_eq_preds, dict_preds) = partition isEqPred theta
     dict_tys     = mkPredTys theta
     real_arg_tys = dict_tys                      ++ orig_arg_tys
-    real_stricts = map mk_dict_strict_mark dict_preds ++ arg_stricts
+    real_stricts = map mk_dict_strict_mark theta ++ arg_stricts
 
 	-- Representation arguments and demands
 	-- To do: eliminate duplication with MkId
@@ -599,12 +604,13 @@ 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 (MkData {dcOrigArgTys = arg_tys,
+dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
 			       dcUnivTyVars = univ_tvs, 
 			       dcExTyVars = ex_tvs}) inst_tys
- = ASSERT( length tyvars == length inst_tys )
+ = ASSERT2( length tyvars == length inst_tys, ptext SLIT("dataConInstOrigArgTys") <+> ppr dc <+> ppr inst_tys )
    map (substTyWith tyvars inst_tys) arg_tys
  where
    tyvars = univ_tvs ++ ex_tvs
@@ -685,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
@@ -696,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}