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

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 5ded0a8..51bc1f1 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -14,10 +14,12 @@ module TyCon(
 	SynTyConRhs(..),
 
 	isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
-	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
+	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isClosedNewTyCon,
+	isPrimTyCon, 
 	isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
+	assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
 	isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
-	isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
+	isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo_maybe,
 	isHiBootTyCon, isSuperKindTyCon,
         isCoercionTyCon_maybe, isCoercionTyCon,
 
@@ -59,7 +61,7 @@ module TyCon(
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TypeRep ( Kind, Type, Coercion, PredType )
+import {-# SOURCE #-} TypeRep ( Kind, Type, PredType )
 import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
 
 import Var   		( TyVar, Id )
@@ -67,6 +69,7 @@ import Class		( Class )
 import BasicTypes	( Arity, RecFlag(..), Boxity(..), isBoxed )
 import Name		( Name, nameUnique, NamedThing(getName) )
 import PrelNames	( Unique, Uniquable(..) )
+import Maybe		( isJust )
 import Maybes		( orElse )
 import Outputable
 import FastString
@@ -94,11 +97,21 @@ data TyCon
 	tyConName   :: Name,
 	tyConKind   :: Kind,
 	tyConArity  :: Arity,
-	
+
 	tyConTyVars :: [TyVar],		-- Scopes over (a) the algTcStupidTheta
 					--	       (b) the cached types in
 					--		   algTyConRhs.NewTyCon
+					--	       (c) the family instance
+					--		   types if present
 					-- But not over the data constructors
+
+        tyConArgPoss :: Maybe [Int],    -- for associated families: for each
+					-- tyvar in the AT decl, gives the
+					-- position of that tyvar in the class
+					-- argument list (starting from 0).
+					-- NB: Length is less than tyConArity
+					--     if higher kind signature.
+	
 	algTcSelIds :: [Id],  		-- Its record selectors (empty if none)
 
 	algTcGadtSyntax  :: Bool,	-- True <=> the data type was declared using GADT syntax
@@ -133,13 +146,21 @@ 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
+
+        tyConArgPoss :: Maybe [Int],    -- for associated families: for each
+					-- tyvar in the AT decl, gives the
+					-- position of that tyvar in the class
+					-- argument list (starting from 0).
+					-- NB: Length is less than tyConArity
+					--     if higher kind signature.
+	
+	synTcRhs     :: SynTyConRhs	-- Expanded type in here
     }
 
   | PrimTyCon {			-- Primitive types; cannot be defined in Haskell
@@ -173,10 +194,6 @@ data TyCon
         tyConName   :: Name
     }
 
-type KindCon = TyCon
-
-type SuperKindCon = TyCon
-
 type FieldLabel = Name
 
 data AlgTyConRhs
@@ -399,6 +416,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
 	tyConKind	 = kind,
 	tyConArity	 = length tyvars,
 	tyConTyVars	 = tyvars,
+	tyConArgPoss	 = Nothing,
 	algTcStupidTheta = stupid,
 	algTcRhs         = rhs,
 	algTcSelIds	 = sel_ids,
@@ -468,6 +486,7 @@ mkSynTyCon name kind tyvars rhs
 	tyConKind = kind,
 	tyConArity = length tyvars,
 	tyConTyVars = tyvars,
+	tyConArgPoss = Nothing,
 	synTcRhs = rhs
     }
 
@@ -530,13 +549,23 @@ isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})
 	OpenNewTyCon  -> False
 	NewTyCon {}   -> False
 	AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
-
 isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
 isDataTyCon other = False
 
 isNewTyCon :: TyCon -> Bool
-isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True 
-isNewTyCon other			       = False
+isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
+					   OpenNewTyCon -> True
+					   NewTyCon {}  -> True
+					   _	        -> False
+isNewTyCon other			= False
+
+-- This is an important refinement as typical newtype optimisations do *not*
+-- hold for newtype families.  Why?  Given a type `T a', if T is a newtype
+-- family, there is no unique right hand side by which `T a' can be replaced
+-- by a cast.
+--
+isClosedNewTyCon :: TyCon -> Bool
+isClosedNewTyCon tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
 
 isProductTyCon :: TyCon -> Bool
 -- A "product" tycon
@@ -573,6 +602,19 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
 isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon  }) = True
 isOpenTyCon _					   = False
 
+assocTyConArgPoss_maybe :: TyCon -> Maybe [Int]
+assocTyConArgPoss_maybe (AlgTyCon { tyConArgPoss = poss }) = poss
+assocTyConArgPoss_maybe (SynTyCon { tyConArgPoss = poss }) = poss
+assocTyConArgPoss_maybe _                                  = Nothing
+
+isTyConAssoc :: TyCon -> Bool
+isTyConAssoc = isJust . assocTyConArgPoss_maybe
+
+setTyConArgPoss :: TyCon -> [Int] -> TyCon
+setTyConArgPoss tc@(AlgTyCon {}) poss = tc { tyConArgPoss = Just poss }
+setTyConArgPoss tc@(SynTyCon {}) poss = tc { tyConArgPoss = Just poss }
+setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (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
@@ -712,9 +754,9 @@ newTyConRep :: TyCon -> ([TyVar], Type)
 newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 
-newTyConCo :: TyCon -> Maybe TyCon
-newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
-newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
+newTyConCo_maybe :: TyCon -> Maybe TyCon
+newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co
+newTyConCo_maybe _						 = Nothing
 
 tyConPrimRep :: TyCon -> PrimRep
 tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
@@ -769,8 +811,8 @@ tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
 tyConClass_maybe ther_tycon				    = Nothing
 
 isFamInstTyCon :: TyCon -> Bool
-isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _}) = True
-isFamInstTyCon other_tycon			            = False
+isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True
+isFamInstTyCon other_tycon			             = False
 
 tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
 tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) =