X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=d91effeada8da392126742bd68afd40d621c53e5;hb=b00b5bc04ff36a551552470060064f0b7d84ca30;hp=d536f59a6a79e61abbaa05c72f47ea53bc33edd8;hpb=d5c4754dcb857be7b9f4dbf6482e6050a9cd0991;p=ghc-hetmet.git

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index d536f59..d91effe 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -10,17 +10,20 @@ module TyCon(
 	PrimRep(..),
 	tyConPrimRep,
 
-	AlgTyConRhs(..), visibleDataCons, AlgTyConParent(..),
+	AlgTyConRhs(..), visibleDataCons, 
+        AlgTyConParent(..), hasParent,
 	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,
+        isImplicitTyCon,
 
 	tcExpandTyCon_maybe, coreExpandTyCon_maybe,
 
@@ -60,7 +63,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 )
@@ -100,6 +103,8 @@ data TyCon
 	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
@@ -182,8 +187,10 @@ data TyCon
 	tyConUnique :: Unique,
         tyConName   :: Name,
 	tyConArity  :: Arity,
-	coKindFun   :: [Type] -> Kind
-    }
+	coKindFun   :: [Type] -> (Type,Type)
+    }		-- INVARAINT: coKindFun is always applied to exactly 'arity' args
+		-- E.g. for trans (c1 :: ta=tb) (c2 :: tb=tc), the coKindFun returns 
+		--	the kind as a pair of types: (ta,tc)
 	
   | SuperKindTyCon {    -- Super Kinds, TY (box) and CO (diamond).
 			-- They have no kind; and arity zero
@@ -191,10 +198,6 @@ data TyCon
         tyConName   :: Name
     }
 
-type KindCon = TyCon
-
-type SuperKindCon = TyCon
-
 type FieldLabel = Name
 
 data AlgTyConRhs
@@ -274,6 +277,10 @@ data AlgTyConParent = -- An ordinary type constructor has no parent.
 						-- the representation type
 						-- with the type instance
 
+hasParent :: AlgTyConParent -> Bool
+hasParent NoParentTyCon = False
+hasParent _other        = True
+
 data SynTyConRhs
   = OpenSynTyCon Kind	-- Type family: *result* kind given
   | SynonymTyCon Type   -- Mentioning head type vars.  Acts as a template for
@@ -560,6 +567,14 @@ isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
 					   _	        -> 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
 --	has *one* constructor, 
@@ -648,13 +663,21 @@ isSuperKindTyCon :: TyCon -> Bool
 isSuperKindTyCon (SuperKindTyCon {}) = True
 isSuperKindTyCon other               = False
 
-isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> Kind)
+isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> (Type,Type))
 isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) 
   = Just (ar, rule)
 isCoercionTyCon_maybe other = Nothing
 
+isCoercionTyCon :: TyCon -> Bool
 isCoercionTyCon (CoercionTyCon {}) = True
 isCoercionTyCon other              = False
+
+isImplicitTyCon :: TyCon -> Bool
+isImplicitTyCon SynTyCon{}                     = False
+isImplicitTyCon AlgTyCon{algTcParent = parent} = hasParent parent
+isImplicitTyCon other                          = True
+        -- catches: FunTyCon, TupleTyCon, PrimTyCon, 
+        -- CoercionTyCon, SuperKindTyCon
 \end{code}
 
 
@@ -747,12 +770,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 (AlgTyCon {tyConTyVars = tvs, algTcRhs = OpenNewTyCon})
-  = Nothing
-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
@@ -807,8 +827,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 _}) =