X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=befc4e6f938bfe3c0d7c3b27e002aa9bc3b23ad0;hb=d52cb8fdc74b2ad74be5940cdbd549fedb2835ca;hp=fdd21be02b95ec23c3c3b7f739ca60bc76120091;hpb=46934dd87e13143ec2e97f075309a9e2c0945889;p=ghc-hetmet.git

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index fdd21be..befc4e6 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -39,6 +39,7 @@ module TyCon(
         isCoercionTyCon, isCoercionTyCon_maybe,
         isForeignTyCon,
 
+	isInjectiveTyCon,
 	isDataTyCon, isProductTyCon, isEnumerationTyCon, 
 	isNewTyCon, isAbstractTyCon, isOpenTyCon,
         isUnLiftedTyCon,
@@ -55,7 +56,6 @@ module TyCon(
 	tyConTyVars,
 	tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe,
 	tyConFamilySize,
-	tyConSelIds,
 	tyConStupidTheta,
 	tyConArity,
 	tyConClass_maybe,
@@ -146,8 +146,6 @@ data TyCon
 					--
 					-- Note that it does /not/ scope over the data constructors.
 
-	algTcSelIds :: [Id],  		-- ^ The record selectors of this type (possibly emptys)
-
 	algTcGadtSyntax  :: Bool,	-- ^ Was the data type declared with GADT syntax? If so,
 					-- that doesn't mean it's a true GADT; only that the "where"
 					-- 	form was used. This field is used only to guide
@@ -574,13 +572,12 @@ mkAlgTyCon :: Name
            -> [TyVar]           -- ^ 'TyVar's scoped over: see 'tyConTyVars'. Arity is inferred from the length of this list
            -> [PredType]        -- ^ Stupid theta: see 'algTcStupidTheta'
            -> AlgTyConRhs       -- ^ Information about dat aconstructors
-           -> [Id]              -- ^ Selector 'Id's
            -> TyConParent
            -> RecFlag           -- ^ Is the 'TyCon' recursive?
            -> Bool              -- ^ Does it have generic functions? See 'hasGenerics'
            -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?
            -> TyCon
-mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
+mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn
   = AlgTyCon {	
 	tyConName 	 = name,
 	tyConUnique	 = nameUnique name,
@@ -589,7 +586,6 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
 	tyConTyVars	 = tyvars,
 	algTcStupidTheta = stupid,
 	algTcRhs         = rhs,
-	algTcSelIds	 = sel_ids,
 	algTcParent	 = ASSERT( okParent name parent ) parent,
 	algTcRec	 = is_rec,
 	algTcGadtSyntax  = gadt_syn,
@@ -599,7 +595,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
 -- | Simpler specialization of 'mkAlgTyCon' for classes
 mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
 mkClassTyCon name kind tyvars rhs clas is_rec =
-  mkAlgTyCon name kind tyvars [] rhs [] (ClassTyCon clas) is_rec False False
+  mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False
 
 mkTupleTyCon :: Name 
              -> Kind    -- ^ Kind of the resulting 'TyCon'
@@ -816,9 +812,20 @@ isEnumerationTyCon _                                                   = False
 
 -- | Is this a 'TyCon', synonym or otherwise, that may have further instances appear?
 isOpenTyCon :: TyCon -> Bool
-isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _ _}) = True
-isOpenTyCon (AlgTyCon {algTcRhs = OpenTyCon {}    }) = True
-isOpenTyCon _					     = False
+isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon {}}) = True
+isOpenTyCon (AlgTyCon {algTcRhs = OpenTyCon {}})    = True
+isOpenTyCon _					    = False
+
+-- | Injective 'TyCon's can be decomposed, so that
+--     T ty1 ~ T ty2  =>  ty1 ~ ty2
+isInjectiveTyCon :: TyCon -> Bool
+isInjectiveTyCon tc = not (isSynTyCon tc)
+	-- Ultimately we may have injective associated types
+        -- in which case this test will become more interesting
+	--
+	-- It'd be unusual to call isInjectiveTyCon on a regular H98
+	-- type synonym, because you should probably have expanded it first
+	-- But regardless, it's not injective!
 
 -- | Extract the mapping from 'TyVar' indexes to indexes in the corresponding family
 -- argument lists form an open 'TyCon' of any sort, if the given 'TyCon' is indeed
@@ -959,7 +966,7 @@ tcExpandTyCon_maybe _ _ = Nothing
 
 -- ^ Used to create the view /Core/ has on 'TyCon's. We expand not only closed synonyms like 'tcExpandTyCon_maybe',
 -- but also non-recursive @newtype@s
-coreExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive,	-- Not recursive
+coreExpandTyCon_maybe (AlgTyCon {
          algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys
    = case etad_rhs of	-- Don't do this in the pattern match, lest we accidentally
 			-- match the etad_rhs of a *recursive* newtype
@@ -1013,11 +1020,6 @@ tyConFamilySize (AlgTyCon   {algTcRhs = OpenTyCon {}})                 = 0
 tyConFamilySize (TupleTyCon {})	 		                       = 1
 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
 
--- | Extract the record selector 'Id's from an algebraic 'TyCon' and returns the empty list otherwise
-tyConSelIds :: TyCon -> [Id]
-tyConSelIds (AlgTyCon {algTcSelIds = fs}) = fs
-tyConSelIds _                             = []
-
 -- | Extract an 'AlgTyConRhs' with information about data constructors from an algebraic or tuple
 -- 'TyCon'. Panics for any other sort of 'TyCon'
 algTyConRhs :: TyCon -> AlgTyConRhs