Massive patch for the first months work adding System FC to GHC #35

Broken up massive patch -=chak
Original log message:  
This is (sadly) all done in one patch to avoid Darcs bugs.
It's not complete work... more FC stuff to come.  A compiler
using just this patch will fail dismally.

compiler/types/Class.lhs

@@ -5,9 +5,11 @@
 
 \begin{code}
 module Class (
-	Class, ClassOpItem, FunDep,
+	Class, ClassOpItem, 
 	DefMeth (..),
 
+	FunDep,	pprFundeps,
+
 	mkClass, classTyVars, classArity,
 	classKey, className, classSelIds, classTyCon, classMethods,
 	classBigSig, classExtraBigSig, classTvsFds, classSCTheta
@@ -159,6 +161,12 @@ instance Outputable DefMeth where
     ppr DefMeth     =  text "{- has default method -}"
     ppr GenDefMeth  =  text "{- has generic method -}"
     ppr NoDefMeth   =  empty   -- No default method
-\end{code}
 
+pprFundeps :: Outputable a => [FunDep a] -> SDoc
+pprFundeps []  = empty
+pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
+	       where
+		 ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), 
+					 interppSP vs]
+\end{code}
 

compiler/types/FunDeps.lhs

@@ -17,8 +17,8 @@ module FunDeps (
 
 import Name		( Name, getSrcLoc )
 import Var		( TyVar )
-import Class		( Class, FunDep, classTvsFds )
-import Unify		( tcUnifyTys, BindFlag(..) )
+import Class		( Class, FunDep, pprFundeps, classTvsFds )
+import TcGadt		( tcUnifyTys, BindFlag(..) )
 import Type		( substTys, notElemTvSubst )
 import TcType		( Type, PredType(..), tcEqType, 
 			  predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred )
@@ -485,17 +485,4 @@ trimRoughMatchTcs clas_tvs (ltvs,_) mb_tcs
 \end{code}
 
 
-%************************************************************************
-%*									*
-\subsection{Miscellaneous}
-%*									*
-%************************************************************************
-
-\begin{code}
-pprFundeps :: Outputable a => [FunDep a] -> SDoc
-pprFundeps [] = empty
-pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
-
-ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs]
-\end{code}
 

compiler/types/InstEnv.lhs

@@ -33,8 +33,10 @@ import TcType		( Type, PredType, tcEqType,
 			  tyClsNamesOfType, tcSplitTyConApp_maybe
 			)
 import TyCon		( tyConName )
-import Unify		( tcMatchTys, tcUnifyTys, BindFlag(..) )
+import TcGadt		( tcUnifyTys, BindFlag(..) )
+import Unify		( tcMatchTys )
 import Outputable
+import BasicTypes	( OverlapFlag(..) )
 import UniqFM		( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM )
 import Id		( idType, idName )
 import SrcLoc		( pprDefnLoc )
@@ -61,7 +63,8 @@ data Instance
 	     , is_tys  :: [Type]	-- Full arg types
 
 	     , is_dfun :: DFunId
-	     , is_flag :: OverlapFlag
+	     , is_flag :: OverlapFlag	-- See detailed comments with
+					-- the decl of BasicTypes.OverlapFlag
 
 	     , is_orph :: Maybe OccName }
 
@@ -213,39 +216,6 @@ instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
 -- False is non-committal
 instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as
 instanceCantMatch ts		as	      =  False	-- Safe
-
----------------------------------------------------
-data OverlapFlag
-  = NoOverlap	-- This instance must not overlap another
-
-  | OverlapOk	-- Silently ignore this instance if you find a 
-		-- more specific one that matches the constraint
-		-- you are trying to resolve
-		--
-		-- Example: constraint (Foo [Int])
-		-- 	    instances  (Foo [Int])
-		--		       (Foo [a])	OverlapOk
-		-- Since the second instance has the OverlapOk flag,
-		-- the first instance will be chosen (otherwise 
-		-- its ambiguous which to choose)
-
-  | Incoherent	-- Like OverlapOk, but also ignore this instance 
-		-- if it doesn't match the constraint you are
-		-- trying to resolve, but could match if the type variables
-		-- in the constraint were instantiated
-		--
-		-- Example: constraint (Foo [b])
-		--	    instances  (Foo [Int])	Incoherent
-		--		       (Foo [a])
-		-- Without the Incoherent flag, we'd complain that
-		-- instantiating 'b' would change which instance 
-		-- was chosen
-  deriving( Eq )
-
-instance Outputable OverlapFlag where
-   ppr NoOverlap  = empty
-   ppr OverlapOk  = ptext SLIT("[overlap ok]")
-   ppr Incoherent = ptext SLIT("[incoherent]")
 \end{code}
 
 

