X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=14180b22036bcecf6d4cf106d7eb6646a55c65b2;hb=d70de6f98f9d833adf4c8d68afc17bd1e6493545;hp=189b0da3a8b90a65da9a950addeea627119dda24;hpb=8295d9ca0f3e72e545b35c43a4a2e1e4ec582fb6;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 189b0da..14180b2 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module TyCon(
-	TyCon, KindCon, SuperKindCon,
+	TyCon, KindCon, SuperKindCon, ArgVrcs,
 
 	isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon,
 	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
@@ -19,9 +19,12 @@ module TyCon(
 	mkKindCon,
 	mkSuperKindCon,
 
+	setTyConName,
+
 	tyConKind,
 	tyConUnique,
 	tyConTyVars,
+	tyConArgVrcs_maybe,
 	tyConDataCons,
 	tyConFamilySize,
 	tyConDerivings,
@@ -38,8 +41,11 @@ module TyCon(
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} Type  ( Type, Kind, SuperKind )
-import {-# SOURCE #-} DataCon ( DataCon )
+import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind )
+ -- Should just be Type(Type), but this fails due to bug present up to
+ -- and including 4.02 involving slurping of hi-boot files.  Bug is now fixed.
+
+import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon )
 
 import Class 		( Class )
 import Var   		( TyVar )
@@ -77,8 +83,9 @@ data TyCon
 	tyConKind   :: Kind,
 	tyConArity  :: Arity,
 	
-	tyConTyVars   	:: [TyVar],
-	dataTyConTheta  :: [(Class,[Type])],
+	tyConTyVars   	 :: [TyVar],
+	dataTyConTheta   :: [(Class,[Type])],
+	dataTyConArgVrcs :: ArgVrcs,
 
 	dataCons :: [DataCon],
 		-- Its data constructors, with fully polymorphic types
@@ -104,6 +111,7 @@ data TyCon
 	tyConName    :: Name,
 	tyConKind    :: Kind,
 	tyConArity   :: Arity,
+	primTyConArgVrcs :: ArgVrcs,
 	primTyConRep :: PrimRep
     }
 
@@ -124,10 +132,11 @@ data TyCon
 	tyConKind   :: Kind,
 	tyConArity  :: Arity,
 
-	tyConTyVars :: [TyVar],		-- Bound tyvars
-	synTyConDefn :: Type		-- Right-hand side, mentioning these type vars.
+	tyConTyVars     :: [TyVar],	-- Bound tyvars
+	synTyConDefn    :: Type,	-- Right-hand side, mentioning these type vars.
 					-- Acts as a template for the expansion when
 					-- the tycon is applied to some types.
+	synTyConArgVrcs :: ArgVrcs
     }
 
   | KindCon {		-- Type constructor at the kind level
@@ -141,6 +150,10 @@ data TyCon
 	tyConUnique :: Unique,
 	tyConName   :: Name
     }
+
+type ArgVrcs = [(Bool,Bool)]  -- Tyvar variance info: [(occPos,occNeg)]
+                              -- *NB*: this is tyvar variance info, *not*
+                              --       termvar usage info.
 \end{code}
 
 %************************************************************************
@@ -180,7 +193,7 @@ mkFunTyCon name kind
 	tyConArity  = 2
     }
 			    
-mkAlgTyCon name kind tyvars theta cons derivs maybe_clas flavour rec
+mkAlgTyCon name kind tyvars theta argvrcs cons derivs maybe_clas flavour rec
   = AlgTyCon {	
 	tyConName = name,
 	tyConUnique = nameUnique name,
@@ -188,6 +201,7 @@ mkAlgTyCon name kind tyvars theta cons derivs maybe_clas flavour rec
 	tyConArity = length tyvars,
 	tyConTyVars = tyvars,
 	dataTyConTheta = theta,
+	dataTyConArgVrcs = argvrcs,
 	dataCons = cons,
 	dataTyConDerivings = derivs,
 	dataTyConClass_maybe = maybe_clas,
@@ -206,24 +220,28 @@ mkTupleTyCon name kind arity tyvars con boxed
 	dataCon = con
     }
 
-mkPrimTyCon name kind arity rep 
+mkPrimTyCon name kind arity arg_vrcs rep 
   = PrimTyCon {
 	tyConName = name,
 	tyConUnique = nameUnique name,
 	tyConKind = kind,
 	tyConArity = arity,
+        primTyConArgVrcs = arg_vrcs,
 	primTyConRep = rep
     }
 
-mkSynTyCon name kind arity tyvars rhs 
+mkSynTyCon name kind arity tyvars rhs argvrcs
   = SynTyCon {	
 	tyConName = name,
 	tyConUnique = nameUnique name,
 	tyConKind = kind,
 	tyConArity = arity,
 	tyConTyVars = tyvars,
-	synTyConDefn = rhs
+	synTyConDefn = rhs,
+	synTyConArgVrcs = argvrcs
     }
+
+setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name}
 \end{code}
 
 \begin{code}
@@ -258,10 +276,16 @@ isDataTyCon other = False
 isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True 
 isNewTyCon other			          = False
 
--- A "product" tycon is non-recursive and has one constructor,
+-- A "product" tycon is 
+--	non-recursive 
+--	has one constructor, 
+--	is *not* existential
+--	is *not* an unboxed tuple
 -- whether DataType or NewType
-isProductTyCon (AlgTyCon {dataCons = [c], algTyConRec = NonRecursive}) = True
-isProductTyCon (TupleTyCon {}) = True
+isProductTyCon (AlgTyCon {dataCons = [data_con], algTyConRec = NonRecursive}) 
+  = not (isExistentialDataCon data_con)
+isProductTyCon (TupleTyCon { tyConBoxed = boxed }) 
+  = boxed
 isProductTyCon other = False
 
 isSynTyCon (SynTyCon {}) = True
@@ -311,6 +335,21 @@ tyConTheta (AlgTyCon {dataTyConTheta = theta}) = theta
 -- should ask about anything else
 \end{code}
 
+@tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for
+each tyvar, if available.  See @calcAlgTyConArgVrcs@ for how this is
+actually computed (in another file).
+
+\begin{code}
+tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs
+
+tyConArgVrcs_maybe (FunTyCon   {}                     ) = Just [(False,True),(True,False)]
+tyConArgVrcs_maybe (AlgTyCon   {dataTyConArgVrcs = oi}) = Just oi
+tyConArgVrcs_maybe (PrimTyCon  {primTyConArgVrcs = oi}) = Just oi
+tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity   }) = Just (replicate arity (True,False))
+tyConArgVrcs_maybe (SynTyCon   {synTyConArgVrcs = oi }) = Just oi
+tyConArgVrcs_maybe _                                    = Nothing
+\end{code}
+
 \begin{code}
 getSynTyConDefn :: TyCon -> ([TyVar], Type)
 getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,ty)
@@ -322,6 +361,9 @@ maybeTyConSingleCon (AlgTyCon {dataCons = [c]})  = Just c
 maybeTyConSingleCon (AlgTyCon {})	         = Nothing
 maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con
 maybeTyConSingleCon (PrimTyCon {})               = Nothing
+maybeTyConSingleCon (FunTyCon {})                = Nothing  -- case at funty
+maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $
+                         ppr tc
 \end{code}
 
 \begin{code}