X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=40cfa069b7a68f737d6ac27502b0e03166dc2287;hb=feb584b7ffd49827ff2b6e716965cfdcd344570e;hp=5ded0a8c7ca05da795113f7506adff9935a68fb6;hpb=909d2dd885f5eebaf7c12cf15d5ac153d646566e;p=ghc-hetmet.git

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 5ded0a8..40cfa06 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -15,7 +15,8 @@ module TyCon(
 
 	isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
 	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
-	isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
+	isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isAssocTyCon,
+	makeTyConAssoc,
 	isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
 	isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
 	isHiBootTyCon, isSuperKindTyCon,
@@ -94,11 +95,14 @@ data TyCon
 	tyConName   :: Name,
 	tyConKind   :: Kind,
 	tyConArity  :: Arity,
-	
+
 	tyConTyVars :: [TyVar],		-- Scopes over (a) the algTcStupidTheta
 					--	       (b) the cached types in
 					--		   algTyConRhs.NewTyCon
 					-- But not over the data constructors
+
+        tyConIsAssoc :: Bool,           -- for families: declared in a class?
+	
 	algTcSelIds :: [Id],  		-- Its record selectors (empty if none)
 
 	algTcGadtSyntax  :: Bool,	-- True <=> the data type was declared using GADT syntax
@@ -133,13 +137,14 @@ data TyCon
     }
 
   | SynTyCon {
-	tyConUnique :: Unique,
-	tyConName   :: Name,
-	tyConKind   :: Kind,
-	tyConArity  :: Arity,
-
-	tyConTyVars :: [TyVar],		-- Bound tyvars
-	synTcRhs    :: SynTyConRhs	-- Expanded type in here
+	tyConUnique  :: Unique,
+	tyConName    :: Name,
+	tyConKind    :: Kind,
+	tyConArity   :: Arity,
+
+	tyConTyVars  :: [TyVar],	-- Bound tyvars
+        tyConIsAssoc :: Bool,           -- for families: declared in a class?
+	synTcRhs     :: SynTyConRhs	-- Expanded type in here
     }
 
   | PrimTyCon {			-- Primitive types; cannot be defined in Haskell
@@ -399,6 +404,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
 	tyConKind	 = kind,
 	tyConArity	 = length tyvars,
 	tyConTyVars	 = tyvars,
+	tyConIsAssoc	 = False,
 	algTcStupidTheta = stupid,
 	algTcRhs         = rhs,
 	algTcSelIds	 = sel_ids,
@@ -468,6 +474,7 @@ mkSynTyCon name kind tyvars rhs
 	tyConKind = kind,
 	tyConArity = length tyvars,
 	tyConTyVars = tyvars,
+	tyConIsAssoc = False,
 	synTcRhs = rhs
     }
 
@@ -573,6 +580,16 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
 isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon  }) = True
 isOpenTyCon _					   = False
 
+isAssocTyCon :: TyCon -> Bool
+isAssocTyCon (AlgTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon (SynTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon _                                     = False
+
+makeTyConAssoc :: TyCon -> TyCon
+makeTyConAssoc tc@(AlgTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc@(SynTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc = pprPanic "makeTyConAssoc" (ppr tc)
+
 isTupleTyCon :: TyCon -> Bool
 -- The unit tycon didn't used to be classed as a tuple tycon
 -- but I thought that was silly so I've undone it