compiler/types/Kind.lhs

-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-
-\begin{code}
-module Kind (
-	Kind(..), SimpleKind, 
-	openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
-	argTypeKind, ubxTupleKind,
-
-	isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
-	isArgTypeKind, isOpenTypeKind,
-	mkArrowKind, mkArrowKinds,
-
-        isSubKind, defaultKind, 
-	kindFunResult, splitKindFunTys, 
-
-	KindVar, mkKindVar, kindVarRef, kindVarUniq, 
-	kindVarOcc, setKindVarOcc,
-
-	pprKind, pprParendKind
-     ) where
-
-#include "HsVersions.h"
-
-import Unique	( Unique )
-import OccName  ( OccName, mkOccName, tvName )
-import Outputable
-import DATA_IOREF
-\end{code}
-
-Kinds
-~~~~~
-There's a little subtyping at the kind level:  
-
-		 ?
-		/ \
-	       /   \
-	      ??   (#)
-	    / | \
-	   *  !  #
-
-where	*    [LiftedTypeKind]   means boxed type
-	#    [UnboxedTypeKind]  means unboxed type
-	(#)  [UbxTupleKind]     means unboxed tuple
-	??   [ArgTypeKind]      is the lub of *,#
-	?    [OpenTypeKind]	means any type at all
-
-In particular:
-
-	error :: forall a:?. String -> a
-	(->)  :: ?? -> ? -> *
-	(\(x::t) -> ...)	Here t::?? (i.e. not unboxed tuple)
-
-\begin{code}
-data Kind 
-  = LiftedTypeKind 	--  *
-  | OpenTypeKind	--  ?
-  | UnboxedTypeKind	--  #
-  | UnliftedTypeKind    --  !
-  | UbxTupleKind	--  (##)
-  | ArgTypeKind		--  ??
-  | FunKind Kind Kind	--  k1 -> k2
-  | KindVar KindVar
-  deriving( Eq )
-
-data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
-  -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
-
-type SimpleKind = Kind	
-  -- A SimpleKind has no ? or # kinds in it:
-  -- sk ::= * | sk1 -> sk2 | kvar
-
-instance Eq KindVar where
-  (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
-
-mkKindVar :: Unique -> IORef (Maybe Kind) -> KindVar
-mkKindVar u r = KVar u kind_var_occ r
-
-kindVarRef :: KindVar -> IORef (Maybe Kind)
-kindVarRef (KVar _ _ ref) = ref
-
-kindVarUniq :: KindVar -> Unique
-kindVarUniq (KVar uniq _ _) = uniq
-
-kindVarOcc :: KindVar -> OccName
-kindVarOcc (KVar _ occ _) = occ
-
-setKindVarOcc :: KindVar -> OccName -> KindVar
-setKindVarOcc (KVar u _ r) occ = KVar u occ r
-
-kind_var_occ :: OccName	-- Just one for all KindVars
-			-- They may be jiggled by tidying
-kind_var_occ = mkOccName tvName "k"
-\end{code}
-
-Kind inference
-~~~~~~~~~~~~~~
-During kind inference, a kind variable unifies only with 
-a "simple kind", sk
-	sk ::= * | sk1 -> sk2
-For example 
-	data T a = MkT a (T Int#)
-fails.  We give T the kind (k -> *), and the kind variable k won't unify
-with # (the kind of Int#).
-
-Type inference
-~~~~~~~~~~~~~~
-When creating a fresh internal type variable, we give it a kind to express 
-constraints on it.  E.g. in (\x->e) we make up a fresh type variable for x, 
-with kind ??.  
-
-During unification we only bind an internal type variable to a type
-whose kind is lower in the sub-kind hierarchy than the kind of the tyvar.
-
-When unifying two internal type variables, we collect their kind constraints by
-finding the GLB of the two.  Since the partial order is a tree, they only
-have a glb if one is a sub-kind of the other.  In that case, we bind the
-less-informative one to the more informative one.  Neat, eh?
-
-
-\begin{code}
-liftedTypeKind   = LiftedTypeKind
-unboxedTypeKind  = UnboxedTypeKind
-unliftedTypeKind = UnliftedTypeKind
-openTypeKind     = OpenTypeKind
-argTypeKind      = ArgTypeKind
-ubxTupleKind	 = UbxTupleKind
-
-mkArrowKind :: Kind -> Kind -> Kind
-mkArrowKind k1 k2 = k1 `FunKind` k2
-
-mkArrowKinds :: [Kind] -> Kind -> Kind
-mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
-\end{code}
-
-%************************************************************************
-%*									*
-	Functions over Kinds		
-%*									*
-%************************************************************************
-
-\begin{code}
-kindFunResult :: Kind -> Kind
-kindFunResult (FunKind _ k) = k
-kindFunResult k = pprPanic "kindFunResult" (ppr k)
-
-splitKindFunTys :: Kind -> ([Kind],Kind)
-splitKindFunTys (FunKind k1 k2) = case splitKindFunTys k2 of
-				    (as, r) -> (k1:as, r)
-splitKindFunTys k = ([], k)
-
-isLiftedTypeKind, isUnliftedTypeKind :: Kind -> Bool
-isLiftedTypeKind LiftedTypeKind = True
-isLiftedTypeKind other		= False
-
-isUnliftedBoxedTypeKind UnliftedTypeKind = True
-isUnliftedBoxedTypeKind other	    = False
-
-isUnliftedTypeKind UnliftedTypeKind = True
-isUnliftedTypeKind UnboxedTypeKind  = True
-isUnliftedTypeKind other	    = False
-
-isArgTypeKind :: Kind -> Bool
--- True of any sub-kind of ArgTypeKind 
-isArgTypeKind LiftedTypeKind   = True
-isArgTypeKind UnliftedTypeKind = True
-isArgTypeKind UnboxedTypeKind  = True
-isArgTypeKind ArgTypeKind      = True
-isArgTypeKind other	       = False
-
-isOpenTypeKind :: Kind -> Bool
--- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
-isOpenTypeKind (FunKind _ _) = False
-isOpenTypeKind (KindVar _)   = False	-- This is a conservative answer
-					-- It matters in the call to isSubKind in
-					-- checkExpectedKind.
-isOpenTypeKind other	     = True
-
-isSubKind :: Kind -> Kind -> Bool
--- (k1 `isSubKind` k2) checks that k1 <: k2
-isSubKind LiftedTypeKind   LiftedTypeKind   = True
-isSubKind UnliftedTypeKind UnliftedTypeKind = True
-isSubKind UnboxedTypeKind  UnboxedTypeKind  = True
-isSubKind UbxTupleKind     UbxTupleKind     = True
-isSubKind k1 		   OpenTypeKind     = isOpenTypeKind k1
-isSubKind k1 		   ArgTypeKind      = isArgTypeKind k1
-isSubKind (FunKind a1 r1) (FunKind a2 r2)   = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
-isSubKind k1		  k2		    = False
-
-defaultKind :: Kind -> Kind
--- Used when generalising: default kind '?' and '??' to '*'
--- 
--- When we generalise, we make generic type variables whose kind is
--- simple (* or *->* etc).  So generic type variables (other than
--- built-in constants like 'error') always have simple kinds.  This is important;
--- consider
---	f x = True
--- We want f to get type
---	f :: forall (a::*). a -> Bool
--- Not 
---	f :: forall (a::??). a -> Bool
--- because that would allow a call like (f 3#) as well as (f True),
---and the calling conventions differ.  This defaulting is done in TcMType.zonkTcTyVarBndr.
-defaultKind OpenTypeKind = LiftedTypeKind
-defaultKind ArgTypeKind  = LiftedTypeKind
-defaultKind kind	 = kind
-\end{code}
-
-
-%************************************************************************
-%*									*
-		Pretty printing
-%*									*
-%************************************************************************
-
-\begin{code}
-instance Outputable KindVar where
-  ppr (KVar uniq occ _) = ppr occ <> ifPprDebug (ppr uniq)
-
-instance Outputable Kind where
-  ppr k = pprKind k
-
-pprParendKind :: Kind -> SDoc
-pprParendKind k@(FunKind _ _) = parens (pprKind k)
-pprParendKind k		      = pprKind k
-
-pprKind (KindVar v)      = ppr v
-pprKind LiftedTypeKind   = ptext SLIT("*")
-pprKind UnliftedTypeKind = ptext SLIT("!")
-pprKind UnboxedTypeKind  = ptext SLIT("#")
-pprKind OpenTypeKind     = ptext SLIT("?")
-pprKind ArgTypeKind      = ptext SLIT("??")
-pprKind UbxTupleKind     = ptext SLIT("(#)")
-pprKind (FunKind k1 k2)  = sep [ pprParendKind k1, arrow <+> pprKind k2]
-
-\end{code}

compiler/types/TyCon.lhs

@@ -14,12 +14,13 @@ module TyCon(
 
 	isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
 	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
-	isEnumerationTyCon, 
+	isEnumerationTyCon, isGadtSyntaxTyCon,
 	isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
-	isRecursiveTyCon, newTyConRep, newTyConRhs, 
-	isHiBootTyCon,
+	isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
+	isHiBootTyCon, isSuperKindTyCon,
+        isCoercionTyCon_maybe, isCoercionTyCon,
 
-	tcExpandTyCon_maybe, coreExpandTyCon_maybe,
+	tcExpandTyCon_maybe, coreExpandTyCon_maybe, stgExpandTyCon_maybe,
 
 	makeTyConAbstract, isAbstractTyCon,
 
@@ -29,9 +30,12 @@ module TyCon(
 	mkClassTyCon,
 	mkFunTyCon,
 	mkPrimTyCon,
+	mkVoidPrimTyCon,
 	mkLiftedPrimTyCon,
 	mkTupleTyCon,
 	mkSynTyCon,
+        mkSuperKindTyCon,
+        mkCoercionTyCon,
 
 	tyConName,
 	tyConKind,
@@ -54,16 +58,11 @@ module TyCon(
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TypeRep ( Type, PredType )
- -- 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 #-} TypeRep ( Kind, Type, Coercion, PredType )
 import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
 
-
 import Var   		( TyVar, Id )
 import Class		( Class )
-import Kind		( Kind )
 import BasicTypes	( Arity, RecFlag(..), Boxity(..), isBoxed )
 import Name		( Name, nameUnique, NamedThing(getName) )
 import PrelNames	( Unique, Uniquable(..) )
@@ -102,6 +101,10 @@ data TyCon
 
 	algTcSelIds :: [Id],  		-- Its record selectors (empty if none): 
 
+	algTcGadtSyntax  :: Bool,	-- True <=> the data type was declared using GADT syntax
+					-- That doesn't mean it's a true GADT; only that the "where"
+					-- 	form was used. This field is used only to guide
+					--	pretty-printinng
 	algTcStupidTheta :: [PredType],	-- The "stupid theta" for the data type
 					-- (always empty for GADTs)
 
@@ -117,8 +120,33 @@ data TyCon
 		-- Just cl if this tycon came from a class declaration
     }
 
+  | TupleTyCon {
+	tyConUnique :: Unique,
+	tyConName   :: Name,
+	tyConKind   :: Kind,
+	tyConArity  :: Arity,
+	tyConBoxed  :: Boxity,
+	tyConTyVars :: [TyVar],
+	dataCon     :: DataCon,
+	hasGenerics :: Bool
+    }
+
+  | SynTyCon {
+	tyConUnique :: Unique,
+	tyConName   :: Name,
+	tyConKind   :: Kind,
+	tyConArity  :: Arity,
+
+	tyConTyVars :: [TyVar],		-- Bound tyvars
+	synTcRhs    :: Type,		-- Right-hand side, mentioning these type vars.
+					-- Acts as a template for the expansion when
+					-- the tycon is applied to some types.
+	argVrcs :: ArgVrcs
+    }
+
   | PrimTyCon {			-- Primitive types; cannot be defined in Haskell
 				-- Now includes foreign-imported types
+                                -- Also includes Kinds
 	tyConUnique   :: Unique,
 	tyConName     :: Name,
 	tyConKind     :: Kind,
@@ -134,29 +162,23 @@ data TyCon
 	tyConExtName :: Maybe FastString	-- Just xx for foreign-imported types
     }
 
-  | TupleTyCon {
+  | CoercionTyCon {	-- E.g. (:=:), sym, trans, left, right
+			-- INVARIANT: coercions are always fully applied
 	tyConUnique :: Unique,
-	tyConName   :: Name,
-	tyConKind   :: Kind,
+        tyConName   :: Name,
 	tyConArity  :: Arity,
-	tyConBoxed  :: Boxity,
-	tyConTyVars :: [TyVar],
-	dataCon     :: DataCon,
-	hasGenerics :: Bool
+	coKindFun   :: [Type] -> Kind
+    }
+	
+  | SuperKindTyCon {    -- Super Kinds, TY (box) and CO (diamond).
+			-- They have no kind; and arity zero
+        tyConUnique :: Unique,
+        tyConName   :: Name
     }
 
-  | SynTyCon {
-	tyConUnique :: Unique,
-	tyConName   :: Name,
-	tyConKind   :: Kind,
-	tyConArity  :: Arity,
+type KindCon = TyCon
 
-	tyConTyVars :: [TyVar],	-- Bound tyvars
-	synTcRhs    :: Type,	-- Right-hand side, mentioning these type vars.
-					-- Acts as a template for the expansion when
-					-- the tycon is applied to some types.
-	argVrcs :: ArgVrcs
-    }
+type SuperKindCon = TyCon
 
 type FieldLabel = Name
 
@@ -183,6 +205,11 @@ data AlgTyConRhs
 
 	nt_rhs :: Type,		-- Cached: the argument type of the constructor
 				--  = the representation type of the tycon
+				-- The free tyvars of this type are the tyConTyVars
+      
+        nt_co :: TyCon,		-- The coercion used to create the newtype
+                                -- from the representation
+				-- See Note [Newtype coercions]
 
 	nt_etad_rhs :: ([TyVar], Type) ,
 			-- The same again, but this time eta-reduced
@@ -211,6 +238,20 @@ visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 \end{code}
 
+Note [Newtype coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~
+
+The NewTyCon field nt_co is a a TyCon (a coercion constructor in fact)
+which is used for coercing from the representation type of the
+newtype, to the newtype itself. For example,
+
+   newtype T a = MkT [a]
+
+the NewTyCon for T will contain nt_co = CoT where CoT t : [t] :=: T t.
+This TyCon is a CoercionTyCon, so it does not have a kind on its own;
+it basically has its own typing rule for the fully-applied version.
+If the newtype T has k type variables then CoT has arity k.
+
 Note [Newtype eta]
 ~~~~~~~~~~~~~~~~~~
 Consider
@@ -304,7 +345,7 @@ mkFunTyCon name kind
 -- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
 -- but now you also have to pass in the generic information about the type
 -- constructor - you can get hold of it easily (see Generics module)
-mkAlgTyCon name kind tyvars argvrcs stupid rhs sel_ids is_rec gen_info
+mkAlgTyCon name kind tyvars argvrcs stupid rhs sel_ids is_rec gen_info gadt_syn
   = AlgTyCon {	
 	tyConName 	 = name,
 	tyConUnique	 = nameUnique name,
@@ -317,6 +358,7 @@ mkAlgTyCon name kind tyvars argvrcs stupid rhs sel_ids is_rec gen_info
 	algTcSelIds	 = sel_ids,
 	algTcClass	 = Nothing,
 	algTcRec	 = is_rec,
+	algTcGadtSyntax  = gadt_syn,
 	hasGenerics = gen_info
     }
 
@@ -333,6 +375,7 @@ mkClassTyCon name kind tyvars argvrcs rhs clas is_rec
 	algTcSelIds	 = [],
 	algTcClass	 = Just clas,
 	algTcRec	 = is_rec,
+	algTcGadtSyntax  = False,	-- Doesn't really matter
 	hasGenerics = False
     }
 
@@ -370,6 +413,9 @@ mkForeignTyCon name ext_name kind arity arg_vrcs
 mkPrimTyCon name kind arity arg_vrcs rep
   = mkPrimTyCon' name kind arity arg_vrcs rep True  
 
+mkVoidPrimTyCon name kind arity arg_vrcs 
+  = mkPrimTyCon' name kind arity arg_vrcs VoidRep True  
+
 -- but RealWorld is lifted
 mkLiftedPrimTyCon name kind arity arg_vrcs rep
   = mkPrimTyCon' name kind arity arg_vrcs rep False
@@ -396,6 +442,21 @@ mkSynTyCon name kind tyvars rhs argvrcs
 	synTcRhs = rhs,
 	argVrcs      = argvrcs
     }
+
+mkCoercionTyCon name arity kindRule
+  = CoercionTyCon {
+        tyConName = name,
+        tyConUnique = nameUnique name,
+        tyConArity = arity,
+        coKindFun = kindRule
+    }
+
+-- Super kinds always have arity zero
+mkSuperKindTyCon name
+  = SuperKindTyCon {
+        tyConName = name,
+        tyConUnique = nameUnique name
+  }
 \end{code}
 
 \begin{code}
@@ -467,6 +528,10 @@ isSynTyCon :: TyCon -> Bool
 isSynTyCon (SynTyCon {}) = True
 isSynTyCon _		 = False
 
+isGadtSyntaxTyCon :: TyCon -> Bool
+isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res
+isGadtSyntaxTyCon other				       = False
+
 isEnumerationTyCon :: TyCon -> Bool
 isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res
 isEnumerationTyCon other				       	       = False
@@ -506,6 +571,18 @@ isForeignTyCon :: TyCon -> Bool
 -- isForeignTyCon identifies foreign-imported type constructors
 isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True
 isForeignTyCon other				   = False
+
+isSuperKindTyCon :: TyCon -> Bool
+isSuperKindTyCon (SuperKindTyCon {}) = True
+isSuperKindTyCon other               = False
+
+isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> Kind)
+isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) 
+  = Just (ar, rule)
+isCoercionTyCon_maybe other = Nothing
+
+isCoercionTyCon (CoercionTyCon {}) = True
+isCoercionTyCon other              = False
 \end{code}
 
 
@@ -527,15 +604,26 @@ tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, synTcRhs = rhs }) tys
 tcExpandTyCon_maybe other_tycon tys = Nothing
 
 ---------------
--- For the *Core* view, we expand synonyms *and* non-recursive newtypes
+-- For the *Core* view, we expand synonyms only as well
+{-
 coreExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive,	-- Not recursive
          algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys
    = case etad_rhs of	-- Don't do this in the pattern match, lest we accidentally
 			-- match the etad_rhs of a *recursive* newtype
 	(tvs,rhs) -> expand tvs rhs tys
-	
+-}
 coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys
 
+---------------
+-- For the *STG* view, we expand synonyms *and* non-recursive newtypes
+stgExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive,	-- Not recursive
+         algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys
+   = case etad_rhs of	-- Don't do this in the pattern match, lest we accidentally
+			-- match the etad_rhs of a *recursive* newtype
+	(tvs,rhs) -> expand tvs rhs tys
+
+stgExpandTyCon_maybe tycon tys = coreExpandTyCon_maybe tycon tys
+
 ----------------
 expand	:: [TyVar] -> Type 			-- Template
 	-> [Type]				-- Args
@@ -593,6 +681,10 @@ newTyConRep :: TyCon -> ([TyVar], Type)
 newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 
+newTyConCo :: TyCon -> TyCon
+newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
+newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
+
 tyConPrimRep :: TyCon -> PrimRep
 tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
 tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep

compiler/types/TypeRep.lhs

@@ -17,29 +17,51 @@ module TypeRep (
 	pprType, pprParendType, pprTyThingCategory,
 	pprPred, pprTheta, pprThetaArrow, pprClassPred,
 
-	-- Re-export fromKind
+	-- Kinds
 	liftedTypeKind, unliftedTypeKind, openTypeKind,
-	isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, 
+        argTypeKind, ubxTupleKind,
+	isLiftedTypeKindCon, isLiftedTypeKind,
 	mkArrowKind, mkArrowKinds,
+
+        -- Kind constructors...
+        liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,