Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-constraint-solver

Conflicts:
	compiler/coreSyn/CoreLint.lhs
	compiler/iface/BinIface.hs
	compiler/prelude/TysPrim.lhs
	compiler/simplCore/Simplify.lhs
	compiler/typecheck/TcCanonical.lhs
	compiler/typecheck/TcInteract.lhs
	compiler/typecheck/TcMType.lhs
	compiler/typecheck/TcSMonad.lhs

126 files changed, 5815 insertions, 3865 deletions

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index 1f42d252ce..c6226cac67 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -588,6 +588,7 @@ data HsBang = HsNoBang
 	    | HsUnpackFailed   -- An UNPACK pragma that we could not make 
 	      		       -- use of, because the type isn't unboxable; 
                                -- equivalant to HsStrict except for checkValidDataCon
+            | HsNoUnpack       -- {-# NOUNPACK #-} ! (GHC extension, meaning "strict but not unboxed")
   deriving (Eq, Data, Typeable)
 
 instance Outputable HsBang where
@@ -595,6 +596,7 @@ instance Outputable HsBang where
     ppr HsStrict       = char '!'
     ppr HsUnpack       = ptext (sLit "{-# UNPACK #-} !")
     ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")
+    ppr HsNoUnpack     = ptext (sLit "{-# NOUNPACK #-} !")
 
 isBanged :: HsBang -> Bool
 isBanged HsNoBang = False
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index cd7a2e1df3..c2cf0bfcdd 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -953,6 +953,7 @@ computeRep stricts tys
   where
     unbox HsNoBang       ty = [(NotMarkedStrict, ty)]
     unbox HsStrict       ty = [(MarkedStrict,    ty)]
+    unbox HsNoUnpack     ty = [(MarkedStrict,    ty)]
     unbox HsUnpackFailed ty = [(MarkedStrict,    ty)]
     unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
                       where
diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs
index 7fef7c7f5e..417444542a 100644
--- a/compiler/basicTypes/Literal.lhs
+++ b/compiler/basicTypes/Literal.lhs
@@ -143,7 +143,9 @@ easier to write RULEs for them.
    in TcIface.
 
  * When looking for CAF-hood (in TidyPgm), we must take account of the
-   CAF-hood of the mk_integer field in LitInteger; see TidyPgm.cafRefsL
+   CAF-hood of the mk_integer field in LitInteger; see TidyPgm.cafRefsL.
+   Indeed this is the only reason we put the mk_integer field in the 
+   literal -- otherwise we could just look it up in CorePrep.
 
 
 Binary instance
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 07ecc85ba7..a40d46f8a9 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -1024,7 +1024,7 @@ voidArgId       -- :: State# RealWorld
 coercionTokenId :: Id 	      -- :: () ~ ()
 coercionTokenId -- Used to replace Coercion terms when we go to STG
   = pcMiscPrelId coercionTokenName 
-                 (mkTyConApp eqPrimTyCon [unitTy, unitTy])
+                 (mkTyConApp eqPrimTyCon [liftedTypeKind, unitTy, unitTy])
                  noCafIdInfo
 \end{code}
 
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index a48a7d44bd..fa8635091d 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -53,6 +53,7 @@ module OccName (
         mkDFunOcc,
 	mkTupleOcc, 
 	setOccNameSpace,
+        demoteOccName,
 
 	-- ** Derived 'OccName's
         isDerivedOccName,
@@ -204,8 +205,35 @@ pprNameSpaceBrief DataName  = char 'd'
 pprNameSpaceBrief VarName   = char 'v'
 pprNameSpaceBrief TvName    = ptext (sLit "tv")
 pprNameSpaceBrief TcClsName = ptext (sLit "tc")
+
+-- demoteNameSpace lowers the NameSpace if possible.  We can not know
+-- in advance, since a TvName can appear in an HsTyVar.
+-- see Note [Demotion]
+demoteNameSpace :: NameSpace -> Maybe NameSpace
+demoteNameSpace VarName = Nothing
+demoteNameSpace DataName = Nothing
+demoteNameSpace TvName = Nothing
+demoteNameSpace TcClsName = Just DataName
 \end{code}
 
+Note [Demotion]
+~~~~~~~~~~~~~~~
+
+When the user writes:
+  data Nat = Zero | Succ Nat
+  foo :: f Zero -> Int
+
+'Zero' in the type signature of 'foo' is parsed as:
+  HsTyVar ("Zero", TcClsName)
+
+When the renamer hits this occurence of 'Zero' it's going to realise
+that it's not in scope. But because it is renaming a type, it knows
+that 'Zero' might be a promoted data constructor, so it will demote
+its namespace to DataName and do a second lookup.
+
+The final result (after the renamer) will be:
+  HsTyVar ("Zero", DataName)
+
 
 %************************************************************************
 %*									*
@@ -316,6 +344,13 @@ mkClsOcc = mkOccName clsName
 
 mkClsOccFS :: FastString -> OccName
 mkClsOccFS = mkOccNameFS clsName
+
+-- demoteOccName lowers the Namespace of OccName.
+-- see Note [Demotion]
+demoteOccName :: OccName -> Maybe OccName
+demoteOccName (OccName space name) = do
+  space' <- demoteNameSpace space
+  return $ OccName space' name
 \end{code}
 
 
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index ba09d923b8..0353e65d04 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -40,7 +40,7 @@ module RdrName (
 	nameRdrName, getRdrName, 
 
 	-- ** Destruction
-	rdrNameOcc, rdrNameSpace, setRdrNameSpace,
+	rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName,
 	isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, 
 	isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
 
@@ -159,6 +159,14 @@ setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
 setRdrNameSpace (Exact n)    ns = ASSERT( isExternalName n ) 
 		       	          Orig (nameModule n)
 				       (setOccNameSpace ns (nameOccName n))
+
+-- demoteRdrName lowers the NameSpace of RdrName.
+-- see Note [Demotion] in OccName
+demoteRdrName :: RdrName -> Maybe RdrName
+demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)
+demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)
+demoteRdrName (Orig _ _) = panic "demoteRdrName"
+demoteRdrName (Exact _) = panic "demoteRdrName"
 \end{code}
 
 \begin{code}
diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index a923f4d9dd..1692520858 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -39,7 +39,7 @@
 
 module Var (
         -- * The main data type and synonyms
-        Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId,
+        Var, TyVar, CoVar, Id, KindVar, DictId, DFunId, EvVar, EqVar, EvId, IpId,
 
 	-- ** Taking 'Var's apart
 	varName, varUnique, varType, 
@@ -60,20 +60,21 @@ module Var (
 	mustHaveLocalBinding,
 
 	-- ** Constructing 'TyVar's
-	mkTyVar, mkTcTyVar, 
+	mkTyVar, mkTcTyVar, mkKindVar,
 
 	-- ** Taking 'TyVar's apart
         tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
 
 	-- ** Modifying 'TyVar's
-	setTyVarName, setTyVarUnique, setTyVarKind
+	setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind,
+        updateTyVarKindM
 
     ) where
 
 #include "HsVersions.h"
 #include "Typeable.h"
 
-import {-# SOURCE #-}	TypeRep( Type, Kind )
+import {-# SOURCE #-}	TypeRep( Type, Kind, SuperKind )
 import {-# SOURCE #-}	TcType( TcTyVarDetails, pprTcTyVarDetails )
 import {-# SOURCE #-}	IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails )
 
@@ -98,7 +99,10 @@ import Data.Data
 
 \begin{code}
 type Id    = Var       -- A term-level identifier
-type TyVar = Var
+
+type TyVar   = Var     -- Type *or* kind variable
+type KindVar = Var     -- Definitely a kind variable
+     	       	       -- See Note [Kind and type variables]
 
 -- See Note [Evidence: EvIds and CoVars]
 type EvId   = Id        -- Term-level evidence: DictId, IpId, or EqVar
@@ -125,6 +129,16 @@ Note [Evidence: EvIds and CoVars]
 * Only CoVars can occur in Coercions (but NB the LCoercion hack; see
   Note [LCoercions] in Coercion).
 
+Note [Kind and type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before kind polymorphism, TyVar were used to mean type variables. Now
+they are use to mean kind *or* type variables. KindVar is used when we
+know for sure that it is a kind variable. In future, we might want to
+go over the whole compiler code to use:
+   - KiTyVar to mean kind or type variables
+   - TyVar   to mean         type variables only
+   - KindVar to mean kind         variables
+
 
 %************************************************************************
 %*									*
@@ -142,7 +156,8 @@ in its @VarDetails@.
 -- | Essentially a typed 'Name', that may also contain some additional information
 -- about the 'Var' and it's use sites.
 data Var
-  = TyVar {
+  = TyVar {  -- type and kind variables
+             -- see Note [Kind and type variables]
 	varName    :: !Name,
 	realUnique :: FastInt,		-- Key for fast comparison
 					-- Identical to the Unique in the name,
@@ -195,7 +210,8 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
 
 \begin{code}
 instance Outputable Var where
-  ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
+  ppr var = ifPprDebug (text "(") <+> ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
+            <+> ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")")
 
 ppr_debug :: Var -> SDoc
 ppr_debug (TyVar {})                           = ptext (sLit "tv")
@@ -255,7 +271,7 @@ setVarType id ty = id { varType = ty }
 
 %************************************************************************
 %*									*
-\subsection{Type variables}
+\subsection{Type and kind variables}
 %*									*
 %************************************************************************
 
@@ -274,6 +290,14 @@ setTyVarName   = setVarName
 
 setTyVarKind :: TyVar -> Kind -> TyVar
 setTyVarKind tv k = tv {varType = k}
+
+updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar
+updateTyVarKind update tv = tv {varType = update (tyVarKind tv)}
+
+updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar
+updateTyVarKindM update tv
+  = do { k' <- update (tyVarKind tv)
+       ; return $ tv {varType = k'} }
 \end{code}
 
 \begin{code}
@@ -298,6 +322,15 @@ tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
 
 setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
 setTcTyVarDetails tv details = tv { tc_tv_details = details }
+
+mkKindVar :: Name -> SuperKind -> KindVar
+-- mkKindVar take a SuperKind as argument because we don't have access
+-- to tySuperKind here.
+mkKindVar name kind = TyVar
+  { varName    = name
+  , realUnique = getKeyFastInt (nameUnique name)
+  , varType    = kind }
+
 \end{code}
 
 %************************************************************************
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index 23708fe568..6fe934b54c 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -811,7 +811,7 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
         (CmmLit $ mkIntCLit 0)
 
     let arr = CmmReg (CmmLocal arr_r)
-    emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr
+    emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS
     stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
                                       oFFSET_StgMutArrPtrs_ptrs)) n
     stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 8935d56537..f8cc4256f4 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -877,7 +877,7 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
         (CmmLit $ mkIntCLit 0)
 
     let arr = CmmReg (CmmLocal arr_r)
-    emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr
+    emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS
     emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
                                     oFFSET_StgMutArrPtrs_ptrs)) n
     emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 63661ec081..f8565cb4c8 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -139,18 +139,18 @@ Note [exprArity invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 exprArity has the following invariant:
 
-  * If typeArity (exprType e) = n,
-    then manifestArity (etaExpand e n) = n
+  (1) If typeArity (exprType e) = n,
+      then manifestArity (etaExpand e n) = n
  
-    That is, etaExpand can always expand as much as typeArity says
-    So the case analysis in etaExpand and in typeArity must match
+      That is, etaExpand can always expand as much as typeArity says
+      So the case analysis in etaExpand and in typeArity must match
  
-  * exprArity e <= typeArity (exprType e)      
+  (2) exprArity e <= typeArity (exprType e)      
 
-  * Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n
+  (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n
 
-    That is, if exprArity says "the arity is n" then etaExpand really 
-    can get "n" manifest lambdas to the top.
+      That is, if exprArity says "the arity is n" then etaExpand really 
+      can get "n" manifest lambdas to the top.
 
 Why is this important?  Because 
   - In TidyPgm we use exprArity to fix the *final arity* of 
@@ -561,12 +561,17 @@ type CheapFun = CoreExpr -> Maybe Type -> Bool
 arityType :: CheapFun -> CoreExpr -> ArityType
 
 arityType cheap_fn (Cast e co)
-  = arityType cheap_fn e
-    `andArityType` ATop (typeArity (pSnd (coercionKind co)))
-    -- See Note [exprArity invariant]; must be true of
+  = case arityType cheap_fn e of
+      ATop os -> ATop (take co_arity os)
+      ABot n  -> ABot (n `min` co_arity)
+  where
+    co_arity = length (typeArity (pSnd (coercionKind co)))
+    -- See Note [exprArity invariant] (2); must be true of
     -- arityType too, since that is how we compute the arity
     -- of variables, and they in turn affect result of exprArity
     -- Trac #5441 is a nice demo
+    -- However, do make sure that ATop -> ATop and ABot -> ABot!
+    --   Casts don't affect that part. Getting this wrong provoked #5475
 
 arityType _ (Var v)
   | Just strict_sig <- idStrictness_maybe v
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index d8b26da1c1..7bd61fa351 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -218,11 +218,13 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
 %************************************************************************
 
 \begin{code}
-type InType      = Type	-- Substitution not yet applied
+--type InKind      = Kind	-- Substitution not yet applied
+type InType      = Type	
 type InCoercion  = Coercion
 type InVar       = Var
 type InTyVar     = TyVar
 
+type OutKind     = Kind	-- Substitution has been applied to this
 type OutType     = Type	-- Substitution has been applied to this
 type OutCoercion = Coercion
 type OutVar      = Var
@@ -296,6 +298,7 @@ lintCoreExpr (Let (Rec pairs) body)
     (_, dups) = removeDups compare bndrs
 
 lintCoreExpr e@(App _ _)
+{- DV: This grievous hack (from ghc-constraint-solver should not be needed: 
     | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments
                    -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds,
                    -- we should do this properly
@@ -309,6 +312,7 @@ lintCoreExpr e@(App _ _)
          
          lintCoreArg (mkCoercionType arg_ty1' arg_ty2' `mkFunTy` mkEqPred (arg_ty1', arg_ty2')) co_e
     | otherwise
+-}
     = do { fun_ty <- lintCoreExpr fun
          ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
   where
@@ -370,6 +374,27 @@ lintCoreExpr (Coercion co)
        ; return (mkCoercionType ty1 ty2) }
 \end{code}
 
+Note [Kind instantiation in coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consider the following coercion axiom:
+  ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa
+
+Consider the following instantiation:
+  ax_co <* -> *> <Monad>
+
+We need to split the co_ax_tvs into kind and type variables in order
+to find out the coercion kind instantiations. Those can only be Refl
+since we don't have kind coercions. This is just a way to represent
+kind instantiation.
+
+We use the number of kind variables to know how to split the coercions
+instantiations between kind coercions and type coercions. We lint the
+kind coercions and produce the following substitution which is to be
+applied in the type variables:
+  k_ag   ~~>   * -> *
+
+
 %************************************************************************
 %*									*
 \subsection[lintCoreArgs]{lintCoreArgs}
@@ -432,10 +457,14 @@ lintValApp arg fun_ty arg_ty
 checkTyKind :: OutTyVar -> OutType -> LintM ()
 -- Both args have had substitution applied
 checkTyKind tyvar arg_ty
+  | isSuperKind tyvar_kind  -- kind forall
+  -- IA0_NOTE: I added this case to handle kind foralls
+  = lintKind arg_ty
 	-- Arg type might be boxed for a function with an uncommitted
 	-- tyvar; notably this is used so that we can give
 	-- 	error :: forall a:*. String -> a
 	-- and then apply it to both boxed and unboxed types.
+  | otherwise  -- type forall
   = do { arg_kind <- lintType arg_ty
        ; unless (arg_kind `isSubKind` tyvar_kind)
                 (addErrL (mkKindErrMsg tyvar arg_ty)) }
@@ -455,6 +484,16 @@ checkTyCoKind tv co
 checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
 checkTyCoKinds = zipWithM checkTyCoKind
 
+checkKiCoKind :: KindVar -> OutCoercion -> LintM Kind
+-- see lintCoercion (AxiomInstCo {}) and Note [Kind instantiation in coercions]
+checkKiCoKind kv co
+  = do { ki <- lintKindCoercion co
+       ; unless (isSuperKind (tyVarKind kv)) (addErrL (mkTyCoAppErrMsg kv co))
+       ; return ki }
+
+checkKiCoKinds :: [KindVar] -> [OutCoercion] -> LintM [Kind]
+checkKiCoKinds = zipWithM checkKiCoKind
+
 checkDeadIdOcc :: Id -> LintM ()
 -- Occurrences of an Id should never be dead....
 -- except when we are checking a case pattern
@@ -619,11 +658,11 @@ lintAndScopeId id linterF
 lintInTy :: InType -> LintM OutType
 -- Check the type, and apply the substitution to it
 -- See Note [Linting type lets]
--- ToDo: check the kind structure of the type
 lintInTy ty 
   = addLoc (InType ty) $
     do	{ ty' <- applySubstTy ty
-	; _ <- lintType ty'
+	; k <- lintType ty'
+	; lintKind k
 	; return ty' }
 
 lintInCo :: InCoercion -> LintM OutCoercion
@@ -636,21 +675,33 @@ lintInCo co
         ; return co' }
 
 -------------------
-lintKind :: Kind -> LintM ()
--- Check well-formedness of kinds: *, *->*, etc
-lintKind (TyConApp tc []) 
-  | tyConKind tc `eqKind` tySuperKind
-  = return ()
+lintKind :: OutKind -> LintM ()
+-- Check well-formedness of kinds: *, *->*, Either * (* -> *), etc
 lintKind (FunTy k1 k2)
   = lintKind k1 >> lintKind k2
-lintKind kind 
+
+lintKind kind@(TyConApp tc kis)
+  = do { unless (tyConArity tc == length kis || isSuperKindTyCon tc)
+           (addErrL malformed_kind)
+       ; mapM_ lintKind kis }
+  where
+    malformed_kind = hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind))
+
+lintKind (TyVarTy kv) = checkTyCoVarInScope kv
+lintKind kind
   = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind)))
 
 -------------------
 lintTyBndrKind :: OutTyVar -> LintM ()
-lintTyBndrKind tv = lintKind (tyVarKind tv)
+-- Handles both type and kind foralls.
+lintTyBndrKind tv =
+  let ki = tyVarKind tv in
+  if isSuperKind ki
+  then return ()    -- kind forall
+  else lintKind ki  -- type forall
 
 -------------------
+{-
 lint_prim_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType)
 lint_prim_eq_co tc co arg_cos = case arg_cos of 
   [co1,co2] -> do { (t1,s1) <- lintCoercion co1
@@ -671,7 +722,17 @@ lint_eq_co tc co arg_cos = case arg_cos of
               ; return (mkTyConApp tc [t1], mkTyConApp tc [s1]) }
   [] -> return (mkTyConApp tc [], mkTyConApp tc [])
   _ -> failWithL (ptext (sLit "Oversaturated ~ coercion") <+> ppr co) 
+-}
 
+lintKindCoercion :: OutCoercion -> LintM OutKind
+-- Kind coercions are only reflexivity because they mean kind
+-- instantiation.  See Note [Kind coercions] in Coercion
+lintKindCoercion co
+  = do { (k1,k2) <- lintCoercion co
+       ; checkL (k1 `eqKind` k2) 
+                (hang (ptext (sLit "Non-refl kind coercion")) 
+                    2 (ppr co))
+       ; return k1 }
 
 lintCoercion :: OutCoercion -> LintM (OutType, OutType)
 -- Check the kind of a coercion term, returning the kind
@@ -682,6 +743,7 @@ lintCoercion (Refl ty)
        ; return (ty, ty) }
 
 lintCoercion co@(TyConAppCo tc cos)
+{- DV: This grievous hack (from ghc-constraint-solver) should not be needed any more:
   | tc `hasKey` eqPrimTyConKey      -- Just as in lintType, treat applications of (~) and (~#)
   = lint_prim_eq_co tc co cos       -- specially to allow for polymorphism. This hack will 
                                     -- hopefully go away when we merge in kind polymorphism.
@@ -695,6 +757,23 @@ lintCoercion co@(TyConAppCo tc cos)
                              else tyConKind tc -- TODO: Fix this when kind polymorphism is in! 
        ; check_co_app co kind_to_check ss
        ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
+-}
+  = do   -- We use the kind of the type constructor to know how many
+         -- kind coercions we have (one kind coercion for one kind
+         -- instantiation).
+       { let ki | tc `hasKey` funTyConKey && length cos == 2
+                  = mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind
+                  -- It's a fully applied function, so we must use the
+                  -- most permissive type for the arrow constructor
+                | otherwise = tyConKind tc
+             (kvs, _) = splitForAllTys ki
+             (cokis, cotys) = splitAt (length kvs) cos
+         -- kis are the kind instantiations of tc
+       ; kis <- mapM lintKindCoercion cokis
+       ; (ss,ts) <- mapAndUnzipM lintCoercion cotys
+       ; check_co_app co ki (kis ++ ss)
+       ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) }
+
 
 lintCoercion co@(AppCo co1 co2)
   = do { (s1,t1) <- lintCoercion co1
@@ -703,7 +782,9 @@ lintCoercion co@(AppCo co1 co2)
        ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
 
 lintCoercion (ForAllCo v co)
-  = do { lintKind (tyVarKind v)
+  = do { let kind = tyVarKind v
+         -- lintKind when type forall, otherwise we are a kind forall
+       ; unless (isSuperKind kind) (lintKind kind)
        ; (s,t) <- addInScopeVar v (lintCoercion co)
        ; return (ForAllTy v s, ForAllTy v t) }
 
@@ -716,13 +797,21 @@ lintCoercion (CoVarCo cv)
        ; cv' <- lookupIdInScope cv 
        ; return (coVarKind cv') }
 
-lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs
+lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
                                    , co_ax_lhs = lhs
-                                   , co_ax_rhs = rhs }) 
+                                   , co_ax_rhs = rhs })
                            cos)
-  = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos)
-       ; return (substTyWith tvs tys1 lhs,
-                 substTyWith tvs tys2 rhs) }
+  = ASSERT2 (not (any isKiVar tvs), ppr ktvs)
+    do   -- see Note [Kind instantiation in coercions]
+       { kis <- checkKiCoKinds kvs kcos
+       ; let tvs' = map (updateTyVarKind (Type.substTy subst)) tvs
+             subst = zipOpenTvSubst kvs kis
+       ; (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs' tcos)
+       ; return (substTyWith ktvs (kis ++ tys1) lhs,
+                 substTyWith ktvs (kis ++ tys2) rhs) }
+  where
+    (kvs, tvs) = splitKiTyVars ktvs
+    (kcos, tcos) = splitAt (length kvs) cos
 
 lintCoercion (UnsafeCo ty1 ty2)
   = do { _ <- lintType ty1
@@ -773,7 +862,12 @@ checkTcApp co n ty
 lintType :: OutType -> LintM Kind
 lintType (TyVarTy tv)
   = do { checkTyCoVarInScope tv
-       ; return (tyVarKind tv) }
+       ; let kind = tyVarKind tv
+       ; lintKind kind
+       ; if (isSuperKind kind) then failWithL msg
+         else return kind }
+  where msg = hang (ptext (sLit "Expecting a type, but got a kind"))
+                 2 (ptext (sLit "Offending kind:") <+> ppr tv)
 
 lintType ty@(AppTy t1 t2) 
   = do { k1 <- lintType t1
@@ -783,10 +877,6 @@ lintType ty@(FunTy t1 t2)
   = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2]
 
 lintType ty@(TyConApp tc tys)
-  | tc `hasKey` eqPrimTyConKey	-- See Note [The ~# TyCon] in TysPrim
-  = lint_prim_eq_pred ty tys
-  | tc `hasKey` eqTyConKey
-  = lint_eq_pred ty tys
   | tyConHasKind tc
   = lint_ty_app ty (tyConKind tc) tys
   | otherwise
@@ -797,62 +887,44 @@ lintType (ForAllTy tv ty)
        ; addInScopeVar tv (lintType ty) }
 
 ----------------
-lint_ty_app :: OutType -> Kind -> [OutType] -> LintM Kind
-lint_ty_app ty k tys 
-  = do { ks <- mapM lintType tys
-       ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks }
-
-lint_eq_pred :: OutType -> [OutType] -> LintM Kind
-lint_eq_pred ty arg_tys = case arg_tys of
-  [ty1, ty2] ->  do { k1 <- lintType ty1
-                    ; k2 <- lintType ty2
-                    ; unless (k1 `eqKind` k2) 
-                             (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
-                                           , nest 2 (ppr ty) 
-                                           , nest 2 $ text "kind of left type is: " <+> ppr k1 
-                                           , nest 2 $ text "kind or right type is:" <+> ppr k2
-                                           ]))
-                    ; return constraintKind }
-  [ty1] -> do { k1 <- lintType ty1;
-                return (k1 `mkFunTy` constraintKind) }
-  []    -> do { return (typeKind ty) }
-  _     -> failWithL (ptext (sLit "Oversaturated (~) type") <+> ppr ty)
-
-
-lint_prim_eq_pred :: OutType -> [OutType] -> LintM Kind
-lint_prim_eq_pred ty arg_tys
-  | [ty1,ty2] <- arg_tys
-  = do { k1 <- lintType ty1
-       ; k2 <- lintType ty2
-       ; checkL (k1 `eqKind` k2) 
-                (ptext (sLit "Mismatched arg kinds:") <+> ppr ty)
-       ; return unliftedTypeKind }
-  | otherwise
-  = failWithL (ptext (sLit "Unsaturated ~# type") <+> ppr ty)
+lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
+lint_ty_app ty k tys = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys
 
 ----------------
-check_co_app :: OutCoercion -> Kind -> [OutType] -> LintM ()
-check_co_app ty k tys 
-  = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty))  
-                            k (map typeKind tys)
-       ; return () }
-                      
+check_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
+check_co_app ty k tys = lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys >> return ()
+
 ----------------
-lint_kind_app :: SDoc -> Kind -> [Kind] -> LintM Kind
-lint_kind_app doc kfn ks = go kfn ks
+lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind
+-- Takes care of linting the OutTypes
+lint_kind_app doc kfn tys = go kfn tys
   where
-    fail_msg = vcat [hang (ptext (sLit "Kind application error in")) 2 doc,
-               	     nest 2 (ptext (sLit "Function kind =") <+> ppr kfn),
-               	     nest 2 (ptext (sLit "Arg kinds =") <+> ppr ks)]
-
-    go kfn []     = return kfn
-    go kfn (k:ks) = case splitKindFunTy_maybe kfn of
-       	              Nothing         -> failWithL fail_msg
-		      Just (kfa, kfb) -> do { unless (k `isSubKind` kfa)
-                                                     (addErrL fail_msg)
-                                            ; go kfb ks } 
+    fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc
+                    , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn)
+                    , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ]
+
+    go kfn [] = return kfn
+    go kfn (ty:tys) =
+      case splitKindFunTy_maybe kfn of
+      { Nothing ->
+          case splitForAllTy_maybe kfn of
+          { Nothing -> failWithL fail_msg
+          ; Just (kv, body) -> do
+              -- Something of kind (forall kv. body) gets instantiated
+              -- with ty. 'kv' is a kind variable and 'ty' is a kind.
+            { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg)
+            ; lintKind ty
+            ; go (substKiWith [kv] [ty] body) tys } }
+      ; Just (kfa, kfb) -> do
+          -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is
+          -- a type accepting kind 'kfa'.
+        { k <- lintType ty
+        ; lintKind kfa
+        ; unless (k `isSubKind` kfa) (addErrL fail_msg)
+        ; go kfb tys } }
+
 \end{code}
-    
+
 %************************************************************************
 %*									*
 \subsection[lint-monad]{The Lint monad}
@@ -1203,14 +1275,6 @@ mkStrictMsg binder
 	     ]
 
 
-mkEqBoxKindErrMsg :: Type -> Type -> Message
-mkEqBoxKindErrMsg ty1 ty2
-  = vcat [ptext (sLit "Kinds don't match in type arguments of Eq#:"),
-          hang (ptext (sLit "Arg type 1:"))   
-                 4 (ppr ty1 <+> dcolon <+> ppr (typeKind ty1)),
-          hang (ptext (sLit "Arg type 2:"))   
-                 4 (ppr ty2 <+> dcolon <+> ppr (typeKind ty2))]
-
 mkKindErrMsg :: TyVar -> Type -> Message
 mkKindErrMsg tyvar arg_ty
   = vcat [ptext (sLit "Kinds don't match in type application:"),
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 400aad8142..b1d8a3febd 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -68,6 +68,7 @@ import Util
 import Pair
 import Data.Word
 import Data.Bits
+import Data.List ( mapAccumL )
 \end{code}
 
 
@@ -194,9 +195,15 @@ mkCast :: CoreExpr -> Coercion -> CoreExpr
 mkCast e co | isReflCo co = e
 
 mkCast (Coercion e_co) co 
-  = Coercion (mkSymCo g0 `mkTransCo` e_co `mkTransCo` g1)
+  = Coercion new_co
   where
-    [g0, g1] = decomposeCo 2 co
+       -- g :: (s1 ~# s2) ~# (t1 ~#  t2)
+       -- g1 :: s1 ~# t1
+       -- g2 :: s2 ~# t2
+       new_co = mkSymCo g1 `mkTransCo` co `mkTransCo` g2
+       [_reflk, g1, g2] = decomposeCo 3 g
+            -- Remember, (~#) :: forall k. k -> k -> *
+            -- so it takes *three* arguments, not two
 
 mkCast (Cast expr co2) co
   = ASSERT(let { Pair  from_ty  _to_ty  = coercionKind co;
@@ -230,7 +237,8 @@ mkTick t (Var x)
 mkTick t (Cast e co)
   = Cast (mkTick t e) co -- Move tick inside cast
 
-mkTick _ (Lit l) = Lit l
+mkTick t (Lit l)
+  | not (tickishCounts t) = Lit l
 
 mkTick t expr@(App f arg)
   | not (isRuntimeArg arg) = App (mkTick t f) arg
@@ -1071,9 +1079,10 @@ dataConInstPat :: [FastString]          -- A long enough list of FSs to use for
 --
 --  where the double-primed variables are created with the FastStrings and
 --  Uniques given as fss and us
-dataConInstPat fss uniqs con inst_tys
-  = (ex_bndrs, arg_ids)
-  where
+dataConInstPat fss uniqs con inst_tys 
+  = ASSERT( univ_tvs `equalLength` inst_tys )
+    (ex_bndrs, arg_ids)
+  where 
     univ_tvs = dataConUnivTyVars con
     ex_tvs   = dataConExTyVars con
     arg_tys  = dataConRepArgTys con
@@ -1084,19 +1093,25 @@ dataConInstPat fss uniqs con inst_tys
     (ex_uniqs, id_uniqs) = splitAt n_ex uniqs
     (ex_fss,   id_fss)   = splitAt n_ex fss
 
-      -- Make existential type variables
-    ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
-    mk_ex_var uniq fs var = mkTyVar new_name kind
+      -- Make the instantiating substitution for universals
+    univ_subst = zipOpenTvSubst univ_tvs inst_tys
+
+      -- Make existential type variables, applyingn and extending the substitution
+    (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst 
+                                       (zip3 ex_tvs ex_fss ex_uniqs)
+
+    mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar)
+    mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubst subst tv (mkTyVarTy new_tv)
+                                     , new_tv)
       where
+        new_tv   = mkTyVar new_name kind
         new_name = mkSysTvName uniq fs
-        kind     = tyVarKind var
-
-      -- Make the instantiating substitution
-    subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
+        kind     = Type.substTy subst (tyVarKind tv)
 
       -- Make value vars, instantiating types
-    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan
     arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
+    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq 
+                                       (Type.substTy full_subst ty) noSrcSpan
 \end{code}
 
 %************************************************************************
diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index d941b0a4b1..dd41184994 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -288,8 +288,10 @@ mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty]
 \begin{code}
 
 mkEqBox :: Coercion -> CoreExpr
-mkEqBox co = Var (dataConWorkId eqBoxDataCon) `mkTyApps` [ty1, ty2] `App` Coercion co
+mkEqBox co = ASSERT( typeKind ty2 `eqKind` k )
+             Var (dataConWorkId eqBoxDataCon) `mkTyApps` [k, ty1, ty2] `App` Coercion co
   where Pair ty1 ty2 = coercionKind co
+        k = typeKind ty1
 
 \end{code}
 
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index e38885ba54..cb12973a60 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -23,6 +23,7 @@ import TyCon
 -- import Class
 import TypeRep
 import Type
+import Kind
 import PprExternalCore () -- Instances
 import DataCon
 import Coercion
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 2ba8a23120..c575b68857 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -28,6 +28,7 @@ import Demand
 import DataCon
 import TyCon
 import Type
+import Kind
 import Coercion
 import StaticFlags
 import BasicTypes
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 5e5534748d..fd2895d072 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -550,9 +550,6 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
        addPathEntry "\\" $
          allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
            addTickHsExpr e0
-    TickTopFunctions ->
-       allocTickBox (ExpBox False) False{-no count-} True{-top-} pos $
-         addTickHsExpr e0
     _otherwise ->
        addTickLHsExprAlways expr
 
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index fcea3b14bc..e88b57e835 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -86,7 +86,6 @@ deSugar hsc_env
                             tcg_rules        = rules,
                             tcg_vects        = vects,
                             tcg_tcs          = tcs,
-                            tcg_clss         = clss,
                             tcg_insts        = insts,
                             tcg_fam_insts    = fam_insts,
                             tcg_hpc          = other_hpc_info })
@@ -189,7 +188,6 @@ deSugar hsc_env
                 mg_warns        = warns,
                 mg_anns         = anns,
                 mg_tcs          = tcs,
-                mg_clss         = clss,
                 mg_insts        = insts,
                 mg_fam_insts    = fam_insts,
                 mg_inst_env     = inst_env,
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 9e6c1ee814..8b41d3a2af 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -365,11 +365,11 @@ dsExpr (ExplicitList elt_ty xs)
 --   singletonP x1 +:+ ... +:+ singletonP xn
 --
 dsExpr (ExplicitPArr ty []) = do
-    emptyP <- dsLookupDPHId emptyPName
+    emptyP <- dsDPHBuiltin emptyPVar
     return (Var emptyP `App` Type ty)
 dsExpr (ExplicitPArr ty xs) = do
-    singletonP <- dsLookupDPHId singletonPName
-    appP       <- dsLookupDPHId appPName
+    singletonP <- dsDPHBuiltin singletonPVar
+    appP       <- dsDPHBuiltin appPVar
     xs'        <- mapM dsLExpr xs
     return . foldr1 (binary appP) $ map (unary singletonP) xs'
   where
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 335fb1fdda..63d96fd465 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -484,7 +484,7 @@ dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
 --    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
 --
 dsPArrComp (BindStmt p e _ _ : qs) = do
-    filterP <- dsLookupDPHId filterPName
+    filterP <- dsDPHBuiltin filterPVar
     ce <- dsLExpr e
     let ety'ce  = parrElemType ce
         false   = Var falseDataConId
@@ -496,7 +496,7 @@ dsPArrComp (BindStmt p e _ _ : qs) = do
     dePArrComp qs p gen
 
 dsPArrComp qs = do -- no ParStmt in `qs'
-    sglP <- dsLookupDPHId singletonPName
+    sglP <- dsDPHBuiltin singletonPVar
     let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
     dePArrComp qs (noLoc $ WildPat unitTy) unitArray
 
@@ -516,7 +516,7 @@ dePArrComp [] _ _ = panic "dePArrComp"
 --
 dePArrComp (LastStmt e' _ : quals) pa cea
   = ASSERT( null quals )
-    do { mapP <- dsLookupDPHId mapPName
+    do { mapP <- dsDPHBuiltin mapPVar
        ; let ty = parrElemType cea
        ; (clam, ty'e') <- deLambda ty pa e'
        ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
@@ -524,7 +524,7 @@ dePArrComp (LastStmt e' _ : quals) pa cea
 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 --
 dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
-    filterP <- dsLookupDPHId filterPName
+    filterP <- dsDPHBuiltin filterPVar
     let ty = parrElemType cea
     (clam,_) <- deLambda ty pa b
     dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
@@ -543,8 +543,8 @@ dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
 --    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
 --
 dePArrComp (BindStmt p e _ _ : qs) pa cea = do
-    filterP <- dsLookupDPHId filterPName
-    crossMapP <- dsLookupDPHId crossMapPName
+    filterP <- dsDPHBuiltin filterPVar
+    crossMapP <- dsDPHBuiltin crossMapPVar
     ce <- dsLExpr e
     let ety'cea = parrElemType cea
         ety'ce  = parrElemType ce
@@ -568,7 +568,7 @@ dePArrComp (BindStmt p e _ _ : qs) pa cea = do
 --    {x_1, ..., x_n} = DV (ds)         -- Defined Variables
 --
 dePArrComp (LetStmt ds : qs) pa cea = do
-    mapP <- dsLookupDPHId mapPName
+    mapP <- dsDPHBuiltin mapPVar
     let xs     = collectLocalBinders ds
         ty'cea = parrElemType cea
     v <- newSysLocalDs ty'cea
@@ -615,7 +615,7 @@ dePArrParComp qss quals = do
     ---
     parStmts []             pa cea = return (pa, cea)
     parStmts ((qs, xs):qss) pa cea = do  -- subsequent statements (zip'ed)
-      zipP <- dsLookupDPHId zipPName
+      zipP <- dsDPHBuiltin zipPVar
       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
           ty'cea   = parrElemType cea
           res_expr = mkLHsVarTuple xs
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 628f911308..4b710f67cc 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -53,6 +53,7 @@ import NameEnv
 import TcType
 import TyCon
 import TysWiredIn
+import TysPrim ( liftedTypeKindTyConName )
 import CoreSyn
 import MkCore
 import CoreUtils
@@ -81,7 +82,7 @@ dsBracket brack splices
   where
     new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
 
-    do_brack (VarBr n)   = do { MkC e1  <- lookupOcc n ; return e1 }
+    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
     do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }
     do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }
     do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
@@ -598,7 +599,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki _)) nm
   = repKind ki >>= repKindedTV nm
 
 -- represent a type context
@@ -684,7 +685,7 @@ repTy (HsTupleTy HsUnboxedTuple tys) = do
 			        tys1 <- repLTys tys
 			        tcon <- repUnboxedTupleTyCon (length tys)
 			        repTapps tcon tys1
-repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) 
+repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
 			    	   `nlHsAppTy` ty2)
 repTy (HsParTy t)  	    = repLTy t
 repTy (HsKindSig t k)       = do
@@ -696,17 +697,16 @@ repTy ty		      = notHandled "Exotic form of type" (ppr ty)
 
 -- represent a kind
 --
-repKind :: Kind -> DsM (Core TH.Kind)
+repKind :: LHsKind Name -> DsM (Core TH.Kind)
 repKind ki
-  = do { let (kis, ki') = splitKindFunTys ki
+  = do { let (kis, ki') = splitHsFunType ki
        ; kis_rep <- mapM repKind kis
        ; ki'_rep <- repNonArrowKind ki'
        ; foldrM repArrowK ki'_rep kis_rep
        }
   where
-    repNonArrowKind k | isLiftedTypeKind k = repStarK
-                      | otherwise          = notHandled "Exotic form of kind" 
-                                                        (ppr k)
+    repNonArrowKind (L _ (HsTyVar name)) | name == liftedTypeKindTyConName = repStarK
+    repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
 
 -----------------------------------------------------------------------------
 -- 		Splices
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index 9403317ceb..8ea94efef3 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -21,9 +21,9 @@ module DsMonad (
         newUnique, 
         UniqSupply, newUniqueSupply,
         getDOptsDs, getGhcModeDs, doptDs, woptDs,
-        dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
+        dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
         
-        assertDAPPLoaded, lookupDAPPRdrEnv,
+        PArrBuiltin(..), dsLookupDPHRdrEnv, dsInitPArrBuiltin,
 
         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
@@ -41,6 +41,7 @@ import CoreSyn
 import HsSyn
 import TcIface
 import LoadIface
+import Finder
 import PrelNames
 import Avail
 import RdrName
@@ -60,7 +61,6 @@ import DynFlags
 import ErrUtils
 import FastString
 import Maybes
-import Control.Monad
 
 import Data.IORef
 \end{code}
@@ -131,16 +131,38 @@ type DsWarning = (SrcSpan, SDoc)
         -- and we'll do the print_unqual stuff later on to turn it
         -- into a Doc.
 
-data DsGblEnv = DsGblEnv {
-        ds_mod     :: Module,                   -- For SCC profiling
-        ds_unqual  :: PrintUnqualified,
-        ds_msgs    :: IORef Messages,           -- Warning messages
-        ds_if_env  :: (IfGblEnv, IfLclEnv),     -- Used for looking up global, 
+-- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding
+-- variables found in 'Data.Array.Parallel'.
+--
+data PArrBuiltin
+        = PArrBuiltin
+        { lengthPVar         :: Var     -- ^ lengthP
+        , replicatePVar      :: Var     -- ^ replicateP
+        , singletonPVar      :: Var     -- ^ singletonP
+        , mapPVar            :: Var     -- ^ mapP
+        , filterPVar         :: Var     -- ^ filterP
+        , zipPVar            :: Var     -- ^ zipP
+        , crossMapPVar       :: Var     -- ^ crossMapP
+        , indexPVar          :: Var     -- ^ (!:)
+        , emptyPVar          :: Var     -- ^ emptyP
+        , appPVar            :: Var     -- ^ (+:+)
+        , enumFromToPVar     :: Var     -- ^ enumFromToP
+        , enumFromThenToPVar :: Var     -- ^ enumFromThenToP
+        }
+
+data DsGblEnv 
+        = DsGblEnv
+        { ds_mod     :: Module                  -- For SCC profiling
+        , ds_unqual  :: PrintUnqualified
+        , ds_msgs    :: IORef Messages          -- Warning messages
+        , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global, 
                                                 -- possibly-imported things
-        ds_dph_env :: GlobalRdrEnv              -- exported entities of 'Data.Array.Parallel.Prim' iff
-                                                -- '-fdph-*' flag was given (i.e., 'DynFlags.DPHBackend /=
-                                                -- DPHNone'); otherwise, empty
-    }
+        , ds_dph_env :: GlobalRdrEnv            -- exported entities of 'Data.Array.Parallel.Prim'
+                                                -- iff '-fvectorise' flag was given as well as
+                                                -- exported entities of 'Data.Array.Parallel' iff
+                                                -- '-XParallelArrays' was given; otherwise, empty
+        , ds_parr_bi :: PArrBuiltin             -- desugarar names for '-XParallelArrays'
+        }
 
 data DsLclEnv = DsLclEnv {
         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
@@ -171,8 +193,9 @@ initDs hsc_env mod rdr_env type_env thing_inside
               (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env msg_var
 
         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
-                          loadDAPP dflags $
-                            tryM thing_inside       -- Catch exceptions (= errors during desugaring)
+                          loadDAP $
+                            initDPHBuiltins $
+                              tryM thing_inside     -- Catch exceptions (= errors during desugaring)
 
         -- Display any errors and warnings 
         -- Note: if -Werror is used, we don't signal an error here.
@@ -190,22 +213,51 @@ initDs hsc_env mod rdr_env type_env thing_inside
         }
   where
     -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
-    -- 'Data.Array.Parallel.Prim' if '-fdph-*' specified.
-    loadDAPP dflags thing_inside
-      | Just pkg <- dphPackageMaybe dflags
-      = do { rdr_env <- loadModule sdoc (dATA_ARRAY_PARALLEL_PRIM pkg)
-           ; updGblEnv (\env -> env {ds_dph_env = rdr_env}) thing_inside
+    --   * 'Data.Array.Parallel'      iff '-XParallalArrays' specified (see also 'checkLoadDAP').
+    --   * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
+    loadDAP thing_inside
+      = do { dapEnv  <- loadOneModule dATA_ARRAY_PARALLEL_NAME      checkLoadDAP          paErr
+           ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (doptM Opt_Vectorise) veErr
+           ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
            }
-      | otherwise
-      = do { ifXOptM Opt_ParallelArrays (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrPA)
-           ; ifDOptM Opt_Vectorise      (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrVect)
-           ; thing_inside
+      where
+        loadOneModule :: ModuleName           -- the module to load
+                      -> DsM Bool             -- under which condition
+                      -> Message              -- error message if module not found
+                      -> DsM GlobalRdrEnv     -- empty if condition 'False'
+        loadOneModule modname check err
+          = do { doLoad <- check
+               ; if not doLoad 
+                 then return emptyGlobalRdrEnv
+                 else do {
+               ; result <- liftIO $ findImportedModule hsc_env modname Nothing
+               ; case result of
+                   Found _ mod -> loadModule err mod
+                   _           -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
+               } }
+
+        paErr       = ptext (sLit "To use -XParallelArrays,") <+> specBackend $$ hint1 $$ hint2
+        veErr       = ptext (sLit "To use -fvectorise,") <+> specBackend $$ hint1 $$ hint2
+        specBackend = ptext (sLit "you must specify a DPH backend package")
+        hint1       = ptext (sLit "Look for packages named 'dph-lifted-*' with 'ghc-pkg'")
+        hint2       = ptext (sLit "You may need to install them with 'cabal install dph-examples'")
+
+    initDPHBuiltins thing_inside
+      = do {   -- If '-XParallelArrays' given, we populate the builtin table for desugaring those
+           ; doInitBuiltins <- checkLoadDAP
+           ; if doInitBuiltins
+             then dsInitPArrBuiltin thing_inside
+             else thing_inside
            }
 
-    sdoc = ptext (sLit "Internal Data Parallel Haskell interface 'Data.Array.Parallel.Prim'")
-
-    selectBackendErrVect = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
-    selectBackendErrPA   = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
+    checkLoadDAP = do { paEnabled <- xoptM Opt_ParallelArrays
+                      ; return $ paEnabled &&
+                                 mod /= gHC_PARR' && 
+                                 moduleName mod /= dATA_ARRAY_PARALLEL_NAME
+                      }
+                      -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
+                      -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
+                      -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
 
 initDsTc :: DsM a -> TcM a
 initDsTc thing_inside
@@ -228,23 +280,23 @@ mkDsEnvs dflags mod rdr_env type_env msg_var
                            , ds_unqual  = mkPrintUnqualified dflags rdr_env
                            , ds_msgs    = msg_var
                            , ds_dph_env = emptyGlobalRdrEnv
+                           , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
                            }
         lcl_env = DsLclEnv { ds_meta = emptyNameEnv
                            , ds_loc  = noSrcSpan
                            }
     in (gbl_env, lcl_env)
 
--- Attempt to load the given module and return its exported entities if successful; otherwise, return an
--- empty environment.  See "Note [Loading Data.Array.Parallel.Prim]".
+-- Attempt to load the given module and return its exported entities if successful.
 --
 loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
 loadModule doc mod
-  = do { env <- getGblEnv
+  = do { env    <- getGblEnv
        ; setEnvs (ds_if_env env) $ do
        { iface <- loadInterface doc mod ImportBySystem
-       ;   case iface of
-             Failed _err     -> return $ mkGlobalRdrEnv []
-             Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
+       ; case iface of
+           Failed err      -> pprPanic "DsMonad.loadModule: failed to load" (err $$ doc)
+           Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
        } }
   where
     prov     = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }]
@@ -253,15 +305,6 @@ loadModule doc mod
     name = moduleName mod
 \end{code}
 
-Note [Loading Data.Array.Parallel.Prim]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We generally attempt to load the interface of 'Data.Array.Parallel.Prim' when a DPH backend is selected.
-However, while compiling packages containing a DPH backend, we will start out compiling the modules
-'Data.Array.Parallel.Prim' depends on — i.e., when compiling these modules, the interface won't exist yet.
-This is fine, as these modules do not use the vectoriser, but we need to ensure that GHC doesn't barf when
-the interface is missing.  Instead of an error message, we just put an empty 'GlobalRdrEnv' into the
-'DsM' state.
-
 
 %************************************************************************
 %*                                                                      *
@@ -355,18 +398,11 @@ dsLookupGlobalId :: Name -> DsM Id
 dsLookupGlobalId name 
   = tyThingId <$> dsLookupGlobal name
 
--- Looking up a global DPH 'Id' is like 'dsLookupGlobalId', but the package, in which the looked
--- up name is located, varies with the active DPH backend.
+-- |Get a name from "Data.Array.Parallel" for the desugarer, from the 'ds_parr_bi' component of the
+-- global desugerar environment.
 --
-dsLookupDPHId :: (PackageId -> Name) -> DsM Id
-dsLookupDPHId nameInPkg
-  = do { dflags <- getDOpts
-       ; case dphPackageMaybe dflags of
-           Just pkg -> tyThingId <$> dsLookupGlobal (nameInPkg pkg)
-           Nothing  -> failWithDs $ ptext err
-       }
-  where
-    err = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
+dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
+dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
 
 dsLookupTyCon :: Name -> DsM TyCon
 dsLookupTyCon name
@@ -378,28 +414,61 @@ dsLookupDataCon name
 \end{code}
 
 \begin{code}
--- Complain if 'Data.Array.Parallel.Prim' wasn't loaded (and we are about to use it).
---
--- See "Note [Loading Data.Array.Parallel.Prim]".
+-- Look up a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
 --
-assertDAPPLoaded :: DsM ()
-assertDAPPLoaded 
-  = do { env <- ds_dph_env <$> getGblEnv
-       ; when (null $ occEnvElts env) $
-           panic "'Data.Array.Parallel.Prim' not available; maybe missing dependency in DPH package"
-       }
-
--- Look up a name exported by 'Data.Array.Parallel.Prim'.
---
-lookupDAPPRdrEnv :: OccName -> DsM Name
-lookupDAPPRdrEnv occ
+dsLookupDPHRdrEnv :: OccName -> DsM Name
+dsLookupDPHRdrEnv occ
   = do { env <- ds_dph_env <$> getGblEnv
        ; let gres = lookupGlobalRdrEnv env occ
        ; case gres of
-           []    -> pprPanic "Name not found in 'Data.Array.Parallel.Prim':" (ppr occ)
+           []    -> pprPanic nameNotFound (ppr occ)
            [gre] -> return $ gre_name gre
-           _     -> pprPanic "Multiple definitions in 'Data.Array.Parallel.Prim':" (ppr occ)
+           _     -> pprPanic multipleNames (ppr occ)
        }
+  where
+    nameNotFound  = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
+    multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
+
+-- Populate 'ds_parr_bi' from 'ds_dph_env'.
+--
+dsInitPArrBuiltin :: DsM a -> DsM a
+dsInitPArrBuiltin thing_inside
+  = do { lengthPVar         <- externalVar (fsLit "lengthP")
+       ; replicatePVar      <- externalVar (fsLit "replicateP")
+       ; singletonPVar      <- externalVar (fsLit "singletonP")
+       ; mapPVar            <- externalVar (fsLit "mapP")
+       ; filterPVar         <- externalVar (fsLit "filterP")
+       ; zipPVar            <- externalVar (fsLit "zipP")
+       ; crossMapPVar       <- externalVar (fsLit "crossMapP")
+       ; indexPVar          <- externalVar (fsLit "!:")
+       ; emptyPVar          <- externalVar (fsLit "emptyP")
+       ; appPVar            <- externalVar (fsLit "+:+")
+       -- ; enumFromToPVar     <- externalVar (fsLit "enumFromToP")
+       -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
+       ; enumFromToPVar     <- return arithErr
+       ; enumFromThenToPVar <- return arithErr
+
+       ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
+                                              { lengthPVar         = lengthPVar
+                                              , replicatePVar      = replicatePVar
+                                              , singletonPVar      = singletonPVar
+                                              , mapPVar            = mapPVar
+                                              , filterPVar         = filterPVar
+                                              , zipPVar            = zipPVar
+                                              , crossMapPVar       = crossMapPVar
+                                              , indexPVar          = indexPVar
+                                              , emptyPVar          = emptyPVar
+                                              , appPVar            = appPVar
+                                              , enumFromToPVar     = enumFromToPVar
+                                              , enumFromThenToPVar = enumFromThenToPVar
+                                              } })
+                   thing_inside
+       }
+  where
+    externalVar :: FastString -> DsM Var
+    externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
+    
+    arithErr = panic "Arithmetic sequences have to wait until we support type classes"
 \end{code}
 
 \begin{code}
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index df049aae9c..6a46bbe93d 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -389,7 +389,7 @@ mkCoAlgCaseMatchResult var ty match_alts
     isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
     --
     mk_parrCase fail = do
-      lengthP <- dsLookupDPHId lengthPName
+      lengthP <- dsDPHBuiltin lengthPVar
       alt <- unboxAlt
       return (mkWildCase (len lengthP) intTy ty [alt])
       where
@@ -401,7 +401,7 @@ mkCoAlgCaseMatchResult var ty match_alts
 	--
 	unboxAlt = do
 	  l      <- newSysLocalDs intPrimTy
-	  indexP <- dsLookupDPHId indexPName
+	  indexP <- dsDPHBuiltin indexPVar
 	  alts   <- mapM (mkAlt indexP) sorted_alts
 	  return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
           where
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 040ca6b09f..aea6d8d173 100755
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -301,6 +301,7 @@ Library
         LoadIface
         MkIface
         TcIface
+        FlagChecker
         Annotations
         BreakArray
         CmdLineParser
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 84d0acf316..f521ee6b06 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -45,6 +45,7 @@ import Var
 import TcRnMonad
 import TcType
 import TcMType
+import TcHsSyn ( mkZonkTcTyVar )
 import TcUnify
 import TcEnv
 
@@ -1130,7 +1131,7 @@ zonkTerm = foldTermM (TermFoldM
 zonkRttiType :: TcType -> TcM Type
 -- Zonk the type, replacing any unbound Meta tyvars
 -- by skolems, safely out of Meta-tyvar-land
-zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta) 
+zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta mkTyVarTy)
   where
     zonk_unbound_meta tv 
       = ASSERT( isTcTyVar tv )
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index fc33dc125f..6f88319b06 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -27,7 +27,6 @@ import qualified OccName
 import OccName
 import SrcLoc
 import Type
-import Coercion
 import TysWiredIn
 import BasicTypes as Hs
 import ForeignCall
@@ -204,7 +203,7 @@ cvtDec (ForeignD ford)
 
 cvtDec (FamilyD flav tc tvs kind)
   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
-       ; let kind' = fmap cvtKind kind
+       ; kind' <- cvtMaybeKind kind
        ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') }
   where
     cvtFamFlavour TypeFam = TypeFamily
@@ -785,7 +784,8 @@ cvt_tv (TH.PlainTV nm)
        }
 cvt_tv (TH.KindedTV nm ki) 
   = do { nm' <- tName nm
-       ; returnL $ KindedTyVar nm' (cvtKind ki)
+       ; ki' <- cvtKind ki
+       ; returnL $ KindedTyVar nm' ki' placeHolderKind
        }
 
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
@@ -842,7 +842,8 @@ cvtType ty
 
            SigT ty ki
              -> do { ty' <- cvtType ty
-                   ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
+                   ; ki' <- cvtKind ki
+                   ; mk_apps (HsKindSig ty' ki') tys'
                    }
 
            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
@@ -859,9 +860,16 @@ split_ty_app ty = go ty []
     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
     go f as 	      = return (f,as)
 
-cvtKind :: TH.Kind -> Type.Kind
-cvtKind StarK          = liftedTypeKind
-cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
+cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
+cvtKind StarK          = returnL (HsTyVar (getRdrName liftedTypeKindTyCon))
+cvtKind (ArrowK k1 k2) = do
+  k1' <- cvtKind k1
+  k2' <- cvtKind k2
+  returnL (HsFunTy k1' k2')
+
+cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
+cvtMaybeKind Nothing = return Nothing
+cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just
 
 -----------------------------------------------------------
 
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index ff33213b76..b6bc0c702b 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -23,6 +23,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
                                GRHSs, pprPatBind )
 import {-# SOURCE #-} HsPat  ( LPat )
 
+import HsLit
 import HsTypes
 import PprCore ()
 import CoreSyn
@@ -461,9 +462,9 @@ data HsWrapper
   | WpEvLam EvVar               -- \d. []       the 'd' is an evidence variable
   | WpEvApp EvTerm              -- [] d         the 'd' is evidence for a constraint
 
-        -- Type abstraction and application
-  | WpTyLam TyVar               -- \a. []       the 'a' is a type variable (not coercion var)
-  | WpTyApp Type                -- [] t         the 't' is a type (not coercion)
+	-- Kind and Type abstraction and application
+  | WpTyLam TyVar 	-- \a. []	the 'a' is a type/kind variable (not coercion var)
+  | WpTyApp KindOrType	-- [] t		the 't' is a type (not coercion)
 
 
   | WpLet TcEvBinds             -- Non-empty (or possibly non-empty) evidence bindings,
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 480401b84a..ea34e7991c 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -14,7 +14,7 @@ module HsDecls (
   -- * Toplevel declarations
   HsDecl(..), LHsDecl,
   -- ** Class or type declarations
-  TyClDecl(..), LTyClDecl,
+  TyClDecl(..), LTyClDecl, TyClGroup,
   isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
   isFamInstDecl, tcdName, tyClDeclTyVars,
   countTyClDecls,
@@ -63,7 +63,6 @@ import HsDoc
 import TyCon
 import NameSet
 import Name
-import {- Kind parts of -} Type
 import BasicTypes
 import Coercion
 import ForeignCall
@@ -431,6 +430,8 @@ Interface file code:
 -- In both cases, 'tcdVars' collects all variables we need to quantify over.
 
 type LTyClDecl name = Located (TyClDecl name)
+type TyClGroup name = [LTyClDecl name]  -- this is used in TcTyClsDecls to represent
+                                        -- strongly connected components of decls
 
 -- | A type or class declaration.
 data TyClDecl name
@@ -444,7 +445,7 @@ data TyClDecl name
     TyFamily {  tcdFlavour:: FamilyFlavour,             -- type or data
                 tcdLName  :: Located name,              -- type constructor
                 tcdTyVars :: [LHsTyVarBndr name],       -- type variables
-                tcdKind   :: Maybe Kind                 -- result kind
+                tcdKind   :: Maybe (LHsKind name)       -- result kind
     }
 
 
@@ -461,7 +462,7 @@ data TyClDecl name
                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns.
                   -- See Note [tcdTyVars and tcdTyPats] 
 
-                tcdKindSig:: Maybe Kind,
+                tcdKindSig:: Maybe (LHsKind name),
                         -- ^ Optional kind signature.
                         --
                         -- @(Just k)@ for a GADT-style @data@, or @data
@@ -535,14 +536,18 @@ tcdTyPats = Just tys
    This is a data/type family instance declaration
    tcdTyVars are fv(tys)
 
-   Eg   class C a b where
-          type F a x :: *
-        instance D p s => C (p,q) [r] where
-          type F (p,q) x = p -> x
-   The tcdTyVars of the F instance decl are {p,q,x},
-   i.e. not including s, nor r 
-        (and indeed neither s nor should be mentioned
-         on the RHS of the F instance decl; Trac #5515)
+   Eg   class C s t where
+          type F t p :: *
+        instance C w (a,b) where
+          type F (a,b) x = x->a
+   The tcdTyVars of the F decl are {a,b,x}, even though the F decl
+   is nested inside the 'instance' decl. 
+
+   However after the renamer, the uniques will match up:
+        instance C w7 (a8,b9) where
+          type F (a8,b9) x10 = x10->a8
+   so that we can compare the type patter in the 'instance' decl and
+   in the associated 'type' decl
 
 ------------------------------
 Simple classifiers
@@ -631,7 +636,7 @@ instance OutputableBndr name
 
           pp_kind = case mb_kind of
                       Nothing   -> empty
-                      Just kind -> dcolon <+> pprKind kind
+                      Just kind -> dcolon <+> ppr kind
 
     ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
                     tcdSynRhs = mono_ty})
@@ -653,7 +658,7 @@ instance OutputableBndr name
                   derivings
       where
         ppr_sigx Nothing     = empty
-        ppr_sigx (Just kind) = dcolon <+> pprKind kind
+        ppr_sigx (Just kind) = dcolon <+> ppr kind
 
     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
                     tcdFDs  = fds,
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 869532e858..7b814e14bb 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -1197,7 +1197,8 @@ data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
                   | DecBrL [LHsDecl id]	 -- [d| decls |]; result of parser
                   | DecBrG (HsGroup id)  -- [d| decls |]; result of renamer
                   | TypBr (LHsType id)   -- [t| type  |]
-                  | VarBr id             -- 'x, ''T
+                  | VarBr Bool id        -- True: 'x, False: ''T
+                                         -- (The Bool flag is used only in pprHsBracket)
   deriving (Data, Typeable)
 
 instance OutputableBndr id => Outputable (HsBracket id) where
@@ -1210,11 +1211,8 @@ pprHsBracket (PatBr p) 	 = thBrackets (char 'p') (ppr p)
 pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
 pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
 pprHsBracket (TypBr t) 	 = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr n) 	 = char '\'' <> ppr n
--- Infelicity: can't show ' vs '', because
--- we can't ask n what its OccName is, because the
--- pretty-printer for HsExpr doesn't ask for NamedThings
--- But the pretty-printer for names will show the OccName class
+pprHsBracket (VarBr True n)  = char '\''         <> ppr n
+pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n
 
 thBrackets :: SDoc -> SDoc -> SDoc
 thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot
index 4dff75c802..6666243264 100644
--- a/compiler/hsSyn/HsExpr.lhs-boot
+++ b/compiler/hsSyn/HsExpr.lhs-boot
@@ -1,4 +1,5 @@
 \begin{code}
+{-# LANGUAGE KindSignatures #-}
 {-# OPTIONS -fno-warn-tabs #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
@@ -13,11 +14,12 @@ import Outputable ( SDoc, OutputableBndr )
 import {-# SOURCE #-} HsPat  ( LPat )
 
 import Data.Data
-	
-data HsExpr i
-data HsSplice i
-data MatchGroup a
-data GRHSs a
+
+-- IA0_NOTE: We need kind annotations because of kind polymorphism
+data HsExpr (i :: *)
+data HsSplice (i :: *)
+data MatchGroup (a :: *)
+data GRHSs (a :: *)
 
 instance Typeable1 HsSplice
 instance Data i => Data (HsSplice i)
diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs
index b8e4b11e6b..efa61dde67 100644
--- a/compiler/hsSyn/HsLit.lhs
+++ b/compiler/hsSyn/HsLit.lhs
@@ -20,8 +20,7 @@ module HsLit where
 
 import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
 import BasicTypes ( FractionalLit(..) )
-import HsTypes  ( PostTcType )
-import Type	( Type )
+import Type	( Type, Kind )
 import Outputable
 import FastString
 
@@ -31,6 +30,26 @@ import Data.Data
 
 %************************************************************************
 %*									*
+\subsection{Annotating the syntax}
+%*									*
+%************************************************************************
+
+\begin{code}
+type PostTcKind = Kind
+type PostTcType = Type		-- Used for slots in the abstract syntax
+				-- where we want to keep slot for a type
+				-- to be added by the type checker...but
+				-- before typechecking it's just bogus
+
+placeHolderType :: PostTcType	-- Used before typechecking
+placeHolderType  = panic "Evaluated the place holder for a PostTcType"
+
+placeHolderKind :: PostTcKind	-- Used before typechecking
+placeHolderKind  = panic "Evaluated the place holder for a PostTcKind"
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection[HsLit]{Literals}
 %*									*
 %************************************************************************
diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot
index 7ba338e41f..28991030ad 100644
--- a/compiler/hsSyn/HsPat.lhs-boot
+++ b/compiler/hsSyn/HsPat.lhs-boot
@@ -1,10 +1,13 @@
 \begin{code}
+{-# LANGUAGE KindSignatures #-}
+
 module HsPat where
 import SrcLoc( Located )
 
 import Data.Data
 
-data Pat i
+-- IA0_NOTE: We need kind annotation because of kind polymorphism.
+data Pat (i :: *)
 type LPat i = Located (Pat i)
 
 instance Typeable1 Pat
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 9e20dbdd4d..fec71af3a0 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -16,11 +16,12 @@ HsTypes: Abstract syntax: user-defined types
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module HsTypes (
-	HsType(..), LHsType, 
+	HsType(..), LHsType, HsKind, LHsKind,
 	HsTyVarBndr(..), LHsTyVarBndr,
 	HsTupleSort(..), HsExplicitFlag(..),
 	HsContext, LHsContext,
 	HsQuasiQuote(..),
+        HsTyWrapper(..),
 
 	LBangType, BangType, HsBang(..), 
         getBangType, getBangStrictness, 
@@ -29,16 +30,13 @@ module HsTypes (
 	
 	mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
 	hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName,
-	hsTyVarKind, hsTyVarNameKind,
+	hsTyVarKind, hsLTyVarKind, hsTyVarNameKind,
 	hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
 	splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
         splitHsForAllTy, splitLHsForAllTy,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
-	splitHsAppTys, mkHsAppTys,
-	
-	-- Type place holder
-	PostTcType, placeHolderType, PostTcKind, placeHolderKind,
+	splitHsAppTys, mkHsAppTys, mkHsOpTy,
 
 	-- Printing
 	pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
@@ -46,7 +44,9 @@ module HsTypes (
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
-import NameSet ( FreeVars )
+import HsLit
+
+import NameSet( FreeVars )
 import Type
 import HsDoc
 import BasicTypes
@@ -61,26 +61,6 @@ import Data.Data
 
 %************************************************************************
 %*									*
-\subsection{Annotating the syntax}
-%*									*
-%************************************************************************
-
-\begin{code}
-type PostTcKind = Kind
-type PostTcType = Type		-- Used for slots in the abstract syntax
-				-- where we want to keep slot for a type
-				-- to be added by the type checker...but
-				-- before typechecking it's just bogus
-
-placeHolderType :: PostTcType	-- Used before typechecking
-placeHolderType  = panic "Evaluated the place holder for a PostTcType"
-
-placeHolderKind :: PostTcKind	-- Used before typechecking
-placeHolderKind  = panic "Evaluated the place holder for a PostTcKind"
-\end{code}
-
-%************************************************************************
-%*									*
 	Quasi quotes; used in types and elsewhere
 %*									*
 %************************************************************************
@@ -136,6 +116,8 @@ type LHsContext name = Located (HsContext name)
 type HsContext name = [LHsType name]
 
 type LHsType name = Located (HsType name)
+type HsKind name = HsType name
+type LHsKind name = Located (HsKind name)
 
 data HsType name
   = HsForAllTy	HsExplicitFlag   	-- Renamer leaves this flag unchanged, to record the way
@@ -146,7 +128,8 @@ data HsType name
 		(LHsContext name)
 		(LHsType name)
 
-  | HsTyVar		name		-- Type variable or type constructor
+  | HsTyVar		name		-- Type variable, type constructor, or data constructor
+                                        -- see Note [Promotions (HsTyVar)]
 
   | HsAppTy		(LHsType name)
 			(LHsType name)
@@ -161,7 +144,7 @@ data HsType name
   | HsTupleTy		HsTupleSort
 			[LHsType name]	-- Element types (length gives arity)
 
-  | HsOpTy		(LHsType name) (Located name) (LHsType name)
+  | HsOpTy		(LHsType name) (LHsTyOp name) (LHsType name)
 
   | HsParTy		(LHsType name)   -- See Note [Parens in HsSyn] in HsExpr
 	-- Parenthesis preserved for the precedence re-arrangement in RnTypes
@@ -174,7 +157,7 @@ data HsType name
                         (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule
 
   | HsKindSig		(LHsType name)	-- (ty :: kind)
-			Kind		-- A type with a kind signature
+			(LHsKind name)  -- A type with a kind signature
 
   | HsQuasiQuoteTy	(HsQuasiQuote name)
 
@@ -189,11 +172,69 @@ data HsType name
 
   | HsCoreTy Type	-- An escape hatch for tunnelling a *closed* 
     	       		-- Core Type through HsSyn.  
-					 
+
+  | HsExplicitListTy     -- A promoted explicit list
+        PostTcKind       -- See Note [Promoted lists and tuples]
+        [LHsType name]   
+                         
+  | HsExplicitTupleTy    -- A promoted explicit tuple
+        [PostTcKind]     -- See Note [Promoted lists and tuples]
+        [LHsType name]   
+
+  | HsWrapTy HsTyWrapper (HsType name)  -- only in typechecker output
+  deriving (Data, Typeable)
+
+data HsTyWrapper
+  = WpKiApps [Kind]  -- kind instantiation: [] k1 k2 .. kn
   deriving (Data, Typeable)
 
+type LHsTyOp name = HsTyOp (Located name)
+type HsTyOp name = (HsTyWrapper, name)
+
+mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
+mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
+\end{code}
+
+Note [Promotions (HsTyVar)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+HsTyVar: A name in a type or kind.
+  Here are the allowed namespaces for the name.
+    In a type:
+      Var: not allowed
+      Data: promoted data constructor
+      Tv: type variable
+      TcCls before renamer: type constructor, class constructor, or promoted data constructor
+      TcCls after renamer: type constructor or class constructor
+    In a kind:
+      Var, Data: not allowed
+      Tv: kind variable
+      TcCls: kind constructor or promoted type constructor
+
+
+Note [Promoted lists and tuples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Notice the difference between
+   HsListTy    HsExplicitListTy
+   HsTupleTy   HsExplicitListTupleTy
+
+E.g.    f :: [Int]                      HsListTy                
+
+        g3  :: T '[]                   All these use  
+        g2  :: T '[True]                  HsExplicitListTy        
+        g1  :: T '[True,False]          
+        g1a :: T [True,False]             (can omit ' where unambiguous)
+
+  kind of T :: [Bool] -> *        This kind uses HsListTy!
+
+E.g.    h :: (Int,Bool)                 HsTupleTy; f is a pair               
+        k :: S '(True,False)            HsExplicitTypleTy; S is indexed by   
+                                           a type-level pair of booleans 
+        kind of S :: (Bool,Bool) -> *   This kind uses HsExplicitTupleTy
+
+
+\begin{code}
 data HsTupleSort = HsUnboxedTuple
-                 | HsBoxyTuple Kind -- Either a Constraint or normal tuple: resolved during type checking
+                 | HsBoxyTuple PostTcKind -- Either a Constraint or normal tuple: resolved during type checking
                  deriving (Data, Typeable)
 
 data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
@@ -252,9 +293,10 @@ data HsTyVarBndr name
          name 		-- See Note [Printing KindedTyVars]
          PostTcKind
 
-  | KindedTyVar 
-         name 
-         Kind 
+  | KindedTyVar
+         name
+         (LHsKind name)	-- The user-supplied kind signature
+         PostTcKind
       --  *** NOTA BENE *** A "monotype" in a pragma can have
       -- for-alls in it, (mostly to do with dictionaries).  These
       -- must be explicitly Kinded.
@@ -262,15 +304,18 @@ data HsTyVarBndr name
 
 hsTyVarName :: HsTyVarBndr name -> name
 hsTyVarName (UserTyVar n _)   = n
-hsTyVarName (KindedTyVar n _) = n
+hsTyVarName (KindedTyVar n _ _) = n
 
 hsTyVarKind :: HsTyVarBndr name -> Kind
 hsTyVarKind (UserTyVar _ k)   = k
-hsTyVarKind (KindedTyVar _ k) = k
+hsTyVarKind (KindedTyVar _ _ k) = k
+
+hsLTyVarKind :: LHsTyVarBndr name -> Kind
+hsLTyVarKind  = hsTyVarKind . unLoc
 
 hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind)
 hsTyVarNameKind (UserTyVar n k)   = (n,k)
-hsTyVarNameKind (KindedTyVar n k) = (n,k)
+hsTyVarNameKind (KindedTyVar n _ k) = (n,k)
 
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
@@ -287,12 +332,18 @@ hsLTyVarLocName = fmap hsTyVarName
 hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name]
 hsLTyVarLocNames = map hsLTyVarLocName
 
-replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
-replaceTyVarName (UserTyVar _ k)   n' = UserTyVar n' k
-replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k
-
-replaceLTyVarName :: LHsTyVarBndr name1 -> name2 -> LHsTyVarBndr name2
-replaceLTyVarName (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
+replaceTyVarName :: (Monad m) => HsTyVarBndr name1 -> name2  -- new type name
+                    -> (LHsKind name1 -> m (LHsKind name2))  -- kind renaming
+                    -> m (HsTyVarBndr name2)
+replaceTyVarName (UserTyVar _ k) n' _ = return $ UserTyVar n' k
+replaceTyVarName (KindedTyVar _ k tck) n' rn = do
+  k' <- rn k
+  return $ KindedTyVar n' k' tck
+
+replaceLTyVarName :: (Monad m) => LHsTyVarBndr name1 -> name2
+                  -> (LHsKind name1 -> m (LHsKind name2))
+                  -> m (LHsTyVarBndr name2)
+replaceLTyVarName (L loc n1) n2 rn = replaceTyVarName n1 n2 rn >>= return . L loc
 \end{code}
 
 
@@ -351,12 +402,12 @@ splitLHsClassTy_maybe ty
   = checkl ty []
   where
     checkl (L l ty) args = case ty of
-        HsTyVar t      -> Just (L l t, args)
-        HsAppTy l r    -> checkl l (r:args)
-        HsOpTy l tc r  -> checkl (fmap HsTyVar tc) (l:r:args)
-        HsParTy t      -> checkl t args
-        HsKindSig ty _ -> checkl ty args
-        _              -> Nothing
+        HsTyVar t          -> Just (L l t, args)
+        HsAppTy l r        -> checkl l (r:args)
+        HsOpTy l (_, tc) r -> checkl (fmap HsTyVar tc) (l:r:args)
+        HsParTy t          -> checkl t args
+        HsKindSig ty _     -> checkl ty args
+        _                  -> Nothing
 
 -- Splits HsType into the (init, last) parts
 -- Breaks up any parens in the result type: 
@@ -380,9 +431,9 @@ splitHsFunType other 	   	   = ([], other)
 instance (OutputableBndr name) => Outputable (HsType name) where
     ppr ty = pprHsType ty
 
-instance (Outputable name) => Outputable (HsTyVarBndr name) where
+instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name _)      = ppr name
-    ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind]
+    ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind]
 
 pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] ->  LHsContext name -> SDoc
 pprHsForAll exp tvs cxt 
@@ -470,12 +521,28 @@ ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
   where std_con = case con of
                     HsUnboxedTuple -> UnboxedTuple
                     HsBoxyTuple _  -> BoxedTuple
-ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
+ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
 ppr_mono_ty _    (HsListTy ty)	     = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)	     = pabrackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty prec (HsIParamTy n ty)   = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
+ppr_mono_ty _    (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
+ppr_mono_ty _    (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
+
+ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
+  = ppr_mono_ty ctxt_prec ty
+-- We are not printing kind applications. If we wanted to do so, we should do
+-- something like this:
+{-
+  = go ctxt_prec kis ty
+  where
+    go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty
+    go ctxt_prec (ki:kis) ty
+      = maybeParen ctxt_prec pREC_CON $
+        hsep [ go pREC_FUN kis ty
+             , ptext (sLit "@") <> pprParendKind ki ]
+-}
 
 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
   = maybeParen ctxt_prec pREC_OP $
@@ -485,9 +552,9 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty]
 
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2)  
+ppr_mono_ty ctxt_prec (HsOpTy ty1 (wrapper, op) ty2)
   = maybeParen ctxt_prec pREC_OP $
-    ppr_mono_lty pREC_OP ty1 <+> ppr op <+> ppr_mono_lty pREC_OP ty2
+    ppr_mono_lty pREC_OP ty1 <+> ppr_mono_ty pREC_CON (HsWrapTy wrapper (HsTyVar (unLoc op))) <+> ppr_mono_lty pREC_OP ty2
 
 ppr_mono_ty _         (HsParTy ty)
   = parens (ppr_mono_lty pREC_TOP ty)
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 63c60d1f3e..eb6ca87ba3 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1,21 +1,20 @@
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
+--
+--  (c) The University of Glasgow 2002-2006
+--
 
 {-# OPTIONS_GHC -O #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
 
---
---  (c) The University of Glasgow 2002-2006
---
--- Binary interface file support.
-
-module BinIface ( writeBinIface, readBinIface, getSymtabName, getDictFastString,
-                  CheckHiWay(..), TraceBinIFaceReading(..) ) where
+-- | Binary interface file support.
+module BinIface (
+        writeBinIface,
+        readBinIface,
+        getSymtabName,
+        getDictFastString,
+        CheckHiWay(..),
+        TraceBinIFaceReading(..)
+    ) where
 
 #include "HsVersions.h"
 
@@ -62,179 +61,182 @@ import Data.IORef
 import Control.Monad
 import System.Time ( ClockTime(..) )
 
+
+-- ---------------------------------------------------------------------------
+-- Reading and writing binary interface files
+--
+
 data CheckHiWay = CheckHiWay | IgnoreHiWay
     deriving Eq
 
 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
     deriving Eq
 
--- ---------------------------------------------------------------------------
--- Reading and writing binary interface files
-
+-- | Read an interface file
 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
              -> TcRnIf a b ModIface
 readBinIface checkHiWay traceBinIFaceReading hi_path = do
-  ncu <- mkNameCacheUpdater
-  dflags <- getDOpts
-  liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
+    ncu <- mkNameCacheUpdater
+    dflags <- getDOpts
+    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
 
 readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
               -> NameCacheUpdater
               -> IO ModIface
 readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
-  let printer :: SDoc -> IO ()
-      printer = case traceBinIFaceReading of
-                TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
-                QuietBinIFaceReading -> \_ -> return ()
-      wantedGot :: Outputable a => String -> a -> a -> IO ()
-      wantedGot what wanted got
-          = printer (text what <> text ": " <>
+    let printer :: SDoc -> IO ()
+        printer = case traceBinIFaceReading of
+                      TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
+                      QuietBinIFaceReading -> \_ -> return ()
+        wantedGot :: Outputable a => String -> a -> a -> IO ()
+        wantedGot what wanted got =
+            printer (text what <> text ": " <>
                      vcat [text "Wanted " <> ppr wanted <> text ",",
                            text "got    " <> ppr got])
 
-      errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
-      errorOnMismatch what wanted got
+        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
+        errorOnMismatch what wanted got =
             -- This will be caught by readIface which will emit an error
             -- msg containing the iface module name.
-          = when (wanted /= got) $ ghcError $ ProgramError
-                        (what ++ " (wanted " ++ show wanted
-                              ++ ", got "    ++ show got ++ ")")
-  bh <- Binary.readBinMem hi_path
-
-        -- Read the magic number to check that this really is a GHC .hi file
-        -- (This magic number does not change when we change
-        --  GHC interface file format)
-  magic <- get bh
-  wantedGot "Magic" (binaryInterfaceMagic dflags) magic
-  errorOnMismatch "magic number mismatch: old/corrupt interface file?"
-      (binaryInterfaceMagic dflags) magic
-
-        -- Note [dummy iface field]
-        -- read a dummy 32/64 bit value.  This field used to hold the
-        -- dictionary pointer in old interface file formats, but now
-        -- the dictionary pointer is after the version (where it
-        -- should be).  Also, the serialisation of value of type "Bin
-        -- a" used to depend on the word size of the machine, now they
-        -- are always 32 bits.
-        --
-  if wORD_SIZE == 4
-     then do _ <- Binary.get bh :: IO Word32; return ()
-     else do _ <- Binary.get bh :: IO Word64; return ()
-
-        -- Check the interface file version and ways.
-  check_ver  <- get bh
-  let our_ver = show opt_HiVersion
-  wantedGot "Version" our_ver check_ver
-  errorOnMismatch "mismatched interface file versions" our_ver check_ver
-
-  check_way <- get bh
-  let way_descr = getWayDescr dflags
-  wantedGot "Way" way_descr check_way
-  when (checkHiWay == CheckHiWay) $
-       errorOnMismatch "mismatched interface file ways" way_descr check_way
-
-        -- Read the dictionary
-        -- The next word in the file is a pointer to where the dictionary is
-        -- (probably at the end of the file)
-  dict_p <- Binary.get bh
-  data_p <- tellBin bh          -- Remember where we are now
-  seekBin bh dict_p
-  dict <- getDictionary bh
-  seekBin bh data_p             -- Back to where we were before
-
-        -- Initialise the user-data field of bh
-  bh <- do
-    bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
-                                                 (getDictFastString dict)
-
-    symtab_p <- Binary.get bh     -- Get the symtab ptr
+            when (wanted /= got) $ ghcError $ ProgramError
+                         (what ++ " (wanted " ++ show wanted
+                               ++ ", got "    ++ show got ++ ")")
+    bh <- Binary.readBinMem hi_path
+
+    -- Read the magic number to check that this really is a GHC .hi file
+    -- (This magic number does not change when we change
+    --  GHC interface file format)
+    magic <- get bh
+    wantedGot "Magic" (binaryInterfaceMagic dflags) magic
+    errorOnMismatch "magic number mismatch: old/corrupt interface file?"
+        (binaryInterfaceMagic dflags) magic
+
+    -- Note [dummy iface field]
+    -- read a dummy 32/64 bit value.  This field used to hold the
+    -- dictionary pointer in old interface file formats, but now
+    -- the dictionary pointer is after the version (where it
+    -- should be).  Also, the serialisation of value of type "Bin
+    -- a" used to depend on the word size of the machine, now they
+    -- are always 32 bits.
+    if wORD_SIZE == 4
+        then do _ <- Binary.get bh :: IO Word32; return ()
+        else do _ <- Binary.get bh :: IO Word64; return ()
+
+    -- Check the interface file version and ways.
+    check_ver  <- get bh
+    let our_ver = show opt_HiVersion
+    wantedGot "Version" our_ver check_ver
+    errorOnMismatch "mismatched interface file versions" our_ver check_ver
+
+    check_way <- get bh
+    let way_descr = getWayDescr dflags
+    wantedGot "Way" way_descr check_way
+    when (checkHiWay == CheckHiWay) $
+        errorOnMismatch "mismatched interface file ways" way_descr check_way
+
+    -- Read the dictionary
+    -- The next word in the file is a pointer to where the dictionary is
+    -- (probably at the end of the file)
+    dict_p <- Binary.get bh
     data_p <- tellBin bh          -- Remember where we are now
-    seekBin bh symtab_p
-    symtab <- getSymbolTable bh ncu
+    seekBin bh dict_p
+    dict   <- getDictionary bh
     seekBin bh data_p             -- Back to where we were before
-    
-    -- It is only now that we know how to get a Name
-    return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
-                                           (getDictFastString dict)
 
-        -- Read the interface file
-  get bh
+    -- Initialise the user-data field of bh
+    bh <- do
+        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
+                                                     (getDictFastString dict)
+        symtab_p <- Binary.get bh     -- Get the symtab ptr
+        data_p <- tellBin bh          -- Remember where we are now
+        seekBin bh symtab_p
+        symtab <- getSymbolTable bh ncu
+        seekBin bh data_p             -- Back to where we were before
+    
+        -- It is only now that we know how to get a Name
+        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
+                                               (getDictFastString dict)
 
+    -- Read the interface file
+    get bh
 
+-- | Write an interface file
 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
 writeBinIface dflags hi_path mod_iface = do
-  bh <- openBinMem initBinMemSize
-  put_ bh (binaryInterfaceMagic dflags)
-
-       -- dummy 32/64-bit field before the version/way for
-       -- compatibility with older interface file formats.
-       -- See Note [dummy iface field] above.
-  if wORD_SIZE == 4
-     then Binary.put_ bh (0 :: Word32)
-     else Binary.put_ bh (0 :: Word64)
-
-        -- The version and way descriptor go next
-  put_ bh (show opt_HiVersion)
-  let way_descr = getWayDescr dflags
-  put_  bh way_descr
-
-	-- Remember where the dictionary pointer will go
-  dict_p_p <- tellBin bh
-  put_ bh dict_p_p	-- Placeholder for ptr to dictionary
-
-        -- Remember where the symbol table pointer will go
-  symtab_p_p <- tellBin bh
-  put_ bh symtab_p_p
-
-	-- Make some intial state
-  symtab_next <- newFastMutInt
-  writeFastMutInt symtab_next 0
-  symtab_map <- newIORef emptyUFM
-  let bin_symtab = BinSymbolTable {
-                      bin_symtab_next = symtab_next,
-                      bin_symtab_map  = symtab_map }
-  dict_next_ref <- newFastMutInt
-  writeFastMutInt dict_next_ref 0
-  dict_map_ref <- newIORef emptyUFM
-  let bin_dict = BinDictionary {
-                      bin_dict_next = dict_next_ref,
-                      bin_dict_map  = dict_map_ref }
+    bh <- openBinMem initBinMemSize
+    put_ bh (binaryInterfaceMagic dflags)
+
+   -- dummy 32/64-bit field before the version/way for
+   -- compatibility with older interface file formats.
+   -- See Note [dummy iface field] above.
+    if wORD_SIZE == 4
+        then Binary.put_ bh (0 :: Word32)
+        else Binary.put_ bh (0 :: Word64)
+
+    -- The version and way descriptor go next
+    put_ bh (show opt_HiVersion)
+    let way_descr = getWayDescr dflags
+    put_  bh way_descr
+
+    -- Remember where the dictionary pointer will go
+    dict_p_p <- tellBin bh
+    -- Placeholder for ptr to dictionary
+    put_ bh dict_p_p
+
+    -- Remember where the symbol table pointer will go
+    symtab_p_p <- tellBin bh
+    put_ bh symtab_p_p
+
+    -- Make some intial state
+    symtab_next <- newFastMutInt
+    writeFastMutInt symtab_next 0
+    symtab_map <- newIORef emptyUFM
+    let bin_symtab = BinSymbolTable {
+                         bin_symtab_next = symtab_next,
+                         bin_symtab_map  = symtab_map }
+    dict_next_ref <- newFastMutInt
+    writeFastMutInt dict_next_ref 0
+    dict_map_ref <- newIORef emptyUFM
+    let bin_dict = BinDictionary {
+                       bin_dict_next = dict_next_ref,
+                       bin_dict_map  = dict_map_ref }
   
-	-- Put the main thing, 
-  bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
-                                                (putFastString bin_dict)
-  put_ bh mod_iface
-
-	-- Write the symtab pointer at the fornt of the file
-  symtab_p <- tellBin bh	        -- This is where the symtab will start
-  putAt bh symtab_p_p symtab_p	-- Fill in the placeholder
-  seekBin bh symtab_p		-- Seek back to the end of the file
-
-        -- Write the symbol table itself
-  symtab_next <- readFastMutInt symtab_next
-  symtab_map  <- readIORef symtab_map
-  putSymbolTable bh symtab_next symtab_map
-  debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next 
+    -- Put the main thing, 
+    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
+                                                  (putFastString bin_dict)
+    put_ bh mod_iface
+
+    -- Write the symtab pointer at the fornt of the file
+    symtab_p <- tellBin bh        -- This is where the symtab will start
+    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
+    seekBin bh symtab_p           -- Seek back to the end of the file
+
+    -- Write the symbol table itself
+    symtab_next <- readFastMutInt symtab_next
+    symtab_map  <- readIORef symtab_map
+    putSymbolTable bh symtab_next symtab_map
+    debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next 
                                 <+> text "Names")
 
-        -- NB. write the dictionary after the symbol table, because
-        -- writing the symbol table may create more dictionary entries.
+    -- NB. write the dictionary after the symbol table, because
+    -- writing the symbol table may create more dictionary entries.
 
-	-- Write the dictionary pointer at the fornt of the file
-  dict_p <- tellBin bh	        -- This is where the dictionary will start
-  putAt bh dict_p_p dict_p	-- Fill in the placeholder
-  seekBin bh dict_p		-- Seek back to the end of the file
+    -- Write the dictionary pointer at the fornt of the file
+    dict_p <- tellBin bh          -- This is where the dictionary will start
+    putAt bh dict_p_p dict_p      -- Fill in the placeholder
+    seekBin bh dict_p             -- Seek back to the end of the file
 
-	-- Write the dictionary itself
-  dict_next <- readFastMutInt dict_next_ref
-  dict_map  <- readIORef dict_map_ref
-  putDictionary bh dict_next dict_map
-  debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
-                                 <+> text "dict entries")
+    -- Write the dictionary itself
+    dict_next <- readFastMutInt dict_next_ref
+    dict_map  <- readIORef dict_map_ref
+    putDictionary bh dict_next dict_map
+    debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
+                                <+> text "dict entries")
 
-	-- And send the result to the file
-  writeBinMem bh hi_path
+    -- And send the result to the file
+    writeBinMem bh hi_path
 
+-- | Initial ram buffer to allocate for writing interface files
 initBinMemSize :: Int
 initBinMemSize = 1024 * 1024
 
@@ -243,54 +245,45 @@ binaryInterfaceMagic dflags
  | target32Bit (targetPlatform dflags) = 0x1face
  | otherwise                           = 0x1face64
 
+
 -- -----------------------------------------------------------------------------
 -- The symbol table
+--
 
 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
 putSymbolTable bh next_off symtab = do
-  put_ bh next_off
-  let names = elems (array (0,next_off-1) (eltsUFM symtab))
-  mapM_ (\n -> serialiseName bh n symtab) names
+    put_ bh next_off
+    let names = elems (array (0,next_off-1) (eltsUFM symtab))
+    mapM_ (\n -> serialiseName bh n symtab) names
 
-getSymbolTable :: BinHandle -> NameCacheUpdater
-               -> IO SymbolTable
+getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
 getSymbolTable bh ncu = do
-  sz <- get bh
-  od_names <- sequence (replicate sz (get bh))
-  updateNameCache ncu $ \namecache ->
-    let
-        arr = listArray (0,sz-1) names
-        (namecache', names) =    
+    sz <- get bh
+    od_names <- sequence (replicate sz (get bh))
+    updateNameCache ncu $ \namecache ->
+        let arr = listArray (0,sz-1) names
+            (namecache', names) =    
                 mapAccumR (fromOnDiskName arr) namecache od_names
-    in (namecache', arr)
+        in (namecache', arr)
 
 type OnDiskName = (PackageId, ModuleName, OccName)
 
-fromOnDiskName
-   :: Array Int Name
-   -> NameCache
-   -> OnDiskName
-   -> (NameCache, Name)
+fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name)
 fromOnDiskName _ nc (pid, mod_name, occ) =
-  let
-        mod   = mkModule pid mod_name
+    let mod   = mkModule pid mod_name
         cache = nsNames nc
-  in
-  case lookupOrigNameCache cache  mod occ of
-     Just name -> (nc, name)
-     Nothing   ->
-        case takeUniqFromSupply (nsUniqs nc) of
-        (uniq, us) ->
-            let
-                name      = mkExternalName uniq mod occ noSrcSpan
-                new_cache = extendNameCache cache mod occ name
-            in
-            ( nc{ nsUniqs = us, nsNames = new_cache }, name )
+    in case lookupOrigNameCache cache  mod occ of
+           Just name -> (nc, name)
+           Nothing   ->
+               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+                   name       = mkExternalName uniq mod occ noSrcSpan
+                   new_cache  = extendNameCache cache mod occ name
+               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
 
 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
 serialiseName bh name _ = do
-  let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
-  put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
+    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+    put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
 
 
 -- Note [Symbol table representation of names]
@@ -318,8 +311,7 @@ knownKeyNamesMap :: UniqFM Name
 knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames]
   where
     knownKeyNames :: [Name]
-    knownKeyNames = map getName wiredInThings
-                    ++ basicKnownKeyNames
+    knownKeyNames = map getName wiredInThings ++ basicKnownKeyNames
 
 
 -- See Note [Symbol table representation of names]
@@ -479,148 +471,152 @@ data BinDictionary = BinDictionary {
 
 instance Binary ModIface where
    put_ bh (ModIface {
-		 mi_module    = mod,
-		 mi_boot      = is_boot,
-		 mi_iface_hash= iface_hash,
-		 mi_mod_hash  = mod_hash,
-		 mi_orphan    = orphan,
-		 mi_finsts    = hasFamInsts,
-		 mi_deps      = deps,
-		 mi_usages    = usages,
-		 mi_exports   = exports,
-		 mi_exp_hash  = exp_hash,
+                 mi_module    = mod,
+                 mi_boot      = is_boot,
+                 mi_iface_hash= iface_hash,
+                 mi_mod_hash  = mod_hash,
+                 mi_flag_hash = flag_hash,
+                 mi_orphan    = orphan,
+                 mi_finsts    = hasFamInsts,
+                 mi_deps      = deps,
+                 mi_usages    = usages,
+                 mi_exports   = exports,
+                 mi_exp_hash  = exp_hash,
                  mi_used_th   = used_th,
                  mi_fixities  = fixities,
-		 mi_warns     = warns,
-		 mi_anns      = anns,
-		 mi_decls     = decls,
-		 mi_insts     = insts,
-		 mi_fam_insts = fam_insts,
-		 mi_rules     = rules,
-		 mi_orphan_hash = orphan_hash,
+                 mi_warns     = warns,
+                 mi_anns      = anns,
+                 mi_decls     = decls,
+                 mi_insts     = insts,
+                 mi_fam_insts = fam_insts,
+                 mi_rules     = rules,
+                 mi_orphan_hash = orphan_hash,
                  mi_vect_info = vect_info,
                  mi_hpc       = hpc_info,
                  mi_trust     = trust,
                  mi_trust_pkg = trust_pkg }) = do
-	put_ bh mod
-	put_ bh is_boot
-	put_ bh iface_hash
-	put_ bh mod_hash
-	put_ bh orphan
-	put_ bh hasFamInsts
-	lazyPut bh deps
-	lazyPut bh usages
-	put_ bh exports
-	put_ bh exp_hash
+        put_ bh mod
+        put_ bh is_boot
+        put_ bh iface_hash
+        put_ bh mod_hash
+        put_ bh flag_hash
+        put_ bh orphan
+        put_ bh hasFamInsts
+        lazyPut bh deps
+        lazyPut bh usages
+        put_ bh exports
+        put_ bh exp_hash
         put_ bh used_th
         put_ bh fixities
-	lazyPut bh warns
-	lazyPut bh anns
+        lazyPut bh warns
+        lazyPut bh anns
         put_ bh decls
-	put_ bh insts
-	put_ bh fam_insts
-	lazyPut bh rules
-	put_ bh orphan_hash
+        put_ bh insts
+        put_ bh fam_insts
+        lazyPut bh rules
+        put_ bh orphan_hash
         put_ bh vect_info
-	put_ bh hpc_info
-	put_ bh trust
-	put_ bh trust_pkg
+        put_ bh hpc_info
+        put_ bh trust
+        put_ bh trust_pkg
 
    get bh = do
-	mod_name  <- get bh
-	is_boot   <- get bh
-	iface_hash <- get bh
-	mod_hash  <- get bh
-	orphan    <- get bh
-	hasFamInsts <- get bh
-	deps	  <- lazyGet bh
-	usages	  <- lazyGet bh
-	exports	  <- get bh
-	exp_hash  <- get bh
-        used_th   <- get bh
-        fixities  <- get bh
-	warns     <- lazyGet bh
-	anns      <- lazyGet bh
-        decls 	  <- get bh
-	insts     <- get bh
-	fam_insts <- get bh
-	rules	  <- lazyGet bh
-	orphan_hash <- get bh
-        vect_info <- get bh
-        hpc_info  <- get bh
-        trust     <- get bh
-        trust_pkg <- get bh
-	return (ModIface {
-		 mi_module    = mod_name,
-		 mi_boot      = is_boot,
-		 mi_iface_hash = iface_hash,
-		 mi_mod_hash  = mod_hash,
-		 mi_orphan    = orphan,
-		 mi_finsts    = hasFamInsts,
-		 mi_deps      = deps,
-		 mi_usages    = usages,
-		 mi_exports   = exports,
-                 mi_exp_hash  = exp_hash,
-                 mi_used_th   = used_th,
-                 mi_anns      = anns,
-		 mi_fixities  = fixities,
-		 mi_warns     = warns,
-		 mi_decls     = decls,
-		 mi_globals   = Nothing,
-		 mi_insts     = insts,
-		 mi_fam_insts = fam_insts,
-		 mi_rules     = rules,
-		 mi_orphan_hash = orphan_hash,
-                 mi_vect_info = vect_info,
-		 mi_hpc       = hpc_info,
-		 mi_trust     = trust,
-		 mi_trust_pkg = trust_pkg,
-			-- And build the cached values
-		 mi_warn_fn   = mkIfaceWarnCache warns,
-		 mi_fix_fn    = mkIfaceFixCache fixities,
-		 mi_hash_fn   = mkIfaceHashCache decls })
+        mod_name    <- get bh
+        is_boot     <- get bh
+        iface_hash  <- get bh
+        mod_hash    <- get bh
+        flag_hash   <- get bh
+        orphan      <- get bh
+        hasFamInsts <- get bh
+        deps        <- lazyGet bh
+        usages      <- {-# SCC "bin_usages" #-} lazyGet bh
+        exports     <- {-# SCC "bin_exports" #-} get bh
+        exp_hash    <- get bh
+        used_th     <- get bh
+        fixities    <- {-# SCC "bin_fixities" #-} get bh
+        warns       <- {-# SCC "bin_warns" #-} lazyGet bh
+        anns        <- {-# SCC "bin_anns" #-} lazyGet bh
+        decls       <- {-# SCC "bin_tycldecls" #-} get bh
+        insts       <- {-# SCC "bin_insts" #-} get bh
+        fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh
+        rules       <- {-# SCC "bin_rules" #-} lazyGet bh
+        orphan_hash <- get bh
+        vect_info   <- get bh
+        hpc_info    <- get bh
+        trust       <- get bh
+        trust_pkg   <- get bh
+        return (ModIface {
+                 mi_module      = mod_name,
+                 mi_boot        = is_boot,
+                 mi_iface_hash  = iface_hash,
+                 mi_mod_hash    = mod_hash,
+                 mi_flag_hash   = flag_hash,
+                 mi_orphan      = orphan,
+                 mi_finsts      = hasFamInsts,
+                 mi_deps        = deps,
+                 mi_usages      = usages,
+                 mi_exports     = exports,
+                 mi_exp_hash    = exp_hash,
+                 mi_used_th     = used_th,
+                 mi_anns        = anns,
+                 mi_fixities    = fixities,
+                 mi_warns       = warns,
+                 mi_decls       = decls,
+                 mi_globals     = Nothing,
+                 mi_insts       = insts,
+                 mi_fam_insts   = fam_insts,
+                 mi_rules       = rules,
+                 mi_orphan_hash = orphan_hash,
+                 mi_vect_info   = vect_info,
+                 mi_hpc         = hpc_info,
+                 mi_trust       = trust,
+                 mi_trust_pkg   = trust_pkg,
+                        -- And build the cached values
+                 mi_warn_fn     = mkIfaceWarnCache warns,
+                 mi_fix_fn      = mkIfaceFixCache fixities,
+                 mi_hash_fn     = mkIfaceHashCache decls })
 
 getWayDescr :: DynFlags -> String
 getWayDescr dflags
   | cGhcUnregisterised == "YES" = 'u':tag
   | otherwise                   = tag
   where tag = buildTag dflags
-	-- if this is an unregisterised build, make sure our interfaces
-	-- can't be used by a registerised build.
+        -- if this is an unregisterised build, make sure our interfaces
+        -- can't be used by a registerised build.
 
 -------------------------------------------------------------------------
---		Types from: HscTypes
+--              Types from: HscTypes
 -------------------------------------------------------------------------
 
 instance Binary Dependencies where
     put_ bh deps = do put_ bh (dep_mods deps)
-		      put_ bh (dep_pkgs deps)
-		      put_ bh (dep_orphs deps)
-		      put_ bh (dep_finsts deps)
+                      put_ bh (dep_pkgs deps)
+                      put_ bh (dep_orphs deps)
+                      put_ bh (dep_finsts deps)
 
     get bh = do ms <- get bh 
-		ps <- get bh
-		os <- get bh
-		fis <- get bh
-		return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
-			       dep_finsts = fis })
+                ps <- get bh
+                os <- get bh
+                fis <- get bh
+                return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
+                               dep_finsts = fis })
 
 instance Binary AvailInfo where
     put_ bh (Avail aa) = do
-	    putByte bh 0
-	    put_ bh aa
+            putByte bh 0
+            put_ bh aa
     put_ bh (AvailTC ab ac) = do
-	    putByte bh 1
-	    put_ bh ab
-	    put_ bh ac
+            putByte bh 1
+            put_ bh ab
+            put_ bh ac
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do aa <- get bh
-		      return (Avail aa)
-	      _ -> do ab <- get bh
-		      ac <- get bh
-		      return (AvailTC ab ac)
+            h <- getByte bh
+            case h of
+              0 -> do aa <- get bh
+                      return (Avail aa)
+              _ -> do ab <- get bh
+                      ac <- get bh
+                      return (AvailTC ab ac)
 
     
 -- where should this be located?
@@ -709,29 +705,29 @@ instance Binary WarningTxt where
                       return (DeprecatedTxt d)
 
 -------------------------------------------------------------------------
---		Types from: BasicTypes
+--              Types from: BasicTypes
 -------------------------------------------------------------------------
 
 instance Binary Activation where
     put_ bh NeverActive = do
-	    putByte bh 0
+            putByte bh 0
     put_ bh AlwaysActive = do
-	    putByte bh 1
+            putByte bh 1
     put_ bh (ActiveBefore aa) = do
-	    putByte bh 2
-	    put_ bh aa
+            putByte bh 2
+            put_ bh aa
     put_ bh (ActiveAfter ab) = do
-	    putByte bh 3
-	    put_ bh ab
+            putByte bh 3
+            put_ bh ab
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do return NeverActive
-	      1 -> do return AlwaysActive
-	      2 -> do aa <- get bh
-		      return (ActiveBefore aa)
-	      _ -> do ab <- get bh
-		      return (ActiveAfter ab)
+            h <- getByte bh
+            case h of
+              0 -> do return NeverActive
+              1 -> do return AlwaysActive
+              2 -> do aa <- get bh
+                      return (ActiveBefore aa)
+              _ -> do ab <- get bh
+                      return (ActiveAfter ab)
 
 instance Binary RuleMatchInfo where
     put_ bh FunLike = putByte bh 0
@@ -773,13 +769,15 @@ instance Binary HsBang where
     put_ bh HsStrict        = putByte bh 1
     put_ bh HsUnpack        = putByte bh 2
     put_ bh HsUnpackFailed  = putByte bh 3
+    put_ bh HsNoUnpack      = putByte bh 4
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do return HsNoBang
-	      1 -> do return HsStrict
-	      2 -> do return HsUnpack
-	      _ -> do return HsUnpackFailed
+            h <- getByte bh
+            case h of
+              0 -> do return HsNoBang
+              1 -> do return HsStrict
+              2 -> do return HsUnpack
+              3 -> do return HsUnpackFailed
+              _ -> do return HsNoUnpack
 
 instance Binary TupleSort where
     put_ bh BoxedTuple      = putByte bh 0
@@ -794,254 +792,324 @@ instance Binary TupleSort where
 
 instance Binary RecFlag where
     put_ bh Recursive = do
-	    putByte bh 0
+            putByte bh 0
     put_ bh NonRecursive = do
-	    putByte bh 1
+            putByte bh 1
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do return Recursive
-	      _ -> do return NonRecursive
+            h <- getByte bh
+            case h of
+              0 -> do return Recursive
+              _ -> do return NonRecursive
 
 instance Binary DefMethSpec where
     put_ bh NoDM      = putByte bh 0
     put_ bh VanillaDM = putByte bh 1
     put_ bh GenericDM = putByte bh 2
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> return NoDM
-	      1 -> return VanillaDM
-	      _ -> return GenericDM
+            h <- getByte bh
+            case h of
+              0 -> return NoDM
+              1 -> return VanillaDM
+              _ -> return GenericDM
 
 instance Binary FixityDirection where
     put_ bh InfixL = do
-	    putByte bh 0
+            putByte bh 0
     put_ bh InfixR = do
-	    putByte bh 1
+            putByte bh 1
     put_ bh InfixN = do
-	    putByte bh 2
+            putByte bh 2
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do return InfixL
-	      1 -> do return InfixR
-	      _ -> do return InfixN
+            h <- getByte bh
+            case h of
+              0 -> do return InfixL
+              1 -> do return InfixR
+              _ -> do return InfixN
 
 instance Binary Fixity where
     put_ bh (Fixity aa ab) = do
-	    put_ bh aa
-	    put_ bh ab
+            put_ bh aa
+            put_ bh ab
     get bh = do
-	  aa <- get bh
-	  ab <- get bh
-	  return (Fixity aa ab)
+          aa <- get bh
+          ab <- get bh
+          return (Fixity aa ab)
 
 instance (Binary name) => Binary (IPName name) where
     put_ bh (IPName aa) = put_ bh aa
     get bh = do aa <- get bh
-	        return (IPName aa)
+                return (IPName aa)
 
 -------------------------------------------------------------------------
---		Types from: Demand
+--              Types from: Demand
 -------------------------------------------------------------------------
 
 instance Binary DmdType where
-	-- Ignore DmdEnv when spitting out the DmdType
+        -- Ignore DmdEnv when spitting out the DmdType
   put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
 
 instance Binary Demand where
     put_ bh Top = do
-	    putByte bh 0
+            putByte bh 0
     put_ bh Abs = do
-	    putByte bh 1
+            putByte bh 1
     put_ bh (Call aa) = do
-	    putByte bh 2
-	    put_ bh aa
+            putByte bh 2
+            put_ bh aa
     put_ bh (Eval ab) = do
-	    putByte bh 3
-	    put_ bh ab
+            putByte bh 3
+            put_ bh ab
     put_ bh (Defer ac) = do
-	    putByte bh 4
-	    put_ bh ac
+            putByte bh 4
+            put_ bh ac
     put_ bh (Box ad) = do
-	    putByte bh 5
-	    put_ bh ad
+            putByte bh 5
+            put_ bh ad
     put_ bh Bot = do
-	    putByte bh 6
+            putByte bh 6
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do return Top
-	      1 -> do return Abs
-	      2 -> do aa <- get bh
-		      return (Call aa)
-	      3 -> do ab <- get bh
-		      return (Eval ab)
-	      4 -> do ac <- get bh
-		      return (Defer ac)
-	      5 -> do ad <- get bh
-		      return (Box ad)
-	      _ -> do return Bot
+            h <- getByte bh
+            case h of
+              0 -> do return Top
+              1 -> do return Abs
+              2 -> do aa <- get bh
+                      return (Call aa)
+              3 -> do ab <- get bh
+                      return (Eval ab)
+              4 -> do ac <- get bh
+                      return (Defer ac)
+              5 -> do ad <- get bh
+                      return (Box ad)
+              _ -> do return Bot
 
 instance Binary Demands where
     put_ bh (Poly aa) = do
-	    putByte bh 0
-	    put_ bh aa
+            putByte bh 0
+            put_ bh aa
     put_ bh (Prod ab) = do
-	    putByte bh 1
-	    put_ bh ab
+            putByte bh 1
+            put_ bh ab
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do aa <- get bh
-		      return (Poly aa)
-	      _ -> do ab <- get bh
-		      return (Prod ab)
+            h <- getByte bh
+            case h of
+              0 -> do aa <- get bh
+                      return (Poly aa)
+              _ -> do ab <- get bh
+                      return (Prod ab)
 
 instance Binary DmdResult where
     put_ bh TopRes = do
-	    putByte bh 0
+            putByte bh 0
     put_ bh RetCPR = do
-	    putByte bh 1
+            putByte bh 1
     put_ bh BotRes = do
-	    putByte bh 2
+            putByte bh 2
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do return TopRes
-	      1 -> do return RetCPR	-- Really use RetCPR even if -fcpr-off
-					-- The wrapper was generated for CPR in 
-					-- the imported module!
-	      _ -> do return BotRes
+            h <- getByte bh
+            case h of
+              0 -> do return TopRes
+              1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
+                                        -- The wrapper was generated for CPR in 
+                                        -- the imported module!
+              _ -> do return BotRes
 
 instance Binary StrictSig where
     put_ bh (StrictSig aa) = do
-	    put_ bh aa
+            put_ bh aa
     get bh = do
-	  aa <- get bh
-	  return (StrictSig aa)
+          aa <- get bh
+          return (StrictSig aa)
 
 
 -------------------------------------------------------------------------
---		Types from: CostCentre
+--              Types from: CostCentre
 -------------------------------------------------------------------------
 
 instance Binary IsCafCC where
     put_ bh CafCC = do
-	    putByte bh 0
+            putByte bh 0
     put_ bh NotCafCC = do
-	    putByte bh 1
+            putByte bh 1
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do return CafCC
-	      _ -> do return NotCafCC
+            h <- getByte bh
+            case h of
+              0 -> do return CafCC
+              _ -> do return NotCafCC
 
 instance Binary CostCentre where
     put_ bh NoCostCentre = do
-	    putByte bh 0
+            putByte bh 0
     put_ bh (NormalCC aa ab ac) = do
-	    putByte bh 1
-	    put_ bh aa
-	    put_ bh ab
-	    put_ bh ac
+            putByte bh 1
+            put_ bh aa
+            put_ bh ab
+            put_ bh ac
     put_ bh (AllCafsCC ae) = do
-	    putByte bh 2
-	    put_ bh ae
+            putByte bh 2
+            put_ bh ae
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do return NoCostCentre
-	      1 -> do aa <- get bh
-		      ab <- get bh
-		      ac <- get bh
+            h <- getByte bh
+            case h of
+              0 -> do return NoCostCentre
+              1 -> do aa <- get bh
+                      ab <- get bh
+                      ac <- get bh
                       return (NormalCC aa ab ac)
-	      _ -> do ae <- get bh
-		      return (AllCafsCC ae)
+              _ -> do ae <- get bh
+                      return (AllCafsCC ae)
 
 -------------------------------------------------------------------------
---		IfaceTypes and friends
+--              IfaceTypes and friends
 -------------------------------------------------------------------------
 
 instance Binary IfaceBndr where
     put_ bh (IfaceIdBndr aa) = do
-	    putByte bh 0
-	    put_ bh aa
+            putByte bh 0
+            put_ bh aa
     put_ bh (IfaceTvBndr ab) = do
-	    putByte bh 1
-	    put_ bh ab
+            putByte bh 1
+            put_ bh ab
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do aa <- get bh
-		      return (IfaceIdBndr aa)
-	      _ -> do ab <- get bh
-		      return (IfaceTvBndr ab)
+            h <- getByte bh
+            case h of
+              0 -> do aa <- get bh
+                      return (IfaceIdBndr aa)
+              _ -> do ab <- get bh
+                      return (IfaceTvBndr ab)
 
 instance Binary IfaceLetBndr where
     put_ bh (IfLetBndr a b c) = do
-	    put_ bh a
-	    put_ bh b
-	    put_ bh c
+            put_ bh a
+            put_ bh b
+            put_ bh c
     get bh = do a <- get bh
-	        b <- get bh
-	        c <- get bh
-		return (IfLetBndr a b c)	   
+                b <- get bh
+                c <- get bh
+                return (IfLetBndr a b c)           
 
 instance Binary IfaceType where
     put_ bh (IfaceForAllTy aa ab) = do
-	    putByte bh 0
-	    put_ bh aa
-	    put_ bh ab
+            putByte bh 0
+            put_ bh aa
+            put_ bh ab
     put_ bh (IfaceTyVar ad) = do
-	    putByte bh 1
-	    put_ bh ad
+            putByte bh 1
+            put_ bh ad
     put_ bh (IfaceAppTy ae af) = do
-	    putByte bh 2
-	    put_ bh ae
-	    put_ bh af
+            putByte bh 2
+            put_ bh ae
+            put_ bh af
     put_ bh (IfaceFunTy ag ah) = do
-	    putByte bh 3
-	    put_ bh ag
-	    put_ bh ah
+            putByte bh 3
+            put_ bh ag
+            put_ bh ah
     
-	-- Simple compression for common cases of TyConApp
-    put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 4; put_ bh k }
-    put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 5; put_ bh tc; put_ bh tys }
-    put_ bh (IfaceTyConApp tc tys) 	     = do { putByte bh 6; put_ bh tc; put_ bh tys }
-
-    put_ bh (IfaceCoConApp cc tys) = do { putByte bh 7; put_ bh cc; put_ bh tys }
+        -- Simple compression for common cases of TyConApp
+    put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
+    put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
+    put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
+    put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
+        -- Unit tuple and pairs
+    put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10
+    put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2])
+      = do { putByte bh 11; put_ bh t1; put_ bh t2 }
+        -- Kind cases
+    put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
+    put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
+    put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
+    put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
+    put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
+    put_ bh (IfaceTyConApp IfaceConstraintKindTc [])   = putByte bh 17
+    put_ bh (IfaceTyConApp IfaceSuperKindTc [])        = putByte bh 18
+
+    put_ bh (IfaceCoConApp cc tys)
+      = do { putByte bh 19; put_ bh cc; put_ bh tys }
+
+        -- Generic cases
+    put_ bh (IfaceTyConApp (IfaceTc tc) tys)
+      = do { putByte bh 20; put_ bh tc; put_ bh tys }
+    put_ bh (IfaceTyConApp tc tys)
+      = do { putByte bh 21; put_ bh tc; put_ bh tys }
 
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do aa <- get bh
-		      ab <- get bh
-		      return (IfaceForAllTy aa ab)
-	      1 -> do ad <- get bh
-		      return (IfaceTyVar ad)
-	      2 -> do ae <- get bh
-		      af <- get bh
-		      return (IfaceAppTy ae af)
-	      3 -> do ag <- get bh
-		      ah <- get bh
-		      return (IfaceFunTy ag ah)
-              4 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
-	      5 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
-	      6 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
-	      _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
+            h <- getByte bh
+            case h of
+              0 -> do aa <- get bh
+                      ab <- get bh
+                      return (IfaceForAllTy aa ab)
+              1 -> do ad <- get bh
+                      return (IfaceTyVar ad)
+              2 -> do ae <- get bh
+                      af <- get bh
+                      return (IfaceAppTy ae af)
+              3 -> do ag <- get bh
+                      ah <- get bh
+                      return (IfaceFunTy ag ah)
+              
+                -- Now the special cases for TyConApp
+              6 -> return (IfaceTyConApp IfaceIntTc [])
+              7 -> return (IfaceTyConApp IfaceCharTc [])
+              8 -> return (IfaceTyConApp IfaceBoolTc [])
+              9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
+              10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) [])
+              11 -> do { t1 <- get bh; t2 <- get bh
+                       ; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) }
+              12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
+              13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
+              14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
+              15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
+              16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
+              17 -> return (IfaceTyConApp IfaceConstraintKindTc [])
+              18 -> return (IfaceTyConApp IfaceSuperKindTc [])
+
+              19 -> do { cc <- get bh; tys <- get bh
+                        ; return (IfaceCoConApp cc tys) }
+
+              20 -> do { tc <- get bh; tys <- get bh
+                       ; return (IfaceTyConApp (IfaceTc tc) tys) }
+              21 -> do { tc <- get bh; tys <- get bh
+                        ; return (IfaceTyConApp tc tys) }
+
+              _  -> panic ("get IfaceType " ++ show h)
 
 instance Binary IfaceTyCon where
-   put_ bh (IfaceTc ext)  = do { putByte bh 1; put_ bh ext }
-   put_ bh (IfaceAnyTc k) = do { putByte bh 2; put_ bh k }
+        -- Int,Char,Bool can't show up here because they can't not be saturated
+   put_ bh IfaceIntTc         = putByte bh 1
+   put_ bh IfaceBoolTc        = putByte bh 2
+   put_ bh IfaceCharTc        = putByte bh 3
+   put_ bh IfaceListTc        = putByte bh 4
+   put_ bh IfacePArrTc        = putByte bh 5
+   put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
+   put_ bh IfaceOpenTypeKindTc     = putByte bh 7
+   put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
+   put_ bh IfaceUbxTupleKindTc     = putByte bh 9
+   put_ bh IfaceArgTypeKindTc      = putByte bh 10
+   put_ bh IfaceConstraintKindTc   = putByte bh 11
+   put_ bh IfaceSuperKindTc        = putByte bh 12
+   put_ bh (IfaceTupTc bx ar)  = do { putByte bh 13; put_ bh bx; put_ bh ar }
+   put_ bh (IfaceTc ext)       = do { putByte bh 14; put_ bh ext }
+   put_ bh (IfaceIPTc n)       = do { putByte bh 15; put_ bh n }
 
    get bh = do
-	h <- getByte bh
-	case h of
-	  1 -> do { ext <- get bh; return (IfaceTc ext) }
-	  _ -> do { k <- get bh; return (IfaceAnyTc k) }
+        h <- getByte bh
+        case h of
+          1 -> return IfaceIntTc
+          2 -> return IfaceBoolTc
+          3 -> return IfaceCharTc
+          4 -> return IfaceListTc
+          5 -> return IfacePArrTc
+          6 -> return IfaceLiftedTypeKindTc 
+          7 -> return IfaceOpenTypeKindTc 
+          8 -> return IfaceUnliftedTypeKindTc
+          9 -> return IfaceUbxTupleKindTc
+          10 -> return IfaceArgTypeKindTc
+          11 -> return IfaceConstraintKindTc
+          12 -> return IfaceSuperKindTc
+          13 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
+          14 -> do { ext <- get bh; return (IfaceTc ext) }
+          15 -> do { n <- get bh; return (IfaceIPTc n) }
+          _  -> panic ("get IfaceTyCon " ++ show h)
 
 instance Binary IfaceCoCon where
    put_ bh (IfaceCoAx n)       = do { putByte bh 0; put_ bh n }
@@ -1054,273 +1122,241 @@ instance Binary IfaceCoCon where
    put_ bh (IfaceIPCoAx ip)    = do { putByte bh 7; put_ bh ip }
   
    get bh = do
-	h <- getByte bh
-	case h of
+        h <- getByte bh
+        case h of
           0 -> do { n <- get bh; return (IfaceCoAx n) }
-	  1 -> return IfaceReflCo 
-	  2 -> return IfaceUnsafeCo
-	  3 -> return IfaceSymCo
-	  4 -> return IfaceTransCo
-	  5 -> return IfaceInstCo
+          1 -> return IfaceReflCo 
+          2 -> return IfaceUnsafeCo
+          3 -> return IfaceSymCo
+          4 -> return IfaceTransCo
+          5 -> return IfaceInstCo
           6 -> do { d <- get bh; return (IfaceNthCo d) }
-          _ -> do { ip <- get bh; return (IfaceIPCoAx ip) }
+          7 -> do { ip <- get bh; return (IfaceIPCoAx ip) }
+          _ -> panic ("get IfaceCoCon " ++ show h)
 
 -------------------------------------------------------------------------
---		IfaceExpr and friends
+--              IfaceExpr and friends
 -------------------------------------------------------------------------
 
 instance Binary IfaceExpr where
     put_ bh (IfaceLcl aa) = do
-	    putByte bh 0
-	    put_ bh aa
+        putByte bh 0
+        put_ bh aa
     put_ bh (IfaceType ab) = do
-	    putByte bh 1
-	    put_ bh ab
+        putByte bh 1
+        put_ bh ab
     put_ bh (IfaceCo ab) = do
-	    putByte bh 2
-	    put_ bh ab
+        putByte bh 2
+        put_ bh ab
     put_ bh (IfaceTuple ac ad) = do
-	    putByte bh 3
-	    put_ bh ac
-	    put_ bh ad
+        putByte bh 3
+        put_ bh ac
+        put_ bh ad
     put_ bh (IfaceLam ae af) = do
-	    putByte bh 4
-	    put_ bh ae
-	    put_ bh af
+        putByte bh 4
+        put_ bh ae
+        put_ bh af
     put_ bh (IfaceApp ag ah) = do
-	    putByte bh 5
-	    put_ bh ag
-	    put_ bh ah
+        putByte bh 5
+        put_ bh ag
+        put_ bh ah
     put_ bh (IfaceCase ai aj ak) = do
-	    putByte bh 6
-	    put_ bh ai
-	    put_ bh aj
-	    put_ bh ak
+        putByte bh 6
+        put_ bh ai
+        put_ bh aj
+        put_ bh ak
     put_ bh (IfaceLet al am) = do
-	    putByte bh 7
-	    put_ bh al
-	    put_ bh am
+        putByte bh 7
+        put_ bh al
+        put_ bh am
     put_ bh (IfaceTick an ao) = do
-	    putByte bh 8
-	    put_ bh an
-	    put_ bh ao
+        putByte bh 8
+        put_ bh an
+        put_ bh ao
     put_ bh (IfaceLit ap) = do
-	    putByte bh 9
-	    put_ bh ap
+        putByte bh 9
+        put_ bh ap
     put_ bh (IfaceFCall as at) = do
-	    putByte bh 10
-	    put_ bh as
-	    put_ bh at
+        putByte bh 10
+        put_ bh as
+        put_ bh at
     put_ bh (IfaceExt aa) = do
-	    putByte bh 11
-	    put_ bh aa
+        putByte bh 11
+        put_ bh aa
     put_ bh (IfaceCast ie ico) = do
-            putByte bh 12
-            put_ bh ie
-            put_ bh ico
+        putByte bh 12
+        put_ bh ie
+        put_ bh ico
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do aa <- get bh
-		      return (IfaceLcl aa)
-	      1 -> do ab <- get bh
-		      return (IfaceType ab)
-	      2 -> do ab <- get bh
-		      return (IfaceCo ab)
-	      3 -> do ac <- get bh
-		      ad <- get bh
-		      return (IfaceTuple ac ad)
-	      4 -> do ae <- get bh
-		      af <- get bh
-		      return (IfaceLam ae af)
-	      5 -> do ag <- get bh
-		      ah <- get bh
-		      return (IfaceApp ag ah)
-	      6 -> do ai <- get bh
-		      aj <- get bh
-		      ak <- get bh
-		      return (IfaceCase ai aj ak)
-	      7 -> do al <- get bh
-		      am <- get bh
-		      return (IfaceLet al am)
-	      8 -> do an <- get bh
-		      ao <- get bh
-                      return (IfaceTick an ao)
-	      9 -> do ap <- get bh
-		      return (IfaceLit ap)
-	      10 -> do as <- get bh
-		       at <- get bh
-		       return (IfaceFCall as at)
-	      11 -> do aa <- get bh
-		       return (IfaceExt aa)
-              12 -> do ie <- get bh
-                       ico <- get bh
-                       return (IfaceCast ie ico)
-              _ -> panic ("get IfaceExpr " ++ show h)
+        h <- getByte bh
+        case h of
+            0 -> do aa <- get bh
+                    return (IfaceLcl aa)
+            1 -> do ab <- get bh
+                    return (IfaceType ab)
+            2 -> do ab <- get bh
+                    return (IfaceCo ab)
+            3 -> do ac <- get bh
+                    ad <- get bh
+                    return (IfaceTuple ac ad)
+            4 -> do ae <- get bh
+                    af <- get bh
+                    return (IfaceLam ae af)
+            5 -> do ag <- get bh
+                    ah <- get bh
+                    return (IfaceApp ag ah)
+            6 -> do ai <- get bh
+                    aj <- get bh
+                    ak <- get bh
+                    return (IfaceCase ai aj ak)
+            7 -> do al <- get bh
+                    am <- get bh
+                    return (IfaceLet al am)
+            8 -> do an <- get bh
+                    ao <- get bh
+                    return (IfaceTick an ao)
+            9 -> do ap <- get bh
+                    return (IfaceLit ap)
+            10 -> do as <- get bh
+                     at <- get bh
+                     return (IfaceFCall as at)
+            11 -> do aa <- get bh
+                     return (IfaceExt aa)
+            12 -> do ie <- get bh
+                     ico <- get bh
+                     return (IfaceCast ie ico)
+            _ -> panic ("get IfaceExpr " ++ show h)
 
 instance Binary IfaceConAlt where
-    put_ bh IfaceDefault = do
-	    putByte bh 0
-    put_ bh (IfaceDataAlt aa) = do
-	    putByte bh 1
-	    put_ bh aa
-    put_ bh (IfaceLitAlt ac) = do
-	    putByte bh 2
-	    put_ bh ac
+    put_ bh IfaceDefault      = putByte bh 0
+    put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
+    put_ bh (IfaceLitAlt ac)  = putByte bh 2 >> put_ bh ac
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do return IfaceDefault
-	      1 -> do aa <- get bh
-		      return (IfaceDataAlt aa)
-	      _ -> do ac <- get bh
-		      return (IfaceLitAlt ac)
+        h <- getByte bh
+        case h of
+            0 -> return IfaceDefault
+            1 -> get bh >>= (return . IfaceDataAlt)
+            _ -> get bh >>= (return . IfaceLitAlt)
 
 instance Binary IfaceBinding where
-    put_ bh (IfaceNonRec aa ab) = do
-	    putByte bh 0
-	    put_ bh aa
-	    put_ bh ab
-    put_ bh (IfaceRec ac) = do
-	    putByte bh 1
-	    put_ bh ac
+    put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
+    put_ bh (IfaceRec ac)       = putByte bh 1 >> put_ bh ac
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do aa <- get bh
-		      ab <- get bh
-		      return (IfaceNonRec aa ab)
-	      _ -> do ac <- get bh
-		      return (IfaceRec ac)
+        h <- getByte bh
+        case h of
+            0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
+            _ -> do { ac <- get bh; return (IfaceRec ac) }
 
 instance Binary IfaceIdDetails where
     put_ bh IfVanillaId      = putByte bh 0
-    put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
+    put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
     put_ bh IfDFunId         = putByte bh 2
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> return IfVanillaId
-	      1 -> do a <- get bh
-		      b <- get bh
-		      return (IfRecSelId a b)
-              _ -> return IfDFunId
+        h <- getByte bh
+        case h of
+            0 -> return IfVanillaId
+            1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
+            _ -> return IfDFunId
 
 instance Binary IfaceIdInfo where
-    put_ bh NoInfo = putByte bh 0
-    put_ bh (HasInfo i) = do
-	    putByte bh 1
-	    lazyPut bh i			-- NB lazyPut
+    put_ bh NoInfo      = putByte bh 0
+    put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
 
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> return NoInfo
-	      _ -> do info <- lazyGet bh	-- NB lazyGet
-		      return (HasInfo info)
+        h <- getByte bh
+        case h of
+            0 -> return NoInfo
+            _ -> lazyGet bh >>= (return . HasInfo)     -- NB lazyGet
 
 instance Binary IfaceInfoItem where
-    put_ bh (HsArity aa) = do
-	    putByte bh 0
-	    put_ bh aa
-    put_ bh (HsStrictness ab) = do
-	    putByte bh 1
-	    put_ bh ab
-    put_ bh (HsUnfold lb ad) = do
-	    putByte bh 2
-	    put_ bh lb
-	    put_ bh ad
-    put_ bh (HsInline ad) = do
-	    putByte bh 3
-	    put_ bh ad
-    put_ bh HsNoCafRefs = do
-	    putByte bh 4
+    put_ bh (HsArity aa)      = putByte bh 0 >> put_ bh aa
+    put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab
+    put_ bh (HsUnfold lb ad)  = putByte bh 2 >> put_ bh lb >> put_ bh ad
+    put_ bh (HsInline ad)     = putByte bh 3 >> put_ bh ad
+    put_ bh HsNoCafRefs       = putByte bh 4
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do aa <- get bh
-		      return (HsArity aa)
-	      1 -> do ab <- get bh
-		      return (HsStrictness ab)
-	      2 -> do lb <- get bh
-		      ad <- get bh
-                      return (HsUnfold lb ad)
-	      3 -> do ad <- get bh
-		      return (HsInline ad)
-	      _ -> do return HsNoCafRefs
+        h <- getByte bh
+        case h of
+            0 -> get bh >>= (return . HsArity)
+            1 -> get bh >>= (return . HsStrictness)
+            2 -> do lb <- get bh
+                    ad <- get bh
+                    return (HsUnfold lb ad)
+            3 -> get bh >>= (return . HsInline)
+            _ -> return HsNoCafRefs
 
 instance Binary IfaceUnfolding where
     put_ bh (IfCoreUnfold s e) = do
-	putByte bh 0
-	put_ bh s
-	put_ bh e
+        putByte bh 0
+        put_ bh s
+        put_ bh e
     put_ bh (IfInlineRule a b c d) = do
-	putByte bh 1
-	put_ bh a
-	put_ bh b
-	put_ bh c
-	put_ bh d
+        putByte bh 1
+        put_ bh a
+        put_ bh b
+        put_ bh c
+        put_ bh d
     put_ bh (IfLclWrapper a n) = do
-	putByte bh 2
-	put_ bh a
-	put_ bh n
+        putByte bh 2
+        put_ bh a
+        put_ bh n
     put_ bh (IfExtWrapper a n) = do
-	putByte bh 3
-	put_ bh a
-	put_ bh n
+        putByte bh 3
+        put_ bh a
+        put_ bh n
     put_ bh (IfDFunUnfold as) = do
-	putByte bh 4
-	put_ bh as
+        putByte bh 4
+        put_ bh as
     put_ bh (IfCompulsory e) = do
-	putByte bh 5
-	put_ bh e
+        putByte bh 5
+        put_ bh e
     get bh = do
-	h <- getByte bh
-	case h of
-	  0 -> do s <- get bh
-		  e <- get bh
-		  return (IfCoreUnfold s e)
-	  1 -> do a <- get bh
-		  b <- get bh
-		  c <- get bh
-		  d <- get bh
-		  return (IfInlineRule a b c d)
-	  2 -> do a <- get bh
-		  n <- get bh
-		  return (IfLclWrapper a n)
-	  3 -> do a <- get bh
-		  n <- get bh
-		  return (IfExtWrapper a n)
-	  4 -> do as <- get bh
-		  return (IfDFunUnfold as)
-	  _ -> do e <- get bh
-		  return (IfCompulsory e)
+        h <- getByte bh
+        case h of
+            0 -> do s <- get bh
+                    e <- get bh
+                    return (IfCoreUnfold s e)
+            1 -> do a <- get bh
+                    b <- get bh
+                    c <- get bh
+                    d <- get bh
+                    return (IfInlineRule a b c d)
+            2 -> do a <- get bh
+                    n <- get bh
+                    return (IfLclWrapper a n)
+            3 -> do a <- get bh
+                    n <- get bh
+                    return (IfExtWrapper a n)
+            4 -> do as <- get bh
+                    return (IfDFunUnfold as)
+            _ -> do e <- get bh
+                    return (IfCompulsory e)
 
 instance Binary IfaceTickish where
     put_ bh (IfaceHpcTick m ix) = do
-      putByte bh 0
-      put_ bh m
-      put_ bh ix
+        putByte bh 0
+        put_ bh m
+        put_ bh ix
     put_ bh (IfaceSCC cc tick push) = do
-      putByte bh 1
-      put_ bh cc
-      put_ bh tick
-      put_ bh push
+        putByte bh 1
+        put_ bh cc
+        put_ bh tick
+        put_ bh push
 
     get bh = do
-      h <- getByte bh
-      case h of
-        0 -> do m <- get bh
-                ix <- get bh
-                return (IfaceHpcTick m ix)
-        1 -> do cc <- get bh
-                tick <- get bh
-                push <- get bh
-                return (IfaceSCC cc tick push)
-        _ -> panic ("get IfaceTickish " ++ show h)
+        h <- getByte bh
+        case h of
+            0 -> do m <- get bh
+                    ix <- get bh
+                    return (IfaceHpcTick m ix)
+            1 -> do cc <- get bh
+                    tick <- get bh
+                    push <- get bh
+                    return (IfaceSCC cc tick push)
+            _ -> panic ("get IfaceTickish " ++ show h)
 
 -------------------------------------------------------------------------
---		IfaceDecl and friends
+--              IfaceDecl and friends
 -------------------------------------------------------------------------
 
 -- A bit of magic going on here: there's no need to store the OccName
@@ -1331,161 +1367,164 @@ instance Binary IfaceTickish where
 
 instance Binary IfaceDecl where
     put_ bh (IfaceId name ty details idinfo) = do
-	    putByte bh 0
-	    put_ bh (occNameFS name)
-	    put_ bh ty
-	    put_ bh details
-	    put_ bh idinfo
+        putByte bh 0
+        put_ bh (occNameFS name)
+        put_ bh ty
+        put_ bh details
+        put_ bh idinfo
+
     put_ _ (IfaceForeign _ _) = 
-	error "Binary.put_(IfaceDecl): IfaceForeign"
+        error "Binary.put_(IfaceDecl): IfaceForeign"
+
     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
-	    putByte bh 2
-	    put_ bh (occNameFS a1)
-	    put_ bh a2
-	    put_ bh a3
-	    put_ bh a4
-	    put_ bh a5
-	    put_ bh a6
-	    put_ bh a7
+        putByte bh 2
+        put_ bh (occNameFS a1)
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+        put_ bh a6
+        put_ bh a7
+
     put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
-	    putByte bh 3
-	    put_ bh (occNameFS a1)
-	    put_ bh a2
-	    put_ bh a3
-	    put_ bh a4
-	    put_ bh a5
+        putByte bh 3
+        put_ bh (occNameFS a1)
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+
     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
-	    putByte bh 4
-	    put_ bh a1
-	    put_ bh (occNameFS a2)
-	    put_ bh a3
-	    put_ bh a4
-	    put_ bh a5
-	    put_ bh a6
-	    put_ bh a7
+        putByte bh 4
+        put_ bh a1
+        put_ bh (occNameFS a2)
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+        put_ bh a6
+        put_ bh a7
+
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do name    <- get bh
-		      ty      <- get bh
-		      details <- get bh
-		      idinfo  <- get bh
-                      occ <- return $! mkOccNameFS varName name
-		      return (IfaceId occ ty details idinfo)
-	      1 -> error "Binary.get(TyClDecl): ForeignType"
-	      2 -> do
-		    a1 <- get bh
-		    a2 <- get bh
-		    a3 <- get bh
-		    a4 <- get bh
-		    a5 <- get bh
-		    a6 <- get bh
-		    a7 <- get bh
+        h <- getByte bh
+        case h of
+            0 -> do name    <- get bh
+                    ty      <- get bh
+                    details <- get bh
+                    idinfo  <- get bh
+                    occ <- return $! mkOccNameFS varName name
+                    return (IfaceId occ ty details idinfo)
+            1 -> error "Binary.get(TyClDecl): ForeignType"
+            2 -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    a4 <- get bh
+                    a5 <- get bh
+                    a6 <- get bh
+                    a7 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-		    return (IfaceData occ a2 a3 a4 a5 a6 a7)
-	      3 -> do
-		    a1 <- get bh
-		    a2 <- get bh
-		    a3 <- get bh
-		    a4 <- get bh
-		    a5 <- get bh
+                    return (IfaceData occ a2 a3 a4 a5 a6 a7)
+            3 -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    a4 <- get bh
+                    a5 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-		    return (IfaceSyn occ a2 a3 a4 a5)
-	      _ -> do
-		    a1 <- get bh
-		    a2 <- get bh
-		    a3 <- get bh
-		    a4 <- get bh
-		    a5 <- get bh
-		    a6 <- get bh
-		    a7 <- get bh
+                    return (IfaceSyn occ a2 a3 a4 a5)
+            _ -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    a4 <- get bh
+                    a5 <- get bh
+                    a6 <- get bh
+                    a7 <- get bh
                     occ <- return $! mkOccNameFS clsName a2
-		    return (IfaceClass a1 occ a3 a4 a5 a6 a7)
+                    return (IfaceClass a1 occ a3 a4 a5 a6 a7)
 
 instance Binary IfaceInst where
     put_ bh (IfaceInst cls tys dfun flag orph) = do
-	    put_ bh cls
-	    put_ bh tys
-	    put_ bh dfun
-	    put_ bh flag
-	    put_ bh orph
-    get bh = do cls  <- get bh
-		tys  <- get bh
-		dfun <- get bh
-		flag <- get bh
-		orph <- get bh
-		return (IfaceInst cls tys dfun flag orph)
+        put_ bh cls
+        put_ bh tys
+        put_ bh dfun
+        put_ bh flag
+        put_ bh orph
+    get bh = do
+        cls  <- get bh
+        tys  <- get bh
+        dfun <- get bh
+        flag <- get bh
+        orph <- get bh
+        return (IfaceInst cls tys dfun flag orph)
 
 instance Binary IfaceFamInst where
     put_ bh (IfaceFamInst fam tys tycon) = do
-	    put_ bh fam
-	    put_ bh tys
-	    put_ bh tycon
-    get bh = do fam   <- get bh
-		tys   <- get bh
-		tycon <- get bh
-		return (IfaceFamInst fam tys tycon)
+        put_ bh fam
+        put_ bh tys
+        put_ bh tycon
+    get bh = do
+        fam   <- get bh
+        tys   <- get bh
+        tycon <- get bh
+        return (IfaceFamInst fam tys tycon)
 
 instance Binary OverlapFlag where
     put_ bh (NoOverlap  b) = putByte bh 0 >> put_ bh b
     put_ bh (OverlapOk  b) = putByte bh 1 >> put_ bh b
     put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
-    get bh = do h <- getByte bh
-                b <- get bh
-		case h of
-		  0 -> return $ NoOverlap b
-		  1 -> return $ OverlapOk b
-		  2 -> return $ Incoherent b
-		  _ -> panic ("get OverlapFlag " ++ show h)
+    get bh = do
+        h <- getByte bh
+        b <- get bh
+        case h of
+            0 -> return $ NoOverlap b
+            1 -> return $ OverlapOk b
+            2 -> return $ Incoherent b
+            _ -> panic ("get OverlapFlag " ++ show h)
 
 instance Binary IfaceConDecls where
-    put_ bh (IfAbstractTyCon d) = do { putByte bh 0; put_ bh d }
-    put_ bh IfOpenDataTyCon = putByte bh 1
-    put_ bh (IfDataTyCon cs) = do { putByte bh 2
-				  ; put_ bh cs }
-    put_ bh (IfNewTyCon c)  = do { putByte bh 3
-				  ; put_ bh c }
+    put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
+    put_ bh IfOpenDataTyCon     = putByte bh 1
+    put_ bh (IfDataTyCon cs)    = putByte bh 2 >> put_ bh cs
+    put_ bh (IfNewTyCon c)      = putByte bh 3 >> put_ bh c
     get bh = do
-	    h <- getByte bh
-	    case h of
-	      0 -> do { d <- get bh; return (IfAbstractTyCon d) }
-	      1 -> return IfOpenDataTyCon
-	      2 -> do cs <- get bh
-		      return (IfDataTyCon cs)
-	      _ -> do aa <- get bh
-		      return (IfNewTyCon aa)
+        h <- getByte bh
+        case h of
+            0 -> get bh >>= (return . IfAbstractTyCon)
+            1 -> return IfOpenDataTyCon
+            2 -> get bh >>= (return . IfDataTyCon)
+            _ -> get bh >>= (return . IfNewTyCon)
 
 instance Binary IfaceConDecl where
     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
-	    put_ bh a1
-	    put_ bh a2
-	    put_ bh a3
-	    put_ bh a4
-	    put_ bh a5
-	    put_ bh a6
-	    put_ bh a7
-	    put_ bh a8
-	    put_ bh a9
-	    put_ bh a10
-    get bh = do a1 <- get bh
-		a2 <- get bh
-		a3 <- get bh	      
-		a4 <- get bh
-		a5 <- get bh
-		a6 <- get bh
-		a7 <- get bh
-		a8 <- get bh
-		a9 <- get bh
-		a10 <- get bh
-	        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
+        put_ bh a1
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+        put_ bh a6
+        put_ bh a7
+        put_ bh a8
+        put_ bh a9
+        put_ bh a10
+    get bh = do
+        a1 <- get bh
+        a2 <- get bh
+        a3 <- get bh          
+        a4 <- get bh
+        a5 <- get bh
+        a6 <- get bh
+        a7 <- get bh
+        a8 <- get bh
+        a9 <- get bh
+        a10 <- get bh
+        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
 
 instance Binary IfaceAT where
     put_ bh (IfaceAT dec defs) = do
-            put_ bh dec
-            put_ bh defs
-    get bh = do dec <- get bh
-                defs <- get bh
-                return (IfaceAT dec defs)
+        put_ bh dec
+        put_ bh defs
+    get bh = do
+        dec  <- get bh
+        defs <- get bh
+        return (IfaceAT dec defs)
 
 instance Binary IfaceATDefault where
     put_ bh (IfaceATD tvs pat_tys ty) = do
@@ -1495,37 +1534,37 @@ instance Binary IfaceATDefault where
     get bh = liftM3 IfaceATD (get bh) (get bh) (get bh)
 
 instance Binary IfaceClassOp where
-   put_ bh (IfaceClassOp n def ty) = do	
-	put_ bh (occNameFS n)
-	put_ bh def	
-	put_ bh ty
-   get bh = do
-	n <- get bh
-	def <- get bh
-	ty <- get bh
+    put_ bh (IfaceClassOp n def ty) = do 
+        put_ bh (occNameFS n)
+        put_ bh def     
+        put_ bh ty
+    get bh = do
+        n   <- get bh
+        def <- get bh
+        ty  <- get bh
         occ <- return $! mkOccNameFS varName n
-	return (IfaceClassOp occ def ty)
+        return (IfaceClassOp occ def ty)
 
 instance Binary IfaceRule where
     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
-	    put_ bh a1
-	    put_ bh a2
-	    put_ bh a3
-	    put_ bh a4
-	    put_ bh a5
-	    put_ bh a6
-	    put_ bh a7
-	    put_ bh a8
+        put_ bh a1
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+        put_ bh a6
+        put_ bh a7
+        put_ bh a8
     get bh = do
-	    a1 <- get bh
-	    a2 <- get bh
-	    a3 <- get bh
-	    a4 <- get bh
-	    a5 <- get bh
-	    a6 <- get bh
-	    a7 <- get bh
-	    a8 <- get bh
-	    return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
+        a1 <- get bh
+        a2 <- get bh
+        a3 <- get bh
+        a4 <- get bh
+        a5 <- get bh
+        a6 <- get bh
+        a7 <- get bh
+        a8 <- get bh
+        return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
 
 instance Binary IfaceAnnotation where
     put_ bh (IfaceAnnotation a1 a2) = do
@@ -1546,25 +1585,23 @@ instance Binary name => Binary (AnnTarget name) where
     get bh = do
         h <- getByte bh
         case h of
-          0 -> do a <- get bh
-                  return (NamedTarget a)
-          _ -> do a <- get bh
-                  return (ModuleTarget a)
+            0 -> get bh >>= (return . NamedTarget)
+            _ -> get bh >>= (return . ModuleTarget)
 
 instance Binary IfaceVectInfo where
     put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
-	    put_ bh a1
-	    put_ bh a2
-	    put_ bh a3
-	    put_ bh a4
-	    put_ bh a5
+        put_ bh a1
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
     get bh = do
-	    a1 <- get bh
-	    a2 <- get bh
-	    a3 <- get bh
-	    a4 <- get bh
-	    a5 <- get bh
-	    return (IfaceVectInfo a1 a2 a3 a4 a5)
+        a1 <- get bh
+        a2 <- get bh
+        a3 <- get bh
+        a4 <- get bh
+        a5 <- get bh
+        return (IfaceVectInfo a1 a2 a3 a4 a5)
 
 instance Binary IfaceTrustInfo where
     put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 348da8c6c4..9d4a825586 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -15,6 +15,7 @@ module BuildTyCl (
 	buildSynTyCon, 
         buildAlgTyCon, 
         buildDataCon,
+        buildPromotedDataTyCon,
         TcMethInfo, buildClass,
 	distinctAbstractTyConRhs, totallyAbstractTyConRhs,
 	mkNewTyConRhs, mkDataTyConRhs, 
@@ -34,11 +35,13 @@ import MkId
 import Class
 import TyCon
 import Type
+import Kind             ( promoteType, isPromotableType )
 import Coercion
 
 import TcRnMonad
 import Util		( isSingleton )
 import Outputable
+import Unique           ( getUnique )
 \end{code}
 	
 
@@ -59,11 +62,10 @@ buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family
 
   | otherwise
   = return (mkSynTyCon tc_name kind tvs rhs parent)
-  where
-    kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
+  where kind = mkForAllArrowKinds tvs rhs_kind
 
 ------------------------------------------------------
-buildAlgTyCon :: Name -> [TyVar] 
+buildAlgTyCon :: Name -> [TyVar]        -- ^ Kind variables adn type variables
 	      -> ThetaType		-- ^ Stupid theta
 	      -> AlgTyConRhs
 	      -> RecFlag
@@ -72,22 +74,21 @@ buildAlgTyCon :: Name -> [TyVar]
 	      -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
 	      -> TcRnIf m n TyCon
 
-buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn
+buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn
 	      parent mb_family
   | Just fam_inst_info <- mb_family
   = -- We need to tie a knot as the coercion of a data instance depends
      -- on the instance representation tycon and vice versa.
     ASSERT( isNoParent parent )
     fixM $ \ tycon_rec -> do 
-    { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
-    ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
+    { fam_parent <- mkFamInstParentInfo tc_name ktvs fam_inst_info tycon_rec
+    ; return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs
 		         fam_parent is_rec gadt_syn) }
 
   | otherwise
-  = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
+  = return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs
 	               parent is_rec gadt_syn)
-  where
-    kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
+  where kind = mkForAllArrowKinds ktvs liftedTypeKind
 
 -- | If a family tycon with instance types is given, the current tycon is an
 -- instance of that family and we need to
@@ -224,6 +225,11 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
     arg_tyvars      = tyVarsOfTypes arg_tys
     in_arg_tys pred = not $ isEmptyVarSet $ 
 		      tyVarsOfType pred `intersectVarSet` arg_tyvars
+
+buildPromotedDataTyCon :: DataCon -> TyCon
+buildPromotedDataTyCon dc = ASSERT ( isPromotableType ty )
+  mkPromotedDataTyCon dc (getName dc) (getUnique dc) (promoteType ty)
+  where ty = dataConUserType dc
 \end{code}
 
 
@@ -301,7 +307,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
 		 then mkNewTyConRhs tycon_name rec_tycon dict_con
 		 else return (mkDataTyConRhs [dict_con])
 
-	; let {	clas_kind = mkArrowKinds (map tyVarKind tvs) constraintKind
+	; let {	clas_kind = mkForAllArrowKinds tvs constraintKind
 
  	      ; tycon = mkClassTyCon tycon_name clas_kind tvs
  	                             rhs rec_clas tc_isrec
diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs
new file mode 100644
index 0000000000..f670437ffe
--- /dev/null
+++ b/compiler/iface/FlagChecker.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- | This module manages storing the various GHC option flags in a modules
+-- interface file as part of the recompilation checking infrastructure.
+module FlagChecker (
+        fingerprintDynFlags
+    ) where
+
+import Binary
+import BinIface ()
+import DynFlags
+import HscTypes
+import Name
+import Fingerprint
+-- import Outputable
+
+import Data.List (sort)
+import System.FilePath (normalise)
+
+-- | Produce a fingerprint of a @DynFlags@ value. We only base
+-- the finger print on important fields in @DynFlags@ so that
+-- the recompilation checker can use this fingerprint.
+fingerprintDynFlags :: DynFlags -> (BinHandle -> Name -> IO ())
+                    -> IO Fingerprint
+
+fingerprintDynFlags DynFlags{..} nameio =
+    let mainis   = (mainModIs, mainFunIs)
+        -- pkgopts  = (thisPackage dflags, sort $ packageFlags dflags)
+        safeHs   = setSafeMode safeHaskell
+        -- oflags   = sort $ filter filterOFlags $ flags dflags
+
+        -- *all* the extension flags and the language
+        lang = (fmap fromEnum language,
+                sort $ map fromEnum $ extensionFlags)
+
+        -- -I, -D and -U flags affect CPP
+        cpp = (map normalise includePaths, sOpt_P settings)
+            -- normalise: eliminate spurious differences due to "./foo" vs "foo"
+
+        -- -i, -osuf, -hcsuf, -hisuf, -odir, -hidir, -stubdir, -o, -ohi
+        paths = (map normalise importPaths,
+                   [ objectSuf, hcSuf, hiSuf ],
+                   [ objectDir, hiDir, stubDir, outputFile, outputHi ])
+
+    in -- pprTrace "flags" (ppr (mainis, safeHs, lang, cpp, paths)) $
+       computeFingerprint nameio (mainis, safeHs, lang, cpp, paths)
+
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index deeac37c65..92fb0d9937 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -500,6 +500,7 @@ pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
                                                             (map (pprIfaceConDecl tc) cs))
 
 mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType
+-- IA0_NOTE: This is wrong, but only used for pretty-printing.
 mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2]
 
 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
@@ -718,7 +719,9 @@ freeNamesIfDecl d@IfaceData{} =
 freeNamesIfDecl d@IfaceSyn{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
   freeNamesIfSynRhs (ifSynRhs d) &&&
-  freeNamesIfTcFam (ifFamInst d)
+  freeNamesIfTcFam (ifFamInst d) &&&
+  freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we
+                                -- return names in the kind signature
 freeNamesIfDecl d@IfaceClass{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
   freeNamesIfContext (ifCtxt d) &&&
@@ -769,6 +772,9 @@ freeNamesIfConDecl c =
   fnList freeNamesIfType (ifConArgTys c) &&&
   fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
 
+freeNamesIfKind :: IfaceType -> NameSet
+freeNamesIfKind = freeNamesIfType
+
 freeNamesIfType :: IfaceType -> NameSet
 freeNamesIfType (IfaceTyVar _)        = emptyNameSet
 freeNamesIfType (IfaceAppTy s t)      = freeNamesIfType s &&& freeNamesIfType t
@@ -795,8 +801,8 @@ freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty
                                              &&& freeNamesIfIdInfo info
 
 freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
-freeNamesIfTvBndr (_fs,k) = freeNamesIfType k
-    -- kinds can have Names inside, when the Kind is an equality predicate
+freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k
+    -- kinds can have Names inside, because of promotion
 
 freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
 freeNamesIfIdBndr = freeNamesIfTvBndr
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index 471acd0639..5441287eef 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -21,7 +21,7 @@ module IfaceType (
 	ifaceTyConName,
 
 	-- Conversion from Type -> IfaceType
-        toIfaceType, toIfaceContext,
+        toIfaceType, toIfaceKind, toIfaceContext,
 	toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, 
 	toIfaceTyCon, toIfaceTyCon_name,
 
@@ -87,12 +87,20 @@ data IfaceType	   -- A kind of universal type, used for types, kinds, and coerci
 type IfacePredType = IfaceType
 type IfaceContext = [IfacePredType]
 
-data IfaceTyCon 	 -- Encodes type consructors, kind constructors
-     			 -- coercion constructors, the lot
-  = IfaceTc IfExtName	 -- The common case
-  | IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
-    	       		 -- other than 'Any :: *' itself
-                         -- XXX: remove this case after Any becomes kind-polymorphic
+data IfaceTyCon 	-- Encodes type constructors, kind constructors
+     			-- coercion constructors, the lot
+  = IfaceTc IfExtName	-- The common case
+  | IfaceIntTc | IfaceBoolTc | IfaceCharTc
+  | IfaceListTc | IfacePArrTc
+  | IfaceTupTc TupleSort Arity 
+  | IfaceIPTc IfIPName       -- Used for implicit parameter TyCons
+
+  -- Kind constructors
+  | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
+  | IfaceUbxTupleKindTc | IfaceArgTypeKindTc | IfaceConstraintKindTc
+
+  -- SuperKind constructor
+  | IfaceSuperKindTc  -- IA0_NOTE: You might want to check if I didn't forget something.
 
   -- Coercion constructors
 data IfaceCoCon
@@ -103,13 +111,29 @@ data IfaceCoCon
   | IfaceNthCo Int
 
 ifaceTyConName :: IfaceTyCon -> Name
+ifaceTyConName IfaceIntTc              = intTyConName
+ifaceTyConName IfaceBoolTc 	       = boolTyConName
+ifaceTyConName IfaceCharTc 	       = charTyConName
+ifaceTyConName IfaceListTc 	       = listTyConName
+ifaceTyConName IfacePArrTc 	       = parrTyConName
+ifaceTyConName (IfaceTupTc bx ar)      = getName (tupleTyCon bx ar)
+ifaceTyConName IfaceLiftedTypeKindTc   = liftedTypeKindTyConName
+ifaceTyConName IfaceOpenTypeKindTc     = openTypeKindTyConName
+ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName
+ifaceTyConName IfaceUbxTupleKindTc     = ubxTupleKindTyConName
+ifaceTyConName IfaceArgTypeKindTc      = argTypeKindTyConName
+ifaceTyConName IfaceConstraintKindTc   = constraintKindTyConName
+ifaceTyConName IfaceSuperKindTc        = tySuperKindTyConName
 ifaceTyConName (IfaceTc ext)           = ext
-ifaceTyConName (IfaceAnyTc k)          = pprPanic "ifaceTyConName:AnyTc" (ppr k)
+ifaceTyConName (IfaceIPTc n)           = pprPanic "ifaceTyConName:IPTc" (ppr n)
 	       		    	       	 -- Note [The Name of an IfaceAnyTc]
 \end{code}
 
 Note [The Name of an IfaceAnyTc]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+IA0_NOTE: This is an old comment. It needs to be updated with IPTc which
+I don't know about.
+
 It isn't easy to get the Name of an IfaceAnyTc in a pure way.  What you
 really need to do is to transform it to a TyCon, and get the Name of that.
 But doing so needs the monad because there's an IfaceKind inside, and we
@@ -190,8 +214,7 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
 pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
 
 pprIfaceTvBndr :: IfaceTvBndr -> SDoc
-pprIfaceTvBndr (tv, IfaceTyConApp (IfaceTc n) [])
-  | n == liftedTypeKindTyConName
+pprIfaceTvBndr (tv, IfaceTyConApp IfaceLiftedTypeKindTc [])
   = ppr tv
 pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
 pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
@@ -255,18 +278,21 @@ pprIfaceForAllPart tvs ctxt doc
 
 -------------------
 ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc
-ppr_tc_app _         tc 	 []   = ppr_tc tc
-ppr_tc_app _         (IfaceTc n) [ty] | n == listTyConName = brackets (pprIfaceType ty)
-ppr_tc_app _         (IfaceTc n) [ty] | n == parrTyConName = pabrackets (pprIfaceType ty)
-ppr_tc_app _         (IfaceTc n) tys
-  | Just (ATyCon tc) <- wiredInNameTyThing_maybe n
-  , Just sort <- tyConTuple_maybe tc
-  , tyConArity tc == length tys 
-  = tupleParens sort (sep (punctuate comma (map pprIfaceType tys)))
-  | Just (ATyCon tc) <- wiredInNameTyThing_maybe n
-  , Just ip <- tyConIP_maybe tc
-  , [ty] <- tys
-  = parens (ppr ip <> dcolon <> pprIfaceType ty)
+ppr_tc_app _         tc          []   = ppr_tc tc
+
+ppr_tc_app _         IfaceListTc [ty] = brackets (pprIfaceType ty)
+ppr_tc_app _         IfaceListTc _    = panic "ppr_tc_app IfaceListTc"
+
+ppr_tc_app _         IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
+ppr_tc_app _         IfacePArrTc _    = panic "ppr_tc_app IfacePArrTc"
+
+ppr_tc_app _         (IfaceTupTc sort _) tys =
+  tupleParens sort (sep (punctuate comma (map pprIfaceType tys)))
+
+ppr_tc_app _         (IfaceIPTc n) [ty] =
+  parens (ppr n <> dcolon <> pprIfaceType ty)
+ppr_tc_app _         (IfaceIPTc _) _ = panic "ppr_tc_app IfaceIPTc"
+
 ppr_tc_app ctxt_prec tc tys
   = maybeParen ctxt_prec tYCON_PREC 
                (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
@@ -278,11 +304,8 @@ ppr_tc tc		   = ppr tc
 
 -------------------
 instance Outputable IfaceTyCon where
-  ppr (IfaceAnyTc k) = ptext (sLit "Any") <> pprParendIfaceType k
-      		       	     -- We can't easily get the Name of an IfaceAnyTc
-			     -- (see Note [The Name of an IfaceAnyTc])
-			     -- so we fake it.  It's only for debug printing!
-  ppr (IfaceTc ext)  = ppr ext
+  ppr (IfaceIPTc n)  = ppr (IPName n)
+  ppr other_tc       = ppr (ifaceTyConName other_tc)
 
 instance Outputable IfaceCoCon where
   ppr (IfaceCoAx n)    = ppr n
@@ -350,8 +373,9 @@ toIfaceCoVar = occNameFS . getOccName
 ----------------
 toIfaceTyCon :: TyCon -> IfaceTyCon
 toIfaceTyCon tc 
-  | isAnyTyCon tc              = IfaceAnyTc (toIfaceKind (tyConKind tc))
-  | otherwise	               = IfaceTc (tyConName tc)
+  | isTupleTyCon tc            = IfaceTupTc (tupleTyConSort tc) (tyConArity tc)
+  | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n)
+  | otherwise	               = toIfaceTyCon_name (tyConName tc)
 
 toIfaceTyCon_name :: Name -> IfaceTyCon
 toIfaceTyCon_name nm
@@ -362,7 +386,20 @@ toIfaceTyCon_name nm
 
 toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon
 toIfaceWiredInTyCon tc nm
-  | isAnyTyCon tc                   = IfaceAnyTc (toIfaceKind (tyConKind tc))
+  | isTupleTyCon tc                 = IfaceTupTc  (tupleTyConSort tc) (tyConArity tc)
+  | Just n <- tyConIP_maybe tc      = IfaceIPTc (ipFastString n)
+  | nm == intTyConName              = IfaceIntTc
+  | nm == boolTyConName             = IfaceBoolTc 
+  | nm == charTyConName             = IfaceCharTc 
+  | nm == listTyConName             = IfaceListTc 
+  | nm == parrTyConName             = IfacePArrTc 
+  | nm == liftedTypeKindTyConName   = IfaceLiftedTypeKindTc
+  | nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc
+  | nm == openTypeKindTyConName     = IfaceOpenTypeKindTc
+  | nm == argTypeKindTyConName      = IfaceArgTypeKindTc
+  | nm == constraintKindTyConName   = IfaceConstraintKindTc
+  | nm == ubxTupleKindTyConName     = IfaceUbxTupleKindTc
+  | nm == tySuperKindTyConName      = IfaceSuperKindTc
   | otherwise		            = IfaceTc nm
 
 ----------------
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 2f62ca5f4a..063158cf4e 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -250,7 +250,7 @@ loadInterface doc_str mod from
         ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
         ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
         ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
-        ; new_eps_vect_info <- tcIfaceVectInfo mod (mi_vect_info iface)
+        ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface)
 
         ; let { final_iface = iface {   
                                 mi_decls     = panic "No mi_decls in PIT",
@@ -660,6 +660,7 @@ pprModIface iface
         , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
         , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
         , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
+        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))
         , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
         , nest 2 (ptext (sLit "where"))
         , ptext (sLit "exports:")
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index c25186444f..86c46bac6c 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -4,13 +4,9 @@
 %
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
+-- | Module for constructing @ModIface@ values (interface files),
+-- writing them to disk and comparing two versions to see if
+-- recompilation is required.
 module MkIface ( 
         mkUsedNames,
         mkDependencies,
@@ -61,6 +57,8 @@ Basic idea:
 
 import IfaceSyn
 import LoadIface
+import FlagChecker
+
 import Id
 import IdInfo
 import Demand
@@ -155,10 +153,10 @@ mkIface hsc_env maybe_old_fingerprint mod_details
 -- for non-optimising compilation, or where we aren't generating any
 -- object code at all ('HscNothing').
 mkIfaceTc :: HscEnv
-          -> Maybe Fingerprint	-- The old fingerprint, if we have it
-          -> ModDetails		-- gotten from mkBootModDetails, probably
-          -> TcGblEnv		-- Usages, deprecations, etc
-	  -> IO (Messages, Maybe (ModIface, Bool))
+          -> Maybe Fingerprint  -- The old fingerprint, if we have it
+          -> ModDetails         -- gotten from mkBootModDetails, probably
+          -> TcGblEnv           -- Usages, deprecations, etc
+          -> IO (Messages, Maybe (ModIface, Bool))
 mkIfaceTc hsc_env maybe_old_fingerprint mod_details
   tc_result@TcGblEnv{ tcg_mod = this_mod,
                       tcg_src = hsc_src,
@@ -230,128 +228,131 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
 mkIface_ hsc_env maybe_old_fingerprint 
          this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
          hpc_info dir_imp_mods pkg_trust_req dependent_files
-	 ModDetails{  md_insts 	   = insts, 
-		      md_fam_insts = fam_insts,
-		      md_rules 	   = rules,
-		      md_anns	   = anns,
+         ModDetails{  md_insts     = insts, 
+                      md_fam_insts = fam_insts,
+                      md_rules     = rules,
+                      md_anns      = anns,
                       md_vect_info = vect_info,
-		      md_types 	   = type_env,
-		      md_exports   = exports }
--- NB:	notice that mkIface does not look at the bindings
---	only at the TypeEnv.  The previous Tidy phase has
---	put exactly the info into the TypeEnv that we want
---	to expose in the interface
-
-  = do	{ usages  <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
+                      md_types     = type_env,
+                      md_exports   = exports }
+-- NB:  notice that mkIface does not look at the bindings
+--      only at the TypeEnv.  The previous Tidy phase has
+--      put exactly the info into the TypeEnv that we want
+--      to expose in the interface
+
+  = do  { usages  <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
         ; safeInf <- hscGetSafeInf hsc_env
 
-	; let	{ entities = typeEnvElts type_env ;
+        ; let   { entities = typeEnvElts type_env ;
                   decls  = [ tyThingToIfaceDecl entity
-			   | entity <- entities,
-			     let name = getName entity,
+                           | entity <- entities,
+                             let name = getName entity,
                              not (isImplicitTyThing entity),
-	                        -- No implicit Ids and class tycons in the interface file
-			     not (isWiredInName name),
-	                        -- Nor wired-in things; the compiler knows about them anyhow
-			     nameIsLocalOrFrom this_mod name  ]
-				-- Sigh: see Note [Root-main Id] in TcRnDriver
-
-		; fixities    = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
-		; warns       = src_warns
-		; iface_rules = map (coreRuleToIfaceRule this_mod) rules
-		; iface_insts = map instanceToIfaceInst insts
-		; iface_fam_insts = map famInstToIfaceFamInst fam_insts
+                                -- No implicit Ids and class tycons in the interface file
+                             not (isWiredInName name),
+                                -- Nor wired-in things; the compiler knows about them anyhow
+                             nameIsLocalOrFrom this_mod name  ]
+                                -- Sigh: see Note [Root-main Id] in TcRnDriver
+
+                ; fixities    = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
+                ; warns       = src_warns
+                ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
+                ; iface_insts = map instanceToIfaceInst insts
+                ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
                 ; iface_vect_info = flattenVectInfo vect_info
+                -- Check if we are in Safe Inference mode but we failed to pass
+                -- the muster
                 ; safeMode    = if safeInferOn dflags  && not safeInf
                                     then Sf_None
                                     else safeHaskell dflags
                 ; trust_info  = setSafeMode safeMode
 
-	        ; intermediate_iface = ModIface { 
-			mi_module   = this_mod,
-			mi_boot     = is_boot,
-			mi_deps     = deps,
-			mi_usages   = usages,
-			mi_exports  = mkIfaceExports exports,
-	
-			-- Sort these lexicographically, so that
-			-- the result is stable across compilations
-			mi_insts    = sortLe le_inst iface_insts,
-			mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
-			mi_rules    = sortLe le_rule iface_rules,
-
-                        mi_vect_info = iface_vect_info,
-
-			mi_fixities = fixities,
-			mi_warns  = warns,
-			mi_anns     = mkIfaceAnnotations anns,
-			mi_globals  = Just rdr_env,
-
-			-- Left out deliberately: filled in by addVersionInfo
-			mi_iface_hash = fingerprint0,
-			mi_mod_hash  = fingerprint0,
- 			mi_exp_hash  = fingerprint0,
-                        mi_used_th   = used_th,
+                ; intermediate_iface = ModIface { 
+                        mi_module      = this_mod,
+                        mi_boot        = is_boot,
+                        mi_deps        = deps,
+                        mi_usages      = usages,
+                        mi_exports     = mkIfaceExports exports,
+        
+                        -- Sort these lexicographically, so that
+                        -- the result is stable across compilations
+                        mi_insts       = sortLe le_inst iface_insts,
+                        mi_fam_insts   = sortLe le_fam_inst iface_fam_insts,
+                        mi_rules       = sortLe le_rule iface_rules,
+
+                        mi_vect_info   = iface_vect_info,
+
+                        mi_fixities    = fixities,
+                        mi_warns       = warns,
+                        mi_anns        = mkIfaceAnnotations anns,
+                        mi_globals     = Just rdr_env,
+
+                        -- Left out deliberately: filled in by addFingerprints
+                        mi_iface_hash  = fingerprint0,
+                        mi_mod_hash    = fingerprint0,
+                        mi_flag_hash   = fingerprint0,
+                        mi_exp_hash    = fingerprint0,
+                        mi_used_th     = used_th,
                         mi_orphan_hash = fingerprint0,
-			mi_orphan    = False,	-- Always set by addVersionInfo, but
-						-- it's a strict field, so we can't omit it.
-                        mi_finsts    = False,   -- Ditto
-			mi_decls     = deliberatelyOmitted "decls",
-			mi_hash_fn   = deliberatelyOmitted "hash_fn",
-			mi_hpc       = isHpcUsed hpc_info,
-			mi_trust     = trust_info,
-			mi_trust_pkg = pkg_trust_req,
-
-			-- And build the cached values
-			mi_warn_fn = mkIfaceWarnCache warns,
-			mi_fix_fn = mkIfaceFixCache fixities }
-		}
+                        mi_orphan      = False, -- Always set by addFingerprints, but
+                                                -- it's a strict field, so we can't omit it.
+                        mi_finsts      = False, -- Ditto
+                        mi_decls       = deliberatelyOmitted "decls",
+                        mi_hash_fn     = deliberatelyOmitted "hash_fn",
+                        mi_hpc         = isHpcUsed hpc_info,
+                        mi_trust       = trust_info,
+                        mi_trust_pkg   = pkg_trust_req,
+
+                        -- And build the cached values
+                        mi_warn_fn     = mkIfaceWarnCache warns,
+                        mi_fix_fn      = mkIfaceFixCache fixities }
+                }
 
         ; (new_iface, no_change_at_all) 
-	        <- {-# SCC "versioninfo" #-}
-			 addFingerprints hsc_env maybe_old_fingerprint
+                <- {-# SCC "versioninfo" #-}
+                         addFingerprints hsc_env maybe_old_fingerprint
                                          intermediate_iface decls
 
-		-- Warn about orphans
-	; let warn_orphs      = wopt Opt_WarnOrphans dflags
+                -- Warn about orphans
+        ; let warn_orphs      = wopt Opt_WarnOrphans dflags
               warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
               orph_warnings   --- Laziness means no work done unless -fwarn-orphans
-	        | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
-	        | otherwise 	       	        = emptyBag
-	      errs_and_warns = (orph_warnings, emptyBag)
-	      unqual = mkPrintUnqualified dflags rdr_env
-	      inst_warns = listToBag [ instOrphWarn unqual d 
-	      		   	     | (d,i) <- insts `zip` iface_insts
-	      		   	     , isNothing (ifInstOrph i) ]
-	      rule_warns = listToBag [ ruleOrphWarn unqual this_mod r 
-	      		    	     | r <- iface_rules
-	      		   	     , isNothing (ifRuleOrph r)
+                | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
+                | otherwise                     = emptyBag
+              errs_and_warns = (orph_warnings, emptyBag)
+              unqual = mkPrintUnqualified dflags rdr_env
+              inst_warns = listToBag [ instOrphWarn unqual d 
+                                     | (d,i) <- insts `zip` iface_insts
+                                     , isNothing (ifInstOrph i) ]
+              rule_warns = listToBag [ ruleOrphWarn unqual this_mod r 
+                                     | r <- iface_rules
+                                     , isNothing (ifRuleOrph r)
                                      , if ifRuleAuto r then warn_auto_orphs
                                                        else warn_orphs ]
 
-	; if errorsFound dflags errs_and_warns
+        ; if errorsFound dflags errs_and_warns
             then return ( errs_and_warns, Nothing )
             else do {
 
-	   	-- Debug printing
-	; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" 
-			(pprModIface new_iface)
+                -- Debug printing
+        ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" 
+                        (pprModIface new_iface)
 
                 -- bug #1617: on reload we weren't updating the PrintUnqualified
                 -- correctly.  This stems from the fact that the interface had
-                -- not changed, so addVersionInfo returns the old ModIface
+                -- not changed, so addFingerprints returns the old ModIface
                 -- with the old GlobalRdrEnv (mi_globals).
         ; let final_iface = new_iface{ mi_globals = Just rdr_env }
 
-	; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
+        ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
   where
      r1 `le_rule`     r2 = ifRuleName      r1    <=    ifRuleName      r2
      i1 `le_inst`     i2 = ifDFun          i1 `le_occ` ifDFun          i2  
      i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2
 
      le_occ :: Name -> Name -> Bool
-	-- Compare lexicographically by OccName, *not* by unique, because 
-	-- the latter is not stable across compilations
+        -- Compare lexicographically by OccName, *not* by unique, because 
+        -- the latter is not stable across compilations
      le_occ n1 n2 = nameOccName n1 <= nameOccName n2
 
      dflags = hsc_dflags hsc_env
@@ -413,10 +414,10 @@ mkHashFun hsc_env eps
 addFingerprints
         :: HscEnv
         -> Maybe Fingerprint -- the old fingerprint, if any
-        -> ModIface	     -- The new interface (lacking decls)
+        -> ModIface          -- The new interface (lacking decls)
         -> [IfaceDecl]       -- The new decls
         -> IO (ModIface,     -- Updated interface
-               Bool)	     -- True <=> no changes at all; 
+               Bool)         -- True <=> no changes at all; 
                              -- no need to write Iface
 
 addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
@@ -432,9 +433,9 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
 
        edges :: [(IfaceDeclABI, Unique, [Unique])]
        edges = [ (abi, getUnique (ifName decl), out)
-	       | decl <- new_decls
+               | decl <- new_decls
                , let abi = declABI decl
-	       , let out = localOccs $ freeNamesDeclABI abi
+               , let out = localOccs $ freeNamesDeclABI abi
                ]
 
        name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
@@ -470,7 +471,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
            -- wired-in names don't have fingerprints
           | otherwise
           = ASSERT2( isExternalName name, ppr name )
-	    let hash | nameModule name /= this_mod =  global_hash_fn name
+            let hash | nameModule name /= this_mod =  global_hash_fn name
                      | otherwise = 
                         snd (lookupOccEnv local_env (getOccName name)
                            `orElse` pprPanic "urk! lookup local fingerprint" 
@@ -499,32 +500,46 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                    decl = abiDecl abi
                -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
                hash <- computeFingerprint hash_fn abi
-               return (extend_hash_env (hash,decl) local_env,
-                       (hash,decl) : decls_w_hashes)
+               env' <- extend_hash_env local_env (hash,decl)
+               return (env', (hash,decl) : decls_w_hashes)
 
        fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
           = do let decls = map abiDecl abis
-                   local_env' = foldr extend_hash_env local_env 
+               local_env1 <- foldM extend_hash_env local_env
                                    (zip (repeat fingerprint0) decls)
-                   hash_fn = mk_put_name local_env'
+               let hash_fn = mk_put_name local_env1
                -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
                let stable_abis = sortBy cmp_abiNames abis
                 -- put the cycle in a canonical order
                hash <- computeFingerprint hash_fn stable_abis
                let pairs = zip (repeat hash) decls
-               return (foldr extend_hash_env local_env pairs,
-                       pairs ++ decls_w_hashes)
+               local_env2 <- foldM extend_hash_env local_env pairs
+               return (local_env2, pairs ++ decls_w_hashes)
 
-       extend_hash_env :: (Fingerprint,IfaceDecl)
-                       -> OccEnv (OccName,Fingerprint)
-                       -> OccEnv (OccName,Fingerprint)
-       extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
+       -- we have fingerprinted the whole declaration, but we now need
+       -- to assign fingerprints to all the OccNames that it binds, to
+       -- use when referencing those OccNames in later declarations.
+       --
+       -- We better give each name bound by the declaration a
+       -- different fingerprint!  So we calculate the fingerprint of
+       -- each binder by combining the fingerprint of the whole
+       -- declaration with the name of the binder. (#5614)
+       extend_hash_env :: OccEnv (OccName,Fingerprint)
+                       -> (Fingerprint,IfaceDecl)
+                       -> IO (OccEnv (OccName,Fingerprint))
+       extend_hash_env env0 (hash,d) = do
+          let
+            sub_bndrs = ifaceDeclSubBndrs d
+            fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ)
+          --
+          sub_fps <- mapM fp_sub_bndr sub_bndrs
+          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env1
+                        (zip sub_bndrs sub_fps))
         where
           decl_name = ifName d
           item = (decl_name, hash)
           env1 = extendOccEnv env0 decl_name item
-          add_imp bndr env = extendOccEnv env bndr item
-            
+
    --
    (local_env, decls_w_hashes) <- 
        foldM fingerprint_group (emptyOccEnv, []) groups
@@ -562,6 +577,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
    -- put the declarations in a canonical order, sorted by OccName
    let sorted_decls = Map.elems $ Map.fromList $
                           [(ifName d, e) | e@(_, d) <- decls_w_hashes]
+   
+   -- the flag hash depends on:
+   --   - (some of) dflags
+   -- it returns two hashes, one that shouldn't change
+   -- the abi hash and one that should
+   flag_hash <- fingerprintDynFlags dflags putNameLiterally
 
    -- the ABI hash depends on:
    --   - decls
@@ -569,6 +590,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
    --   - orphans
    --   - deprecations
    --   - vect info
+   --   - flag abi hash
    mod_hash <- computeFingerprint putNameLiterally
                       (map fst sorted_decls,
                        export_hash,
@@ -577,10 +599,10 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                        mi_vect_info iface0)
 
    -- The interface hash depends on:
-   --    - the ABI hash, plus
-   --    - usages
-   --    - deps
-   --    - hpc
+   --   - the ABI hash, plus
+   --   - usages
+   --   - deps
+   --   - hpc
    iface_hash <- computeFingerprint putNameLiterally
                       (mod_hash, 
                        mi_usages iface0,
@@ -595,6 +617,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                 mi_iface_hash  = iface_hash,
                 mi_exp_hash    = export_hash,
                 mi_orphan_hash = orphan_hash,
+                mi_flag_hash   = flag_hash,
                 mi_orphan      = not (null orph_rules && null orph_insts
                                       && null (ifaceVectInfoVar (mi_vect_info iface0))),
                 mi_finsts      = not . null $ mi_fam_insts iface0,
@@ -640,9 +663,9 @@ sortDependencies d
 
 
 %************************************************************************
-%*		                					*
-          The ABI of an IfaceDecl       									
-%*	       	     							*
+%*                                                                      *
+          The ABI of an IfaceDecl                                                                               
+%*                                                                      *
 %************************************************************************
 
 Note [The ABI of an IfaceDecl]
@@ -674,17 +697,17 @@ data IfaceDeclExtras
   = IfaceIdExtras    Fixity [IfaceRule]
 
   | IfaceDataExtras  
-       Fixity			-- Fixity of the tycon itself
-       [IfaceInstABI]		-- Local instances of this tycon
-       				-- See Note [Orphans] in IfaceSyn
-       [(Fixity,[IfaceRule])]	-- For each construcotr, fixity and RULES
+       Fixity                   -- Fixity of the tycon itself
+       [IfaceInstABI]           -- Local instances of this tycon
+                                -- See Note [Orphans] in IfaceSyn
+       [(Fixity,[IfaceRule])]   -- For each construcotr, fixity and RULES
 
   | IfaceClassExtras 
-       Fixity			-- Fixity of the class itself
-       [IfaceInstABI] 		-- Local instances of this class *or*
-       				--   of its associated data types
-       				-- See Note [Orphans] in IfaceSyn
-       [(Fixity,[IfaceRule])]	-- For each class method, fixity and RULES
+       Fixity                   -- Fixity of the class itself
+       [IfaceInstABI]           -- Local instances of this class *or*
+                                --   of its associated data types
+                                -- See Note [Orphans] in IfaceSyn
+       [(Fixity,[IfaceRule])]   -- For each class method, fixity and RULES
 
   | IfaceSynExtras   Fixity
 
@@ -766,8 +789,8 @@ declExtras fix_fn rule_env inst_env decl
                      IfaceClassExtras (fix_fn n)
                         (map ifDFun $ (concatMap at_extras ats)
                                     ++ lookupOccEnvL inst_env n)
-		           -- Include instances of the associated types
-			   -- as well as instances of the class (Trac #5147)
+                           -- Include instances of the associated types
+                           -- as well as instances of the class (Trac #5147)
                         [id_extras op | IfaceClassOp op _ _ <- sigs]
       IfaceSyn{} -> IfaceSynExtras (fix_fn n)
       _other -> IfaceOtherDeclExtras
@@ -828,43 +851,43 @@ ruleOrphWarn unqual mod rule
 
 ----------------------
 -- mkOrphMap partitions instance decls or rules into
--- 	(a) an OccEnv for ones that are not orphans, 
---	    mapping the local OccName to a list of its decls
---	(b) a list of orphan decls
-mkOrphMap :: (decl -> Maybe OccName)	-- (Just occ) for a non-orphan decl, keyed by occ
-					-- Nothing for an orphan decl
-	  -> [decl] 			-- Sorted into canonical order
-	  -> (OccEnv [decl],	 	-- Non-orphan decls associated with their key;
-					--	each sublist in canonical order
-	      [decl])			-- Orphan decls; in canonical order
+--      (a) an OccEnv for ones that are not orphans, 
+--          mapping the local OccName to a list of its decls
+--      (b) a list of orphan decls
+mkOrphMap :: (decl -> Maybe OccName)    -- (Just occ) for a non-orphan decl, keyed by occ
+                                        -- Nothing for an orphan decl
+          -> [decl]                     -- Sorted into canonical order
+          -> (OccEnv [decl],            -- Non-orphan decls associated with their key;
+                                        --      each sublist in canonical order
+              [decl])                   -- Orphan decls; in canonical order
 mkOrphMap get_key decls
   = foldl go (emptyOccEnv, []) decls
   where
     go (non_orphs, orphs) d
-	| Just occ <- get_key d
-	= (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
-	| otherwise = (non_orphs, d:orphs)
+        | Just occ <- get_key d
+        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
+        | otherwise = (non_orphs, d:orphs)
 \end{code}
 
 
 %************************************************************************
-%*		                					*
+%*                                                                      *
        Keeping track of what we've slurped, and fingerprints
-%*	       	     							*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
 mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
-  = do	{ eps <- hscEPS hsc_env
+  = do  { eps <- hscEPS hsc_env
     ; mtimes <- mapM getModificationTime dependent_files
-	; let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
-				     dir_imp_mods used_names
-	; let usages = mod_usages ++ map to_file_usage (zip dependent_files mtimes)
-	; usages `seqList`  return usages }
-	 -- seq the list of Usages returned: occasionally these
-	 -- don't get evaluated for a while and we can end up hanging on to
-	 -- the entire collection of Ifaces.
+        ; let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
+                                     dir_imp_mods used_names
+        ; let usages = mod_usages ++ map to_file_usage (zip dependent_files mtimes)
+        ; usages `seqList`  return usages }
+         -- seq the list of Usages returned: occasionally these
+         -- don't get evaluated for a while and we can end up hanging on to
+         -- the entire collection of Ifaces.
    where
      to_file_usage (f, mtime) = UsageFile { usg_file_path = f, usg_mtime = mtime }
 
@@ -898,22 +921,22 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
         | otherwise
         = case nameModule_maybe name of
              Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map
-	     	-- See Note [Internal used_names]
+                -- See Note [Internal used_names]
 
              Just mod -> -- This lambda function is really just a
                          -- specialised (++); originally came about to
                          -- avoid quadratic behaviour (trac #2680)
                          extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
-    	        where occ = nameOccName name
+                where occ = nameOccName name
     
     -- We want to create a Usage for a home module if 
-    --	a) we used something from it; has something in used_names
-    --	b) we imported it, even if we used nothing from it
-    --	   (need to recompile if its export list changes: export_fprint)
+    --  a) we used something from it; has something in used_names
+    --  b) we imported it, even if we used nothing from it
+    --     (need to recompile if its export list changes: export_fprint)
     mkUsage :: Module -> Maybe Usage
     mkUsage mod
-      | isNothing maybe_iface		-- We can't depend on it if we didn't
-                        		-- load its interface.
+      | isNothing maybe_iface           -- We can't depend on it if we didn't
+                                        -- load its interface.
       || mod == this_mod                -- We don't care about usages of
                                         -- things in *this* module
       = Nothing
@@ -925,15 +948,15 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
         -- for package modules, we record the module hash only
 
       | (null used_occs
-	  && isNothing export_hash
+          && isNothing export_hash
           && not is_direct_import
-	  && not finsts_mod)
-      = Nothing			-- Record no usage info
+          && not finsts_mod)
+      = Nothing                 -- Record no usage info
         -- for directly-imported modules, we always want to record a usage
         -- on the orphan hash.  This is what triggers a recompilation if
         -- an orphan is added or removed somewhere below us in the future.
     
-      | otherwise	
+      | otherwise       
       = Just UsageHomeModule { 
                       usg_mod_name = moduleName mod,
                       usg_mod_hash = mod_hash,
@@ -946,7 +969,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
                 -- modules accumulate in the PIT not HPT.  Sigh.
 
         Just iface   = maybe_iface
-	finsts_mod   = mi_finsts    iface
+        finsts_mod   = mi_finsts    iface
         hash_env     = mi_hash_fn   iface
         mod_hash     = mi_mod_hash  iface
         export_hash | depend_on_exports = Just (mi_exp_hash iface)
@@ -962,12 +985,12 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
     
         used_occs = lookupModuleEnv ent_map mod `orElse` []
 
-    	-- Making a Map here ensures that (a) we remove duplicates
+        -- Making a Map here ensures that (a) we remove duplicates
         -- when we have usages on several subordinates of a single parent,
         -- and (b) that the usages emerge in a canonical order, which
         -- is why we use Map rather than OccEnv: Map works
         -- using Ord on the OccNames, which is a lexicographic ordering.
-	ent_hashs :: Map OccName Fingerprint
+        ent_hashs :: Map OccName Fingerprint
         ent_hashs = Map.fromList (map lookup_occ used_occs)
         
         lookup_occ occ = 
@@ -1020,10 +1043,10 @@ mkIfaceExports exports
 Note [Orignal module]
 ~~~~~~~~~~~~~~~~~~~~~
 Consider this:
-	module X where { data family T }
-	module Y( T(..) ) where { import X; data instance T Int = MkT Int }
+        module X where { data family T }
+        module Y( T(..) ) where { import X; data instance T Int = MkT Int }
 The exported Avail from Y will look like
-	X.T{X.T, Y.MkT}
+        X.T{X.T, Y.MkT}
 That is, in Y, 
   - only MkT is brought into scope by the data instance;
   - but the parent (used for grouping and naming in T(..) exports) is X.T
@@ -1043,19 +1066,25 @@ Trac #5362 for an example.  Such Names are always
 
 
 %************************************************************************
-%*									*
-	Load the old interface file for this module (unless
-	we have it aleady), and check whether it is up to date
-	
-%*									*
+%*                                                                      *
+        Load the old interface file for this module (unless
+        we have it already), and check whether it is up to date
+        
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
+-- | Top level function to check if the version of an old interface file
+-- is equivalent to the current source file the user asked us to compile.
+-- If the same, we can avoid recompilation. We return a tuple where the
+-- first element is a bool saying if we should recompile the object file
+-- and the second is maybe the interface file, where Nothng means to
+-- rebuild the interface file not use the exisitng one.
 checkOldIface :: HscEnv
-	      -> ModSummary
+              -> ModSummary
               -> SourceModified
-	      -> Maybe ModIface 	-- Old interface from compilation manager, if any
-	      -> IO (RecompileRequired, Maybe ModIface)
+              -> Maybe ModIface         -- Old interface from compilation manager, if any
+              -> IO (RecompileRequired, Maybe ModIface)
 
 checkOldIface hsc_env mod_summary source_modified maybe_iface
   = do  showPass (hsc_dflags hsc_env) $
@@ -1068,80 +1097,88 @@ check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface
 check_old_iface hsc_env mod_summary src_modified maybe_iface
   = let dflags = hsc_dflags hsc_env
         getIface =
-             case maybe_iface of
-                 Just _  -> do
-                     traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
-                     return maybe_iface
-                 Nothing -> do
-                     let iface_path = msHiFilePath mod_summary
-                     read_result <- readIface (ms_mod mod_summary) iface_path False
-                     case read_result of
-                         Failed err -> do
-                             traceIf (text "FYI: cannont read old interface file:" $$ nest 4 err)
-                             return Nothing
-                         Succeeded iface -> do
-                             traceIf (text "Read the interface file" <+> text iface_path)
-                             return $ Just iface
-
+            case maybe_iface of
+                Just _  -> do
+                    traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
+                    return maybe_iface
+                Nothing -> loadIface
+
+        loadIface = do
+             let iface_path = msHiFilePath mod_summary
+             read_result <- readIface (ms_mod mod_summary) iface_path False
+             case read_result of
+                 Failed err -> do
+                     traceIf (text "FYI: cannont read old interface file:" $$ nest 4 err)
+                     return Nothing
+                 Succeeded iface -> do
+                     traceIf (text "Read the interface file" <+> text iface_path)
+                     return $ Just iface
+
+        src_changed
+            | dopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
+            | SourceModified <- src_modified = True
+            | otherwise = False
     in do
-         let src_changed
-              | dopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
-              | SourceModified <- src_modified = True
-              | otherwise = False
-
-         when src_changed
-             (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
-
-         -- If the source has changed and we're in interactive mode,
-         -- avoid reading an interface; just return the one we might
-         -- have been supplied with.
-         if not (isObjectTarget $ hscTarget dflags) && src_changed
-            then return (outOfDate, maybe_iface)
-            else do
-                -- Try and read the old interface for the current module
-                -- from the .hi file left from the last time we compiled it
+        when src_changed $
+            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
+
+        case src_changed of
+            -- If the source has changed and we're in interactive mode,
+            -- avoid reading an interface; just return the one we might
+            -- have been supplied with.
+            True | not (isObjectTarget $ hscTarget dflags) ->
+                return (outOfDate, maybe_iface)
+
+            -- Try and read the old interface for the current module
+            -- from the .hi file left from the last time we compiled it
+            True -> do
                 maybe_iface' <- getIface
-                if src_changed
-                   then return (outOfDate, maybe_iface')
-                   else do
-                case maybe_iface' of
-                    Nothing -> return (outOfDate, maybe_iface')
-                    Just iface ->
-                      -- We have got the old iface; check its versions
-                      -- even in the SourceUnmodifiedAndStable case we
-                      -- should check versions because some packages
-                      -- might have changed or gone away.
-                      checkVersions hsc_env mod_summary iface
-\end{code}
-
-@recompileRequired@ is called from the HscMain.   It checks whether
-a recompilation is required.  It needs access to the persistent state,
-finder, etc, because it may have to load lots of interface files to
-check their versions.
+                return (outOfDate, maybe_iface')
 
-\begin{code}
+            False -> do
+                maybe_iface' <- getIface
+                case maybe_iface' of
+                    -- We can't retrieve the iface
+                    Nothing    -> return (outOfDate, Nothing)
+
+                    -- We have got the old iface; check its versions
+                    -- even in the SourceUnmodifiedAndStable case we
+                    -- should check versions because some packages
+                    -- might have changed or gone away.
+                    Just iface -> checkVersions hsc_env mod_summary iface
+
+-- | @recompileRequired@ is called from the HscMain.   It checks whether
+-- a recompilation is required.  It needs access to the persistent state,
+-- finder, etc, because it may have to load lots of interface files to
+-- check their versions.
 type RecompileRequired = Bool
 upToDate, outOfDate :: Bool
-upToDate  = False	-- Recompile not required
-outOfDate = True	-- Recompile required
-
--- | Check the safe haskell flags haven't changed
---   (e.g different flag on command line now)
-safeHsChanged :: HscEnv -> ModIface -> Bool
-safeHsChanged hsc_env iface
-  = (getSafeMode $ mi_trust iface) /= (safeHaskell $ hsc_dflags hsc_env)
+upToDate  = False  -- Recompile not required
+outOfDate = True   -- Recompile required
 
+-- | Check if a module is still the same 'version'.
+--
+-- This function is called in the recompilation checker after we have
+-- determined that the module M being checked hasn't had any changes
+-- to its source file since we last compiled M. So at this point in general
+-- two things may have changed that mean we should recompile M:
+--   * The interface export by a dependency of M has changed.
+--   * The compiler flags specified this time for M have changed
+--     in a manner that is significant for recompilaiton.
+-- We return not just if we should recompile the object file but also
+-- if we should rebuild the interface file.
 checkVersions :: HscEnv
               -> ModSummary
-	      -> ModIface 	-- Old interface
-	      -> IfG (RecompileRequired, Maybe ModIface)
+              -> ModIface       -- Old interface
+              -> IfG (RecompileRequired, Maybe ModIface)
 checkVersions hsc_env mod_summary iface
   = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
                         ppr (mi_module iface) <> colon)
 
+       ; recomp <- checkFlagHash hsc_env iface
+       ; if recomp then return (outOfDate, Nothing) else do {
        ; recomp <- checkDependencies hsc_env mod_summary iface
        ; if recomp then return (outOfDate, Just iface) else do {
-       ; if trust_dif then return (outOfDate, Nothing) else do {
 
        -- Source code unchanged and no errors yet... carry on
        --
@@ -1161,12 +1198,20 @@ checkVersions hsc_env mod_summary iface
        ; return (recomp, Just iface)
     }}}
   where
-    this_pkg  = thisPackage (hsc_dflags hsc_env)
-    trust_dif = safeHsChanged hsc_env iface
+    this_pkg = thisPackage (hsc_dflags hsc_env)
     -- This is a bit of a hack really
     mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
     mod_deps = mkModDeps (dep_mods (mi_deps iface))
 
+-- | Check the flags haven't changed
+checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkFlagHash hsc_env iface = do
+    let old_hash = mi_flag_hash iface
+    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) putNameLiterally
+    case old_hash == new_hash of
+        True  -> up_to_date (ptext $ sLit "Module flags unchanged")
+        False -> out_of_date_hash (ptext $ sLit "  Module flags have changed")
+                     old_hash new_hash
 
 -- If the direct imports of this module are resolved to targets that
 -- are not among the dependencies of the previous interface file,
@@ -1217,13 +1262,13 @@ checkDependencies hsc_env summary iface
 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
               -> IfG RecompileRequired
 needInterface mod continue
-  = do	-- Load the imported interface if possible
+  = do  -- Load the imported interface if possible
     let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
     traceHiDiffs (text "Checking usages for module" <+> ppr mod)
 
     mb_iface <- loadInterface doc_str mod ImportBySystem
-	-- Load the interface, but don't complain on failure;
-	-- Instead, get an Either back which we can test
+        -- Load the interface, but don't complain on failure;
+        -- Instead, get an Either back which we can test
 
     case mb_iface of
       Failed _ ->  (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
@@ -1235,11 +1280,10 @@ needInterface mod continue
       Succeeded iface -> continue iface
 
 
-checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
--- Given the usage information extracted from the old
+-- | Given the usage information extracted from the old
 -- M.hi file for the module being compiled, figure out
 -- whether M needs to be recompiled.
-
+checkModUsage :: PackageId -> Usage -> IfG RecompileRequired
 checkModUsage _this_pkg UsagePackageModule{
                                 usg_mod = mod,
                                 usg_mod_hash = old_mod_hash }
@@ -1253,30 +1297,30 @@ checkModUsage _this_pkg UsagePackageModule{
 checkModUsage this_pkg UsageHomeModule{ 
                                 usg_mod_name = mod_name, 
                                 usg_mod_hash = old_mod_hash,
-		       		usg_exports = maybe_old_export_hash,
-		       		usg_entities = old_decl_hash }
+                                usg_exports = maybe_old_export_hash,
+                                usg_entities = old_decl_hash }
   = do
     let mod = mkModule this_pkg mod_name
     needInterface mod $ \iface -> do
 
     let
-	new_mod_hash    = mi_mod_hash    iface
-	new_decl_hash 	= mi_hash_fn     iface
-	new_export_hash = mi_exp_hash    iface
+        new_mod_hash    = mi_mod_hash    iface
+        new_decl_hash   = mi_hash_fn     iface
+        new_export_hash = mi_exp_hash    iface
 
-	-- CHECK MODULE
+        -- CHECK MODULE
     recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
     if not recompile then return upToDate else do
-				 
-	-- CHECK EXPORT LIST
+                                 
+        -- CHECK EXPORT LIST
     checkMaybeHash maybe_old_export_hash new_export_hash
         (ptext (sLit "  Export list changed")) $ do
 
-	-- CHECK ITEMS ONE BY ONE
+        -- CHECK ITEMS ONE BY ONE
     recompile <- checkList [ checkEntityUsage new_decl_hash u 
                            | u <- old_decl_hash]
     if recompile 
-      then return outOfDate	-- This one failed, so just bail out now
+      then return outOfDate     -- This one failed, so just bail out now
       else up_to_date (ptext (sLit "  Great!  The bits I use are up to date"))
  
 
@@ -1285,16 +1329,15 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file, usg_mtime = old_mtime }
   return $ old_mtime /= new_mtime
 
 
-
 ------------------------
-checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
+checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG RecompileRequired
 checkModuleFingerprint old_mod_hash new_mod_hash
   | new_mod_hash == old_mod_hash
   = up_to_date (ptext (sLit "Module fingerprint unchanged"))
 
   | otherwise
   = out_of_date_hash (ptext (sLit "  Module fingerprint has changed"))
-		     old_mod_hash new_mod_hash
+                     old_mod_hash new_mod_hash
 
 ------------------------
 checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
@@ -1308,31 +1351,31 @@ checkMaybeHash maybe_old_hash new_hash doc continue
 ------------------------
 checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
                  -> (OccName, Fingerprint)
-                 -> IfG Bool
+                 -> IfG RecompileRequired
 checkEntityUsage new_hash (name,old_hash)
   = case new_hash name of
 
-	Nothing       -> 	-- We used it before, but it ain't there now
-			  out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
+        Nothing       ->        -- We used it before, but it ain't there now
+                          out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
 
-	Just (_, new_hash) 	-- It's there, but is it up to date?
-	  | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
-			  	       return upToDate
-	  | otherwise	 	 -> out_of_date_hash (ptext (sLit "  Out of date:") <+> ppr name)
-						     old_hash new_hash
+        Just (_, new_hash)      -- It's there, but is it up to date?
+          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
+                                       return upToDate
+          | otherwise            -> out_of_date_hash (ptext (sLit "  Out of date:") <+> ppr name)
+                                                     old_hash new_hash
 
-up_to_date, out_of_date :: SDoc -> IfG Bool
+up_to_date, out_of_date :: SDoc -> IfG RecompileRequired
 up_to_date  msg = traceHiDiffs msg >> return upToDate
 out_of_date msg = traceHiDiffs msg >> return outOfDate
 
-out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
+out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
 out_of_date_hash msg old_hash new_hash 
   = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
 
 ----------------------
 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
 -- This helper is used in two places
-checkList []		 = return upToDate
+checkList []             = return upToDate
 checkList (check:checks) = do recompile <- check
                               if recompile
                                 then return outOfDate
@@ -1340,79 +1383,79 @@ checkList (check:checks) = do recompile <- check
 \end{code}
 
 %************************************************************************
-%*				 					*
-		Converting things to their Iface equivalents
-%*				 					*
+%*                                                                      *
+                Converting things to their Iface equivalents
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 tyThingToIfaceDecl :: TyThing -> IfaceDecl
 -- Assumption: the thing is already tidied, so that locally-bound names
--- 	       (lambdas, for-alls) already have non-clashing OccNames
+--             (lambdas, for-alls) already have non-clashing OccNames
 -- Reason: Iface stuff uses OccNames, and the conversion here does
---	   not do tidying on the way
+--         not do tidying on the way
 tyThingToIfaceDecl (AnId id)
   = IfaceId { ifName      = getOccName id,
-	      ifType      = toIfaceType (idType id),
-	      ifIdDetails = toIfaceIdDetails (idDetails id),
-	      ifIdInfo    = toIfaceIdInfo (idInfo id) }
+              ifType      = toIfaceType (idType id),
+              ifIdDetails = toIfaceIdDetails (idDetails id),
+              ifIdInfo    = toIfaceIdInfo (idInfo id) }
 
 tyThingToIfaceDecl (ATyCon tycon)
   | Just clas <- tyConClass_maybe tycon
   = classToIfaceDecl clas
 
   | isSynTyCon tycon
-  = IfaceSyn {	ifName    = getOccName tycon,
-		ifTyVars  = toIfaceTvBndrs tyvars,
-		ifSynRhs  = syn_rhs,
-	  	ifSynKind = syn_ki,
+  = IfaceSyn {  ifName    = getOccName tycon,
+                ifTyVars  = toIfaceTvBndrs tyvars,
+                ifSynRhs  = syn_rhs,
+                ifSynKind = syn_ki,
                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
              }
 
   | isAlgTyCon tycon
-  = IfaceData {	ifName    = getOccName tycon,
-		ifTyVars  = toIfaceTvBndrs tyvars,
-		ifCtxt    = toIfaceContext (tyConStupidTheta tycon),
-		ifCons    = ifaceConDecls (algTyConRhs tycon),
-	  	ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
-		ifGadtSyntax = isGadtSyntaxTyCon tycon,
-		ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
+  = IfaceData { ifName    = getOccName tycon,
+                ifTyVars  = toIfaceTvBndrs tyvars,
+                ifCtxt    = toIfaceContext (tyConStupidTheta tycon),
+                ifCons    = ifaceConDecls (algTyConRhs tycon),
+                ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
+                ifGadtSyntax = isGadtSyntaxTyCon tycon,
+                ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
 
   | isForeignTyCon tycon
   = IfaceForeign { ifName    = getOccName tycon,
-	    	   ifExtName = tyConExtName tycon }
+                   ifExtName = tyConExtName tycon }
 
   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
   where
     tyvars = tyConTyVars tycon
     (syn_rhs, syn_ki) 
        = case synTyConRhs tycon of
-	    SynFamilyTyCon  -> (Nothing,               toIfaceType (synTyConResKind tycon))
-	    SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
+            SynFamilyTyCon  -> (Nothing,               toIfaceType (synTyConResKind tycon))
+            SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
 
     ifaceConDecls (NewTyCon { data_con = con })     = 
       IfNewTyCon  (ifaceConDecl con)
     ifaceConDecls (DataTyCon { data_cons = cons })  = 
       IfDataTyCon (map ifaceConDecl cons)
     ifaceConDecls DataFamilyTyCon {}                = IfOpenDataTyCon
-    ifaceConDecls (AbstractTyCon distinct)	    = IfAbstractTyCon distinct
-	-- The last case happens when a TyCon has been trimmed during tidying
-	-- Furthermore, tyThingToIfaceDecl is also used
-	-- in TcRnDriver for GHCi, when browsing a module, in which case the
-	-- AbstractTyCon case is perfectly sensible.
+    ifaceConDecls (AbstractTyCon distinct)          = IfAbstractTyCon distinct
+        -- The last case happens when a TyCon has been trimmed during tidying
+        -- Furthermore, tyThingToIfaceDecl is also used
+        -- in TcRnDriver for GHCi, when browsing a module, in which case the
+        -- AbstractTyCon case is perfectly sensible.
 
     ifaceConDecl data_con 
-	= IfCon   { ifConOcc   	 = getOccName (dataConName data_con),
-		    ifConInfix 	 = dataConIsInfix data_con,
-		    ifConWrapper = isJust (dataConWrapId_maybe data_con),
-		    ifConUnivTvs = toIfaceTvBndrs univ_tvs,
-		    ifConExTvs   = toIfaceTvBndrs ex_tvs,
-		    ifConEqSpec  = to_eq_spec eq_spec,
-		    ifConCtxt    = toIfaceContext theta,
-		    ifConArgTys  = map toIfaceType arg_tys,
-		    ifConFields  = map getOccName 
-				       (dataConFieldLabels data_con),
-		    ifConStricts = dataConStrictMarks data_con }
+        = IfCon   { ifConOcc     = getOccName (dataConName data_con),
+                    ifConInfix   = dataConIsInfix data_con,
+                    ifConWrapper = isJust (dataConWrapId_maybe data_con),
+                    ifConUnivTvs = toIfaceTvBndrs univ_tvs,
+                    ifConExTvs   = toIfaceTvBndrs ex_tvs,
+                    ifConEqSpec  = to_eq_spec eq_spec,
+                    ifConCtxt    = toIfaceContext theta,
+                    ifConArgTys  = map toIfaceType arg_tys,
+                    ifConFields  = map getOccName 
+                                       (dataConFieldLabels data_con),
+                    ifConStricts = dataConStrictMarks data_con }
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
@@ -1425,7 +1468,7 @@ tyThingToIfaceDecl (ATyCon tycon)
 tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c)
 
 tyThingToIfaceDecl (ADataCon dc)
- = pprPanic "toIfaceDecl" (ppr dc)	-- Should be trimmed out earlier
+ = pprPanic "toIfaceDecl" (ppr dc)      -- Should be trimmed out earlier
 
 
 classToIfaceDecl :: Class -> IfaceDecl
@@ -1447,7 +1490,7 @@ classToIfaceDecl clas
       = IfaceAT (tyThingToIfaceDecl (ATyCon tc))
                 (map to_if_at_def defs)
       where
-        to_if_at_def (ATD tvs pat_tys ty)
+        to_if_at_def (ATD tvs pat_tys ty _loc)
           = IfaceATD (toIfaceTvBndrs tvs) (map toIfaceType pat_tys) (toIfaceType ty)
 
     toIfaceClassOp (sel_id, def_meth)
@@ -1478,10 +1521,10 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
                                 is_cls = cls_name, is_tcs = mb_tcs })
   = ASSERT( cls_name == className cls )
     IfaceInst { ifDFun    = dfun_name,
-		ifOFlag   = oflag,
-		ifInstCls = cls_name,
-		ifInstTys = map do_rough mb_tcs,
-		ifInstOrph = orph }
+                ifOFlag   = oflag,
+                ifInstCls = cls_name,
+                ifInstTys = map do_rough mb_tcs,
+                ifInstOrph = orph }
   where
     do_rough Nothing  = Nothing
     do_rough (Just n) = Just (toIfaceTyCon_name n)
@@ -1490,26 +1533,26 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
     mod       = ASSERT( isExternalName dfun_name ) nameModule dfun_name
     is_local name = nameIsLocalOrFrom mod name
 
-	-- Compute orphanhood.  See Note [Orphans] in IfaceSyn
+        -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
     (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
-		-- Slightly awkward: we need the Class to get the fundeps
+                -- Slightly awkward: we need the Class to get the fundeps
     (tvs, fds) = classTvsFds cls
     arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]
     orph | is_local cls_name = Just (nameOccName cls_name)
-	 | all isJust mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
-	 | otherwise	     = Nothing
+         | all isJust mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
+         | otherwise         = Nothing
     
-    mb_ns :: [Maybe OccName]	-- One for each fundep; a locally-defined name
-				-- that is not in the "determined" arguments
+    mb_ns :: [Maybe OccName]    -- One for each fundep; a locally-defined name
+                                -- that is not in the "determined" arguments
     mb_ns | null fds   = [choose_one arg_names]
-	  | otherwise  = map do_one fds
+          | otherwise  = map do_one fds
     do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
                                           , not (tv `elem` rtvs)]
 
     choose_one :: [NameSet] -> Maybe OccName
     choose_one nss = case nameSetToList (unionManyNameSets nss) of
-			[]      -> Nothing
-			(n : _) -> Just (nameOccName n)
+                        []      -> Nothing
+                        (n : _) -> Just (nameOccName n)
 
 --------------------------
 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
@@ -1517,8 +1560,8 @@ famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
                                  fi_fam = fam,
                                  fi_tcs = mb_tcs })
   = IfaceFamInst { ifFamInstTyCon  = toIfaceTyCon tycon
-		 , ifFamInstFam    = fam
-		 , ifFamInstTys    = map do_rough mb_tcs }
+                 , ifFamInstFam    = fam
+                 , ifFamInstTys    = map do_rough mb_tcs }
   where
     do_rough Nothing  = Nothing
     do_rough (Just n) = Just (toIfaceTyCon_name n)
@@ -1526,50 +1569,50 @@ famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
 --------------------------
 toIfaceLetBndr :: Id -> IfaceLetBndr
 toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
-			       (toIfaceType (idType id)) 
-			       (toIfaceIdInfo (idInfo id))
+                               (toIfaceType (idType id)) 
+                               (toIfaceIdInfo (idInfo id))
   -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr 
   -- has left on the Id.  See Note [IdInfo on nested let-bindings] in IfaceSyn
 
 --------------------------
 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
-toIfaceIdDetails VanillaId 		        = IfVanillaId
+toIfaceIdDetails VanillaId                      = IfVanillaId
 toIfaceIdDetails (DFunId {})                    = IfDFunId 
 toIfaceIdDetails (RecSelId { sel_naughty = n
-		 	   , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
-toIfaceIdDetails other	     		        = pprTrace "toIfaceIdDetails" (ppr other) 
+                           , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
+toIfaceIdDetails other                          = pprTrace "toIfaceIdDetails" (ppr other) 
                                                   IfVanillaId   -- Unexpected
 
 toIfaceIdInfo :: IdInfo -> IfaceIdInfo
 toIfaceIdInfo id_info
   = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
-	            inline_hsinfo,  unfold_hsinfo] of
+                    inline_hsinfo,  unfold_hsinfo] of
        []    -> NoInfo
        infos -> HasInfo infos
-	       -- NB: strictness must appear in the list before unfolding
-	       -- See TcIface.tcUnfolding
+               -- NB: strictness must appear in the list before unfolding
+               -- See TcIface.tcUnfolding
   where
     ------------  Arity  --------------
     arity_info = arityInfo id_info
     arity_hsinfo | arity_info == 0 = Nothing
-		 | otherwise       = Just (HsArity arity_info)
+                 | otherwise       = Just (HsArity arity_info)
 
     ------------ Caf Info --------------
     caf_info   = cafInfo id_info
     caf_hsinfo = case caf_info of
-		   NoCafRefs -> Just HsNoCafRefs
-		   _other    -> Nothing
+                   NoCafRefs -> Just HsNoCafRefs
+                   _other    -> Nothing
 
     ------------  Strictness  --------------
-	-- No point in explicitly exporting TopSig
+        -- No point in explicitly exporting TopSig
     strict_hsinfo = case strictnessInfo id_info of
-			Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
-			_other			      -> Nothing
+                        Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
+                        _other                        -> Nothing
 
     ------------  Unfolding  --------------
     unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) 
     loop_breaker  = isStrongLoopBreaker (occInfo id_info)
-					
+                                        
     ------------  Inline prag  --------------
     inline_prag = inlinePragInfo id_info
     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
@@ -1581,20 +1624,20 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
                                 , uf_src = src, uf_guidance = guidance })
   = Just $ HsUnfold lb $
     case src of
-	InlineStable
+        InlineStable
           -> case guidance of
                UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
                _other                     -> IfCoreUnfold True if_rhs
-	InlineWrapper w | isExternalName n -> IfExtWrapper arity n
-	                | otherwise        -> IfLclWrapper arity (getFS n)
-			where
+        InlineWrapper w | isExternalName n -> IfExtWrapper arity n
+                        | otherwise        -> IfLclWrapper arity (getFS n)
+                        where
                           n = idName w
         InlineCompulsory -> IfCompulsory if_rhs
         InlineRhs        -> IfCoreUnfold False if_rhs
-	-- Yes, even if guidance is UnfNever, expose the unfolding
-	-- If we didn't want to expose the unfolding, TidyPgm would
-	-- have stuck in NoUnfolding.  For supercompilation we want 
-	-- to see that unfolding!
+        -- Yes, even if guidance is UnfNever, expose the unfolding
+        -- If we didn't want to expose the unfolding, TidyPgm would
+        -- have stuck in NoUnfolding.  For supercompilation we want 
+        -- to see that unfolding!
   where
     if_rhs = toIfaceExpr rhs
 
@@ -1614,39 +1657,39 @@ coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
 
 coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, 
                                      ru_act = act, ru_bndrs = bndrs,
-	                             ru_args = args, ru_rhs = rhs, 
+                                     ru_args = args, ru_rhs = rhs, 
                                      ru_auto = auto })
   = IfaceRule { ifRuleName  = name, ifActivation = act, 
-		ifRuleBndrs = map toIfaceBndr bndrs,
-		ifRuleHead  = fn, 
-		ifRuleArgs  = map do_arg args,
-		ifRuleRhs   = toIfaceExpr rhs,
+                ifRuleBndrs = map toIfaceBndr bndrs,
+                ifRuleHead  = fn, 
+                ifRuleArgs  = map do_arg args,
+                ifRuleRhs   = toIfaceExpr rhs,
                 ifRuleAuto  = auto,
-		ifRuleOrph  = orph }
+                ifRuleOrph  = orph }
   where
-	-- For type args we must remove synonyms from the outermost
-	-- level.  Reason: so that when we read it back in we'll
-	-- construct the same ru_rough field as we have right now;
-	-- see tcIfaceRule
+        -- For type args we must remove synonyms from the outermost
+        -- level.  Reason: so that when we read it back in we'll
+        -- construct the same ru_rough field as we have right now;
+        -- see tcIfaceRule
     do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
     do_arg (Coercion co) = IfaceType (coToIfaceType co)
                            
     do_arg arg       = toIfaceExpr arg
 
-	-- Compute orphanhood.  See Note [Orphans] in IfaceSyn
-	-- A rule is an orphan only if none of the variables
-	-- mentioned on its left-hand side are locally defined
+        -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
+        -- A rule is an orphan only if none of the variables
+        -- mentioned on its left-hand side are locally defined
     lhs_names = nameSetToList (ruleLhsOrphNames rule)
 
     orph = case filter (nameIsLocalOrFrom mod) lhs_names of
-			(n : _) -> Just (nameOccName n)
-			[]      -> Nothing
+                        (n : _) -> Just (nameOccName n)
+                        []      -> Nothing
 
 bogusIfaceRule :: Name -> IfaceRule
 bogusIfaceRule id_name
   = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,  
-	ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], 
-	ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
+        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], 
+        ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
 
 ---------------------
 toIfaceExpr :: CoreExpr -> IfaceExpr
@@ -1688,14 +1731,14 @@ toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
 toIfaceApp (App f a) as = toIfaceApp f (a:as)
 toIfaceApp (Var v) as
   = case isDataConWorkId_maybe v of
-	-- We convert the *worker* for tuples into IfaceTuples
-	Just dc |  isTupleTyCon tc && saturated 
-		-> IfaceTuple (tupleTyConSort tc) tup_args
-	  where
-	    val_args  = dropWhile isTypeArg as
-	    saturated = val_args `lengthIs` idArity v
-	    tup_args  = map toIfaceExpr val_args
-	    tc	      = dataConTyCon dc
+        -- We convert the *worker* for tuples into IfaceTuples
+        Just dc |  isTupleTyCon tc && saturated 
+                -> IfaceTuple (tupleTyConSort tc) tup_args
+          where
+            val_args  = dropWhile isTypeArg as
+            saturated = val_args `lengthIs` idArity v
+            tup_args  = map toIfaceExpr val_args
+            tc        = dataConTyCon dc
 
         _ -> mkIfaceApps (toIfaceVar v) as
 
@@ -1709,7 +1752,7 @@ toIfaceVar :: Id -> IfaceExpr
 toIfaceVar v
     | Just fcall <- isFCallId_maybe v            = IfaceFCall fcall (toIfaceType (idType v))
        -- Foreign calls have special syntax
-    | isExternalName name		         = IfaceExt name
+    | isExternalName name                        = IfaceExt name
     | otherwise                                  = IfaceLcl (getFS name)
   where name = idName v
 \end{code}
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index a11051b65f..d17b90d7f3 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -41,7 +41,7 @@ import TyCon
 import DataCon
 import PrelNames
 import TysWiredIn
-import TysPrim          ( anyTyConOfKind )
+import TysPrim          ( tySuperKindTyCon )
 import BasicTypes       ( Arity, strongLoopBreaker )
 import Literal
 import qualified Var
@@ -273,7 +273,7 @@ typecheckIface iface
         ; anns      <- tcIfaceAnnotations (mi_anns iface)
 
                 -- Vectorisation information
-        ; vect_info <- tcIfaceVectInfo (mi_module iface) (mi_vect_info iface)
+        ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env (mi_vect_info iface)
 
                 -- Exports
         ; exports <- ifaceExportNames (mi_exports iface)
@@ -502,7 +502,9 @@ tc_iface_decl _parent ignore_prags
        return tc
 
    tc_iface_at_def (IfaceATD tvs pat_tys ty) =
-       bindIfaceTyVars_AT tvs $ \tvs' -> liftM2 (ATD tvs') (mapM tcIfaceType pat_tys) (tcIfaceType ty)
+       bindIfaceTyVars_AT tvs $
+         \tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan)
+                           (mapM tcIfaceType pat_tys) (tcIfaceType ty)
 
    mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
 
@@ -710,14 +712,21 @@ tcIfaceAnnTarget (ModuleTarget mod) = do
 %************************************************************************
 
 \begin{code}
-tcIfaceVectInfo :: Module -> IfaceVectInfo -> IfL VectInfo
-tcIfaceVectInfo mod (IfaceVectInfo 
-                     { ifaceVectInfoVar          = vars
-                     , ifaceVectInfoTyCon        = tycons
-                     , ifaceVectInfoTyConReuse   = tyconsReuse
-                     , ifaceVectInfoScalarVars   = scalarVars
-                     , ifaceVectInfoScalarTyCons = scalarTyCons
-                     })
+-- We need access to the type environment as we need to look up information about type constructors
+-- (i.e., their data constructors and whether they are class type constructors).  If a vectorised
+-- type constructor or class is defined in the same module as where it is vectorised, we cannot
+-- look that information up from the type constructor that we obtained via a 'forkM'ed
+-- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again
+-- and again and again...
+--
+tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
+tcIfaceVectInfo mod typeEnv (IfaceVectInfo 
+                             { ifaceVectInfoVar          = vars
+                             , ifaceVectInfoTyCon        = tycons
+                             , ifaceVectInfoTyConReuse   = tyconsReuse
+                             , ifaceVectInfoScalarVars   = scalarVars
+                             , ifaceVectInfoScalarTyCons = scalarTyCons
+                             })
   = do { let scalarTyConsSet = mkNameSet scalarTyCons
        ; vVars       <- mapM vectVarMapping                          vars
        ; tyConRes1   <- mapM vectTyConMapping                        tycons
@@ -750,8 +759,18 @@ tcIfaceVectInfo mod (IfaceVectInfo
 
     vectTyConMapping name 
       = do { vName  <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
-           ; tycon  <- forkM (text ("vect tycon") <+> ppr name) $
-                         tcIfaceTyCon (IfaceTc name)
+
+               -- we need a fully defined version of the type constructor to be able to extract
+               -- its data constructors etc.
+           ; tycon  <- do { let mb_tycon = lookupTypeEnv typeEnv name
+                          ; case mb_tycon of
+                                -- tycon is local
+                              Just (ATyCon tycon) -> return tycon
+                                -- name is not a tycon => internal inconsistency
+                              Just _              -> notATyConErr
+                                -- tycon is external
+                              Nothing             -> tcIfaceTyCon (IfaceTc name)
+                          }
            ; vTycon <- forkM (text ("vect vTycon") <+> ppr vName) $
                          tcIfaceTyCon (IfaceTc vName)
 
@@ -764,6 +783,8 @@ tcIfaceVectInfo mod (IfaceVectInfo
                     , vDataCons                        -- list of (Ci, Ci_v)
                     )
            }
+      where
+        notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
 
     vectTyConReuseMapping scalarNames name 
       = do { tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
@@ -1235,9 +1256,15 @@ tcIfaceGlobal name
 -- emasculated form (e.g. lacking data constructors).
 
 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
-tcIfaceTyCon (IfaceAnyTc kind)  = do { tc_kind <- tcIfaceType kind
-                                     ; tcWiredInTyCon (anyTyConOfKind tc_kind) }
-tcIfaceTyCon (IfaceTc name)     = do { thing <- tcIfaceGlobal name 
+tcIfaceTyCon IfaceIntTc         = tcWiredInTyCon intTyCon
+tcIfaceTyCon IfaceBoolTc        = tcWiredInTyCon boolTyCon
+tcIfaceTyCon IfaceCharTc        = tcWiredInTyCon charTyCon
+tcIfaceTyCon IfaceListTc        = tcWiredInTyCon listTyCon
+tcIfaceTyCon IfacePArrTc        = tcWiredInTyCon parrTyCon
+tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
+tcIfaceTyCon (IfaceIPTc n)      = do { n' <- newIPName n
+                                     ; tcWiredInTyCon (ipTyCon n') }
+tcIfaceTyCon (IfaceTc name)     = do { thing <- tcIfaceGlobal name
                                      ; return (check_tc (tyThingTyCon thing)) }
   where
     check_tc tc
@@ -1245,6 +1272,14 @@ tcIfaceTyCon (IfaceTc name)     = do { thing <- tcIfaceGlobal name
                    IfaceTc _ -> tc
                    _         -> pprTrace "check_tc" (ppr tc) tc
      | otherwise = tc
+-- we should be okay just returning Kind constructors without extra loading
+tcIfaceTyCon IfaceLiftedTypeKindTc   = return liftedTypeKindTyCon
+tcIfaceTyCon IfaceOpenTypeKindTc     = return openTypeKindTyCon
+tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
+tcIfaceTyCon IfaceArgTypeKindTc      = return argTypeKindTyCon
+tcIfaceTyCon IfaceUbxTupleKindTc     = return ubxTupleKindTyCon
+tcIfaceTyCon IfaceConstraintKindTc   = return constraintKindTyCon
+tcIfaceTyCon IfaceSuperKindTc        = return tySuperKindTyCon
 
 -- Even though we are in an interface file, we want to make
 -- sure the instances and RULES of this tycon are loaded 
@@ -1310,12 +1345,22 @@ bindIfaceTyVar (occ,kind) thing_inside
 
 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
 bindIfaceTyVars bndrs thing_inside
-  = do  { names <- newIfaceNames (map mkTyVarOccFS occs)
-        ; tyvars <- zipWithM mk_iface_tyvar names kinds
-        ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
+  = do { names <- newIfaceNames (map mkTyVarOccFS occs)
+        ; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds
+              (kis_name, tys_name) = splitAt (length kis_kind) names
+          -- We need to bring the kind variables in scope since type
+          -- variables may mention them.
+        ; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind
+        ; extendIfaceTyVarEnv kvs $ do
+        { tvs <- zipWithM mk_iface_tyvar tys_name tys_kind
+        ; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } }
   where
     (occs,kinds) = unzip bndrs
 
+isSuperIfaceKind :: IfaceKind -> Bool
+isSuperIfaceKind (IfaceTyConApp IfaceSuperKindTc []) = True
+isSuperIfaceKind _ = False
+
 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
 mk_iface_tyvar name ifKind
    = do { kind <- tcIfaceType ifKind
@@ -1328,12 +1373,14 @@ bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
 -- Here 'a' is in scope when we look at the 'data T'
 bindIfaceTyVars_AT [] thing_inside
   = thing_inside []
-bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside 
-  = bindIfaceTyVars_AT bs $ \ bs' ->
-    do { mb_tv <- lookupIfaceTyVar tv_occ
-       ; case mb_tv of
-           Just b' -> thing_inside (b':bs')
-           Nothing -> bindIfaceTyVar b $ \ b' -> 
-                      thing_inside (b':bs') }
-\end{code} 
+bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
+  = do { mb_tv <- lookupIfaceTyVar tv_occ
+       ; let bind_b :: (TyVar -> IfL a) -> IfL a
+             bind_b = case mb_tv of
+                        Just b' -> \k -> k b'
+                        Nothing -> bindIfaceTyVar b
+       ; bind_b $ \b' ->
+         bindIfaceTyVars_AT bs $ \bs' ->
+         thing_inside (b':bs') }
+\end{code}
 
diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot
index fd2b647046..a9684a6a91 100644
--- a/compiler/iface/TcIface.lhs-boot
+++ b/compiler/iface/TcIface.lhs-boot
@@ -7,13 +7,13 @@ import TcRnTypes   ( IfL )
 import InstEnv     ( Instance )
 import FamInstEnv  ( FamInst )
 import CoreSyn     ( CoreRule )
-import HscTypes    ( VectInfo, IfaceVectInfo )
+import HscTypes    ( TypeEnv, VectInfo, IfaceVectInfo )
 import Module      ( Module )
 import Annotations ( Annotation )
 
 tcIfaceDecl        :: Bool -> IfaceDecl -> IfL TyThing
 tcIfaceRules       :: Bool -> [IfaceRule] -> IfL [CoreRule]
-tcIfaceVectInfo    :: Module -> IfaceVectInfo -> IfL VectInfo
+tcIfaceVectInfo    :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
 tcIfaceInst        :: IfaceInst -> IfL Instance
 tcIfaceFamInst     :: IfaceFamInst -> IfL FamInst
 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 8037cfb21f..8c0f3a6098 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -138,7 +138,8 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
   -- This is needed when we try to compile the .hc file later, if it
   -- imports a _stub.h file that we created here.
    let current_dir = case takeDirectory basename of
-                     "" -> "." -- XXX Hack
+                     "" -> "." -- XXX Hack required for filepath-1.1 and earlier
+                               -- (GHC 6.12 and earlier)
                      d -> d
        old_paths   = includePaths dflags0
        dflags      = dflags0 { includePaths = current_dir : old_paths }
@@ -839,8 +840,9 @@ runPhase (Hsc src_flavour) input_fn dflags0
   -- the .hs files resides) to the include path, since this is
   -- what gcc does, and it's probably what you want.
         let current_dir = case takeDirectory basename of
-                      "" -> "." -- XXX Hack
-                      d -> d
+                     "" -> "." -- XXX Hack required for filepath-1.1 and earlier
+                               -- (GHC 6.12 and earlier)
+                     d -> d
 
             paths = includePaths dflags0
             dflags = dflags0 { includePaths = current_dir : paths }
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 2ece4763c5..2c0cccb0ba 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -37,7 +37,6 @@ module DynFlags (
         Option(..), showOpt,
         DynLibLoader(..),
         fFlags, fWarningFlags, fLangFlags, xFlags,
-        DPHBackend(..), dphPackageMaybe,
         wayNames, dynFlagDependencies,
 
         -- ** Safe Haskell
@@ -341,6 +340,7 @@ data WarningFlag =
    deriving (Eq, Show)
 
 data Language = Haskell98 | Haskell2010
+   deriving Enum
 
 -- | The various Safe Haskell modes
 data SafeHaskellMode
@@ -393,7 +393,8 @@ data ExtensionFlag
    | Opt_DoAndIfThenElse
    | Opt_RebindableSyntax
    | Opt_ConstraintKinds
-
+   | Opt_PolyKinds                -- Kind polymorphism
+   
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
    | Opt_DeriveFunctor
@@ -436,7 +437,7 @@ data ExtensionFlag
    | Opt_NondecreasingIndentation
    | Opt_RelaxedLayout
    | Opt_TraditionalRecordSyntax
-   deriving (Eq, Show)
+   deriving (Eq, Enum, Show)
 
 -- | Contains not only a collection of 'DynFlag's but also a plethora of
 -- information relating to the compilation of a single file or GHC session
@@ -467,8 +468,6 @@ data DynFlags = DynFlags {
   mainFunIs             :: Maybe String,
   ctxtStkDepth          :: Int,         -- ^ Typechecker context stack depth
 
-  dphBackend            :: DPHBackend,
-
   thisPackage           :: PackageId,   -- ^ name of package currently being compiled
 
   -- ways
@@ -841,8 +840,6 @@ defaultDynFlags mySettings =
         mainFunIs               = Nothing,
         ctxtStkDepth            = mAX_CONTEXT_REDUCTION_DEPTH,
 
-        dphBackend              = DPHNone,
-
         thisPackage             = mainPackageId,
 
         objectDir               = Nothing,
@@ -1622,13 +1619,6 @@ dynamic_flags = [
   , Flag "fprof-auto-exported"    (noArg (\d -> d { profAuto = ProfAutoExports } ))
   , Flag "fno-prof-auto"          (noArg (\d -> d { profAuto = NoProfAuto } ))
 
-        ------ DPH flags ----------------------------------------------------
-
-  , Flag "fdph-seq"         (NoArg (setDPHBackend DPHSeq))
-  , Flag "fdph-par"         (NoArg (setDPHBackend DPHPar))
-  , Flag "fdph-this"        (NoArg (setDPHBackend DPHThis))
-  , Flag "fdph-none"        (NoArg (setDPHBackend DPHNone))
-
         ------ Compiler flags -----------------------------------------------
 
   , Flag "fasm"             (NoArg (setObjTarget HscAsm))
@@ -1915,7 +1905,8 @@ xFlags = [
   ( "DoAndIfThenElse",                  Opt_DoAndIfThenElse, nop ),
   ( "RebindableSyntax",                 Opt_RebindableSyntax, nop ),
   ( "ConstraintKinds",                  Opt_ConstraintKinds, nop ),
-  ( "MonoPatBinds",                     Opt_MonoPatBinds,
+  ( "PolyKinds",                        Opt_PolyKinds, nop ),
+  ( "MonoPatBinds",                     Opt_MonoPatBinds, 
     \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ),
   ( "ExplicitForAll",                   Opt_ExplicitForAll, nop ),
   ( "AlternativeLayoutRule",            Opt_AlternativeLayoutRule, nop ),
@@ -1999,7 +1990,9 @@ impliedFlags
     , (Opt_TypeFamilies,     turnOn, Opt_MonoLocalBinds)
 
     , (Opt_TypeFamilies,     turnOn, Opt_KindSignatures)  -- Type families use kind signatures
-                                                     -- all over the place
+                                                          -- all over the place
+
+    , (Opt_PolyKinds,        turnOn, Opt_KindSignatures)
 
     , (Opt_ImpredicativeTypes,  turnOn, Opt_RankNTypes)
 
@@ -2358,29 +2351,6 @@ setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations  = 20
                                          , simplPhases         = 3
                                          })
 
--- Determines the package used by the vectoriser for the symbols of the vectorised code.
--- 'DPHNone' indicates that no data-parallel backend library is available; hence, the
--- vectoriser cannot be used.
---
-data DPHBackend = DPHPar    -- "dph-par"
-                | DPHSeq    -- "dph-seq"
-                | DPHThis   -- the currently compiled package
-                | DPHNone   -- no DPH library available
-        deriving(Eq, Ord, Enum, Show)
-
-setDPHBackend :: DPHBackend -> DynP ()
-setDPHBackend backend = upd $ \dflags -> dflags { dphBackend = backend }
-
--- Query the DPH backend package to be used by the vectoriser and desugaring of DPH syntax.
---
-dphPackageMaybe :: DynFlags -> Maybe PackageId
-dphPackageMaybe dflags
-  = case dphBackend dflags of
-      DPHPar  -> Just dphParPackageId
-      DPHSeq  -> Just dphSeqPackageId
-      DPHThis -> Just (thisPackage dflags)
-      DPHNone -> Nothing
-
 setMainIs :: String -> DynP ()
 setMainIs arg
   | not (null main_fn) && isLower (head main_fn)
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 039e8f15ba..d60e6d7f59 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -264,7 +264,7 @@ import RdrName
 import qualified HsSyn -- hack as we want to reexport the whole module
 import HsSyn hiding ((<.>))
 import Type     hiding( typeKind )
-import Coercion		( synTyConResKind )
+import Kind		( synTyConResKind )
 import TcType		hiding( typeKind )
 import Id
 import TysPrim		( alphaTyVars )
@@ -881,7 +881,7 @@ compileCore simplify fn = do
         gutsToCoreModule (Right mg) = CoreModule {
           cm_module  = mg_module mg,
           cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
-                                           (mg_tcs mg) (mg_clss mg)
+                                           (mg_tcs mg)
                                            (mg_fam_insts mg),
           cm_binds   = mg_binds mg
          }
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 753f044b71..ca524aa24b 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -83,7 +83,6 @@ import DsMeta           ( templateHaskellNames )
 import VarSet
 import VarEnv           ( emptyTidyEnv )
 import Panic
-import Class
 import Data.List
 #endif
 
@@ -1384,8 +1383,7 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do
     hsc_env <- getHscEnv
     liftIO $ linkDecls hsc_env src_span cbc
 
-    let tcs  = filter (not . isImplicitTyCon) $ mg_tcs simpl_mg
-        clss = mg_clss simpl_mg
+    let tcs         = filter (not . isImplicitTyCon) $ (mg_tcs simpl_mg)
 
         ext_vars = filter (isExternalName . idName) $
                       bindersOfBinds core_binds
@@ -1400,7 +1398,6 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do
 
         tythings =  map AnId user_vars
                  ++ map ATyCon tcs
-                 ++ map (ATyCon . classTyCon) clss
 
     let ictxt1 = extendInteractiveContext icontext tythings
         ictxt  = ictxt1 { ic_sys_vars  = sys_vars ++ ic_sys_vars ictxt1,
@@ -1506,7 +1503,6 @@ mkModGuts mod binds =
         mg_rdr_env      = emptyGlobalRdrEnv,
         mg_fix_env      = emptyFixityEnv,
         mg_tcs          = [],
-        mg_clss         = [],
         mg_insts        = [],
         mg_fam_insts    = [],
         mg_rules        = [],
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 14d1469ebe..3391f6a5ed 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -114,15 +114,15 @@ import {-# SOURCE #-}  InteractiveEval ( Resume )
 
 import HsSyn
 import RdrName
-import Name
 import Avail
-import NameEnv
-import NameSet  
 import Module
 import InstEnv          ( InstEnv, Instance )
 import FamInstEnv
 import Rules            ( RuleBase )
 import CoreSyn          ( CoreProgram )
+import Name
+import NameEnv
+import NameSet  
 import VarEnv
 import VarSet
 import Var
@@ -135,7 +135,7 @@ import Class
 import TyCon
 import DataCon
 import PrelNames        ( gHC_PRIM )
-import Packages hiding ( Version(..) )
+import Packages hiding  ( Version(..) )
 import DynFlags
 import DriverPhases
 import BasicTypes
@@ -157,15 +157,15 @@ import Bag
 import ErrUtils
 import Util
 
-import System.FilePath
-import System.Time      ( ClockTime )
-import Data.IORef
+import Control.Monad    ( mplus, guard, liftM, when )
 import Data.Array       ( Array, array )
+import Data.IORef
 import Data.Map         ( Map )
 import Data.Word
-import Control.Monad    ( mplus, guard, liftM, when )
-import Exception
 import Data.Typeable    ( Typeable )
+import Exception
+import System.FilePath
+import System.Time      ( ClockTime )
 
 -- -----------------------------------------------------------------------------
 -- Source Errors
@@ -174,8 +174,13 @@ import Data.Typeable    ( Typeable )
 -- exception in the IO monad.
 
 mkSrcErr :: ErrorMessages -> SourceError
+mkSrcErr = SourceError
+
 srcErrorMessages :: SourceError -> ErrorMessages
+srcErrorMessages (SourceError msgs) = msgs
+
 mkApiErr :: SDoc -> GhcApiError
+mkApiErr = GhcApiError
 
 throwOneError :: MonadIO m => ErrMsg -> m ab
 throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
@@ -201,12 +206,9 @@ newtype SourceError = SourceError ErrorMessages
 
 instance Show SourceError where
   show (SourceError msgs) = unlines . map show . bagToList $ msgs
-    -- ToDo: is there some nicer way to print this?
 
 instance Exception SourceError
 
-mkSrcErr = SourceError
-
 -- | Perform the given action and call the exception handler if the action
 -- throws a 'SourceError'.  See 'SourceError' for more information.
 handleSourceError :: (ExceptionMonad m) =>
@@ -216,19 +218,15 @@ handleSourceError :: (ExceptionMonad m) =>
 handleSourceError handler act =
   gcatch act (\(e :: SourceError) -> handler e)
 
-srcErrorMessages (SourceError msgs) = msgs
-
--- | XXX: what exactly is an API error?
+-- | An error thrown if the GHC API is used in an incorrect fashion.
 newtype GhcApiError = GhcApiError SDoc
- deriving Typeable
+  deriving Typeable
 
 instance Show GhcApiError where
   show (GhcApiError msg) = showSDoc msg
 
 instance Exception GhcApiError
 
-mkApiErr = GhcApiError
-
 -- | Given a bag of warnings, turn them into an exception if
 -- -Werror is enabled, or print them out otherwise.
 printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
@@ -250,7 +248,14 @@ handleFlagWarnings dflags warns
       printOrThrowWarnings dflags bag
 \end{code}
 
+%************************************************************************
+%*                                                                      *
+\subsection{HscEnv}
+%*                                                                      *
+%************************************************************************
+
 \begin{code}
+
 -- | Hscenv is like 'Session', except that some of the fields are immutable.
 -- An HscEnv is used to compile a single module from plain Haskell source
 -- code (after preprocessing) to either C, assembly or C--.  Things like
@@ -280,10 +285,10 @@ data HscEnv
                 -- home-package modules, /excluding/ the module we 
                 -- are compiling right now.
                 -- (In one-shot mode the current module is the only
-                --  home-package module, so hsc_HPT is empty.  All other
-                --  modules count as \"external-package\" modules.
-                --  However, even in GHCi mode, hi-boot interfaces are
-                --  demand-loaded into the external-package table.)
+                -- home-package module, so hsc_HPT is empty.  All other
+                -- modules count as \"external-package\" modules.
+                -- However, even in GHCi mode, hi-boot interfaces are
+                -- demand-loaded into the external-package table.)
                 --
                 -- 'hsc_HPT' is not mutable because we only demand-load 
                 -- external packages; the home package is eagerly 
@@ -292,7 +297,7 @@ data HscEnv
                 -- The HPT may contain modules compiled earlier by @--make@
                 -- but not actually below the current module in the dependency
                 -- graph.
-
+                --      
                 -- (This changes a previous invariant: changed Jan 05.)
         
         hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),
@@ -344,12 +349,13 @@ hscEPS hsc_env = readIORef (hsc_EPS hsc_env)
 -- module.  If so, use this instead of the file contents (this
 -- is for use in an IDE where the file hasn't been saved by
 -- the user yet).
-data Target = Target
-      { targetId           :: TargetId  -- ^ module or filename
-      , targetAllowObjCode :: Bool      -- ^ object code allowed?
-      , targetContents     :: Maybe (StringBuffer,ClockTime)
+data Target
+  = Target {
+      targetId           :: TargetId, -- ^ module or filename
+      targetAllowObjCode :: Bool,     -- ^ object code allowed?
+      targetContents     :: Maybe (StringBuffer,ClockTime)
                                         -- ^ in-memory text buffer?
-      }
+    }
 
 data TargetId
   = TargetModule ModuleName
@@ -363,7 +369,7 @@ data TargetId
 
 pprTarget :: Target -> SDoc
 pprTarget (Target id obj _) = 
-   (if obj then char '*' else empty) <> pprTargetId id
+    (if obj then char '*' else empty) <> pprTargetId id
 
 instance Outputable Target where
     ppr = pprTarget
@@ -374,7 +380,15 @@ pprTargetId (TargetFile f _) = text f
 
 instance Outputable TargetId where
     ppr = pprTargetId
+\end{code}
 
+%************************************************************************
+%*                                                                      *
+\subsection{Package and Module Tables}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
 -- | Helps us find information about modules in the home package
 type HomePackageTable  = ModuleNameEnv HomeModInfo
         -- Domain = modules in the home package that have been fully compiled
@@ -384,9 +398,11 @@ type HomePackageTable  = ModuleNameEnv HomeModInfo
 type PackageIfaceTable = ModuleEnv ModIface
         -- Domain = modules in the imported packages
 
+-- | Constructs an empty HomePackageTable
 emptyHomePackageTable :: HomePackageTable
 emptyHomePackageTable  = emptyUFM
 
+-- | Constructs an empty PackageIfaceTable
 emptyPackageIfaceTable :: PackageIfaceTable
 emptyPackageIfaceTable = emptyModuleEnv
 
@@ -428,10 +444,10 @@ lookupIfaceByModule
         -> Maybe ModIface
 lookupIfaceByModule dflags hpt pit mod
   | modulePackageId mod == thisPackage dflags
-  =     -- The module comes from the home package, so look first
+        -- The module comes from the home package, so look first
         -- in the HPT.  If it's not from the home package it's wrong to look
         -- in the HPT, because the HPT is indexed by *ModuleName* not Module
-    fmap hm_iface (lookupUFM hpt (moduleName mod)) 
+  = fmap hm_iface (lookupUFM hpt (moduleName mod)) 
     `mplus` lookupModuleEnv pit mod
 
   | otherwise = lookupModuleEnv pit mod         -- Look in PIT only 
@@ -442,15 +458,13 @@ lookupIfaceByModule dflags hpt pit mod
 --     module is in the PIT, namely GHC.Prim when compiling the base package.
 -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
 -- of its own, but it doesn't seem worth the bother.
-\end{code}
 
 
-\begin{code}
-hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([Instance], [FamInst])
--- ^ Find all the instance declarations (of classes and families) that are in
+-- | Find all the instance declarations (of classes and families) that are in
 -- modules imported by this one, directly or indirectly, and are in the Home
 -- Package Table.  This ensures that we don't see instances from modules @--make@
 -- compiled before this one, but which are not below this one.
+hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([Instance], [FamInst])
 hptInstances hsc_env want_this_module
   = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do
                 guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))
@@ -458,34 +472,34 @@ hptInstances hsc_env want_this_module
                 return (md_insts details, md_fam_insts details)
     in (concat insts, concat famInsts)
 
-hptVectInfo :: HscEnv -> VectInfo
--- ^ Get the combined VectInfo of all modules in the home package table.  In
+-- | Get the combined VectInfo of all modules in the home package table. In
 -- contrast to instances and rules, we don't care whether the modules are
--- \"below\" us in the dependency sense.  The VectInfo of those modules not \"below\" 
+-- "below" us in the dependency sense. The VectInfo of those modules not "below" 
 -- us does not affect the compilation of the current module.
+hptVectInfo :: HscEnv -> VectInfo
 hptVectInfo = concatVectInfo . hptAllThings ((: []) . md_vect_info . hm_details)
 
+-- | Get rules from modules "below" this one (in the dependency sense)
 hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule]
--- ^ Get rules from modules \"below\" this one (in the dependency sense)
 hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False
 
 
+-- | Get annotations from modules "below" this one (in the dependency sense)
 hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation]
--- ^ Get annotations from modules \"below\" this one (in the dependency sense)
 hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps
 hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env
 
 hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
 hptAllThings extract hsc_env = concatMap extract (eltsUFM (hsc_HPT hsc_env))
 
-hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a]
--- Get things from modules \"below\" this one (in the dependency sense)
+-- | Get things from modules "below" this one (in the dependency sense)
 -- C.f Inst.hptInstances
+hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a]
 hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
- | isOneShot (ghcMode (hsc_dflags hsc_env)) = []
+  | isOneShot (ghcMode (hsc_dflags hsc_env)) = []
+
   | otherwise
-  = let 
-        hpt = hsc_HPT hsc_env
+  = let hpt = hsc_HPT hsc_env
     in
     [ thing
     |   -- Find each non-hi-boot module below me
@@ -493,10 +507,9 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
     , include_hi_boot || not is_boot_mod
 
         -- unsavoury: when compiling the base package with --make, we
-        -- sometimes try to look up RULES etc for GHC.Prim.  GHC.Prim won't
+        -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't
         -- be in the HPT, because we never compile it; it's in the EPT
-        -- instead.  ToDo: clean up, and remove this slightly bogus
-        -- filter:
+        -- instead. ToDo: clean up, and remove this slightly bogus filter:
     , mod /= moduleName gHC_PRIM
 
         -- Look it up in the HPT
@@ -521,23 +534,22 @@ hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt))
 %************************************************************************
 
 \begin{code}
-prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
--- ^ Deal with gathering annotations in from all possible places 
+-- | Deal with gathering annotations in from all possible places 
 --   and combining them into a single 'AnnEnv'
-prepareAnnotations hsc_env mb_guts
-  = do { eps <- hscEPS hsc_env
-       ; let -- Extract annotations from the module being compiled if supplied one
-            mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts
+prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
+prepareAnnotations hsc_env mb_guts = do
+    eps <- hscEPS hsc_env
+    let -- Extract annotations from the module being compiled if supplied one
+        mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts
         -- Extract dependencies of the module if we are supplied one,
         -- otherwise load annotations from all home package table
         -- entries regardless of dependency ordering.
-            home_pkg_anns  = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts
-            other_pkg_anns = eps_ann_env eps
-            ann_env        = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, 
-                                                             Just home_pkg_anns, 
-                                                             Just other_pkg_anns]
-
-       ; return ann_env }
+        home_pkg_anns  = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts
+        other_pkg_anns = eps_ann_env eps
+        ann_env        = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, 
+                                                         Just home_pkg_anns, 
+                                                         Just other_pkg_anns]
+    return ann_env
 \end{code}
 
 %************************************************************************
@@ -548,11 +560,11 @@ prepareAnnotations hsc_env mb_guts
 
 \begin{code}
 -- | The 'FinderCache' maps home module names to the result of
--- searching for that module.  It records the results of searching for
--- modules along the search path.  On @:load@, we flush the entire
+-- searching for that module. It records the results of searching for
+-- modules along the search path. On @:load@, we flush the entire
 -- contents of this cache.
 --
--- Although the @FinderCache@ range is 'FindResult' for convenience ,
+-- Although the @FinderCache@ range is 'FindResult' for convenience,
 -- in fact it will only ever contain 'Found' or 'NotFound' entries.
 --
 type FinderCache = ModuleNameEnv FindResult
@@ -565,8 +577,9 @@ data FindResult
         -- ^ The requested package was not found
   | FoundMultiple [PackageId]
         -- ^ _Error_: both in multiple packages
-
-  | NotFound          -- Not found
+        
+        -- | Not found
+  | NotFound
       { fr_paths       :: [FilePath]       -- Places where I looked
 
       , fr_pkg         :: Maybe PackageId  -- Just p => module is in this package's
@@ -605,14 +618,16 @@ type ModLocationCache = ModuleEnv ModLocation
 -- as when reading we consolidate the declarations etc. into a number of indexed
 -- maps and environments in the 'ExternalPackageState'.
 data ModIface 
-   = ModIface {
-        mi_module   :: !Module,             -- ^ Name of the module we are for
-        mi_iface_hash :: !Fingerprint,      -- ^ Hash of the whole interface
-        mi_mod_hash :: !Fingerprint,        -- ^ Hash of the ABI only
+  = ModIface {
+        mi_module     :: !Module,             -- ^ Name of the module we are for
+        mi_iface_hash :: !Fingerprint,        -- ^ Hash of the whole interface
+        mi_mod_hash   :: !Fingerprint,        -- ^ Hash of the ABI only
+        mi_flag_hash  :: !Fingerprint,        -- ^ Hash of the important flags
+                                              -- used when compiling this module
 
-        mi_orphan   :: !WhetherHasOrphans,  -- ^ Whether this module has orphans
-        mi_finsts   :: !WhetherHasFamInst,  -- ^ Whether this module has family instances
-        mi_boot     :: !IsBootInterface,    -- ^ Read from an hi-boot file?
+        mi_orphan     :: !WhetherHasOrphans,  -- ^ Whether this module has orphans
+        mi_finsts     :: !WhetherHasFamInst,  -- ^ Whether this module has family instances
+        mi_boot       :: !IsBootInterface,    -- ^ Read from an hi-boot file?
 
         mi_deps     :: Dependencies,
                 -- ^ The dependencies of the module.  This is
@@ -623,41 +638,41 @@ data ModIface
                 -- ^ Usages; kept sorted so that it's easy to decide
                 -- whether to write a new iface file (changing usages
                 -- doesn't affect the hash of this module)
-        
                 -- NOT STRICT!  we read this field lazily from the interface file
                 -- It is *only* consulted by the recompilation checker
 
-                -- Exports
-                -- Kept sorted by (mod,occ), to make version comparisons easier
         mi_exports  :: ![IfaceExport],
-                -- ^ Records the modules that are the declaration points for things
+                -- ^ Exports
+                -- Kept sorted by (mod,occ), to make version comparisons easier
+                -- Records the modules that are the declaration points for things
                 -- exported by this module, and the 'OccName's of those things
         
-        mi_exp_hash :: !Fingerprint,    -- ^ Hash of export list
+        mi_exp_hash :: !Fingerprint,
+                -- ^ Hash of export list
 
-        mi_used_th :: !Bool,  -- ^ Module required TH splices when it was compiled.  This disables recompilation avoidance (see #481).
+        mi_used_th  :: !Bool,
+                -- ^ Module required TH splices when it was compiled.
+                -- This disables recompilation avoidance (see #481).
 
         mi_fixities :: [(OccName,Fixity)],
                 -- ^ Fixities
-        
                 -- NOT STRICT!  we read this field lazily from the interface file
 
-        mi_warns  :: Warnings,
+        mi_warns    :: Warnings,
                 -- ^ Warnings
-                
                 -- NOT STRICT!  we read this field lazily from the interface file
 
-        mi_anns  :: [IfaceAnnotation],
+        mi_anns     :: [IfaceAnnotation],
                 -- ^ Annotations
-        
                 -- NOT STRICT!  we read this field lazily from the interface file
 
-                -- Type, class and variable declarations
+
+        mi_decls    :: [(Fingerprint,IfaceDecl)],
+                -- ^ Type, class and variable declarations
                 -- The hash of an Id changes if its fixity or deprecations change
                 --      (as well as its type of course)
                 -- Ditto data constructors, class operations, except that 
                 -- the hash of the parent class/tycon changes
-        mi_decls :: [(Fingerprint,IfaceDecl)],  -- ^ Sorted type, variable, class etc. declarations
 
         mi_globals  :: !(Maybe GlobalRdrEnv),
                 -- ^ Binds all the things defined at the top level in
@@ -675,30 +690,32 @@ data ModIface
                 -- 'HomeModInfo', but that leads to more plumbing.
 
                 -- Instance declarations and rules
-        mi_insts     :: [IfaceInst],                    -- ^ Sorted class instance
-        mi_fam_insts :: [IfaceFamInst],                 -- ^ Sorted family instances
-        mi_rules     :: [IfaceRule],                    -- ^ Sorted rules
-        mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules and 
-                                        -- class and family instances
-                                        -- combined
+        mi_insts       :: [IfaceInst],     -- ^ Sorted class instance
+        mi_fam_insts   :: [IfaceFamInst],  -- ^ Sorted family instances
+        mi_rules       :: [IfaceRule],     -- ^ Sorted rules
+        mi_orphan_hash :: !Fingerprint,    -- ^ Hash for orphan rules and class
+                                           -- and family instances combined
 
-        mi_vect_info :: !IfaceVectInfo, -- ^ Vectorisation information
+        mi_vect_info :: !IfaceVectInfo,    -- ^ Vectorisation information
 
                 -- Cached environments for easy lookup
                 -- These are computed (lazily) from other fields
                 -- and are not put into the interface file
-        mi_warn_fn  :: Name -> Maybe WarningTxt,        -- ^ Cached lookup for 'mi_warns'
-        mi_fix_fn  :: OccName -> Fixity,                -- ^ Cached lookup for 'mi_fixities'
-        mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint),
-                        -- ^ Cached lookup for 'mi_decls'.
-                        -- The @Nothing@ in 'mi_hash_fn' means that the thing
-                        -- isn't in decls. It's useful to know that when
-                        -- seeing if we are up to date wrt. the old interface.
-                        -- The 'OccName' is the parent of the name, if it has one.
-        mi_hpc    :: !AnyHpcUsage,
+        mi_warn_fn   :: Name -> Maybe WarningTxt,        -- ^ Cached lookup for 'mi_warns'
+        mi_fix_fn    :: OccName -> Fixity,                -- ^ Cached lookup for 'mi_fixities'
+        mi_hash_fn   :: OccName -> Maybe (OccName, Fingerprint),
+                -- ^ Cached lookup for 'mi_decls'.
+                -- The @Nothing@ in 'mi_hash_fn' means that the thing
+                -- isn't in decls. It's useful to know that when
+                -- seeing if we are up to date wrt. the old interface.
+                -- The 'OccName' is the parent of the name, if it has one.
+
+        mi_hpc       :: !AnyHpcUsage,
                 -- ^ True if this program uses Hpc at any point in the program.
-        mi_trust  :: !IfaceTrustInfo,
+
+        mi_trust     :: !IfaceTrustInfo,
                 -- ^ Safe Haskell Trust information for this module.
+
         mi_trust_pkg :: !Bool
                 -- ^ Do we require the package this module resides in be trusted
                 -- to trust this module? This is used for the situation where a
@@ -711,11 +728,43 @@ data ModIface
 -- | The original names declared of a certain module that are exported
 type IfaceExport = AvailInfo
 
+-- | Constructs an empty ModIface
+emptyModIface :: Module -> ModIface
+emptyModIface mod
+  = ModIface { mi_module      = mod,
+               mi_iface_hash  = fingerprint0,
+               mi_mod_hash    = fingerprint0,
+               mi_flag_hash   = fingerprint0,
+               mi_orphan      = False,
+               mi_finsts      = False,
+               mi_boot        = False,
+               mi_deps        = noDependencies,
+               mi_usages      = [],
+               mi_exports     = [],
+               mi_exp_hash    = fingerprint0,
+               mi_used_th     = False,
+               mi_fixities    = [],
+               mi_warns       = NoWarnings,
+               mi_anns        = [],
+               mi_insts       = [],
+               mi_fam_insts   = [],
+               mi_rules       = [],
+               mi_decls       = [],
+               mi_globals     = Nothing,
+               mi_orphan_hash = fingerprint0,
+               mi_vect_info   = noIfaceVectInfo,
+               mi_warn_fn     = emptyIfaceWarnCache,
+               mi_fix_fn      = emptyIfaceFixCache,
+               mi_hash_fn     = emptyIfaceHashCache,
+               mi_hpc         = False,
+               mi_trust       = noIfaceTrustInfo,
+               mi_trust_pkg   = False }           
+
 -- | The 'ModDetails' is essentially a cache for information in the 'ModIface'
 -- for home modules only. Information relating to packages will be loaded into
 -- global environments in 'ExternalPackageState'.
 data ModDetails
-   = ModDetails {
+  = ModDetails {
         -- The next two fields are created by the typechecker
         md_exports   :: [AvailInfo],
         md_types     :: !TypeEnv,       -- ^ Local type environment for this particular module
@@ -727,23 +776,21 @@ data ModDetails
         md_vect_info :: !VectInfo       -- ^ Module vectorisation information
      }
 
+-- | Constructs an empty ModDetails
 emptyModDetails :: ModDetails
-emptyModDetails = ModDetails { md_types = emptyTypeEnv,
-                               md_exports = [],
-                               md_insts     = [],
-                               md_rules     = [],
-                               md_fam_insts = [],
-                               md_anns      = [],
-                               md_vect_info = noVectInfo
-                             } 
+emptyModDetails
+  = ModDetails { md_types     = emptyTypeEnv,
+                 md_exports   = [],
+                 md_insts     = [],
+                 md_rules     = [],
+                 md_fam_insts = [],
+                 md_anns      = [],
+                 md_vect_info = noVectInfo } 
 
 -- | Records the modules directly imported by a module for extracting e.g. usage information
 type ImportedMods = ModuleEnv [ImportedModsVal]
 type ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
 
--- TODO: we are not actually using the codomain of this type at all, so it can be
--- replaced with ModuleEnv ()
-
 -- | A ModGuts is carried through the compiler, accumulating stuff as it goes
 -- There is only one ModGuts at any time, the one for the module
 -- being compiled right now.  Once it is compiled, a 'ModIface' and 
@@ -764,9 +811,9 @@ data ModGuts
 
         -- These fields all describe the things **declared in this module**
         mg_fix_env   :: !FixityEnv,      -- ^ Fixities declared in this module
-                                         -- TODO: I'm unconvinced this is actually used anywhere
+                                         -- ToDo: I'm unconvinced this is actually used anywhere
         mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module
-        mg_clss      :: ![Class],        -- ^ Classes declared in this module
+                                         -- (includes TyCons for classes)
         mg_insts     :: ![Instance],     -- ^ Class instances declared in this module
         mg_fam_insts :: ![FamInst],      -- ^ Family instances declared in this module
         mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains 
@@ -792,7 +839,7 @@ data ModGuts
         mg_fam_inst_env :: FamInstEnv,
         -- ^ Type-family instance enviroment for /home-package/ modules
         -- (including this one); c.f. 'tcg_fam_inst_env'
-        mg_trust_pkg :: Bool,
+        mg_trust_pkg    :: Bool,
         -- ^ Do we need to trust our own package for Safe Haskell?
         -- See Note [RnNames . Trust Own Package]
         mg_dependent_files :: [FilePath] -- ^ dependencies from addDependentFile
@@ -814,81 +861,48 @@ data ModGuts
 -- | A restricted form of 'ModGuts' for code generation purposes
 data CgGuts 
   = CgGuts {
-        cg_module   :: !Module, -- ^ Module being compiled
+        cg_module    :: !Module,
+                -- ^ Module being compiled
 
-        cg_tycons   :: [TyCon],
+        cg_tycons    :: [TyCon],
                 -- ^ Algebraic data types (including ones that started
                 -- life as classes); generate constructors and info
                 -- tables. Includes newtypes, just for the benefit of
                 -- External Core
 
-        cg_binds    :: CoreProgram,
+        cg_binds     :: CoreProgram,
                 -- ^ The tidied main bindings, including
                 -- previously-implicit bindings for record and class
                 -- selectors, and data construtor wrappers.  But *not*
                 -- data constructor workers; reason: we we regard them
                 -- as part of the code-gen of tycons
 
-        cg_foreign  :: !ForeignStubs,   -- ^ Foreign export stubs
-        cg_dep_pkgs :: ![PackageId],    -- ^ Dependent packages, used to 
-                                        -- generate #includes for C code gen
-        cg_hpc_info :: !HpcInfo,        -- ^ Program coverage tick box information
-        cg_modBreaks :: !ModBreaks      -- ^ Module breakpoints
+        cg_foreign   :: !ForeignStubs,   -- ^ Foreign export stubs
+        cg_dep_pkgs  :: ![PackageId],    -- ^ Dependent packages, used to 
+                                         -- generate #includes for C code gen
+        cg_hpc_info  :: !HpcInfo,        -- ^ Program coverage tick box information
+        cg_modBreaks :: !ModBreaks       -- ^ Module breakpoints
     }
 
 -----------------------------------
 -- | Foreign export stubs
-data ForeignStubs = NoStubs             -- ^ We don't have any stubs
-                  | ForeignStubs
-                        SDoc            
-                        SDoc            
-                   -- ^ There are some stubs. Parameters:
-                   --
-                   --  1) Header file prototypes for
-                   --     "foreign exported" functions
-                   --
-                   --  2) C stubs to use when calling
-                   --     "foreign exported" functions
+data ForeignStubs
+  = NoStubs
+      -- ^ We don't have any stubs
+  | ForeignStubs SDoc SDoc
+      -- ^ There are some stubs. Parameters:
+      --
+      --  1) Header file prototypes for
+      --     "foreign exported" functions
+      --
+      --  2) C stubs to use when calling
+      --     "foreign exported" functions
 
 appendStubC :: ForeignStubs -> SDoc -> ForeignStubs
 appendStubC NoStubs            c_code = ForeignStubs empty c_code
 appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)
 \end{code}
 
-\begin{code}
-emptyModIface :: Module -> ModIface
-emptyModIface mod
-  = ModIface { mi_module   = mod,
-               mi_iface_hash = fingerprint0,
-               mi_mod_hash = fingerprint0,
-               mi_orphan   = False,
-               mi_finsts   = False,
-               mi_boot     = False,
-               mi_deps     = noDependencies,
-               mi_usages   = [],
-               mi_exports  = [],
-               mi_exp_hash = fingerprint0,
-               mi_used_th  = False,
-               mi_fixities = [],
-               mi_warns    = NoWarnings,
-               mi_anns     = [],
-               mi_insts     = [],
-               mi_fam_insts = [],
-               mi_rules     = [],
-               mi_decls     = [],
-               mi_globals   = Nothing,
-               mi_orphan_hash = fingerprint0,
-               mi_vect_info = noIfaceVectInfo,
-               mi_warn_fn    = emptyIfaceWarnCache,
-               mi_fix_fn    = emptyIfaceFixCache,
-               mi_hash_fn   = emptyIfaceHashCache,
-               mi_hpc       = False,
-               mi_trust     = noIfaceTrustInfo,
-               mi_trust_pkg = False
-    }           
-\end{code}
-
-
 %************************************************************************
 %*                                                                      *
 \subsection{The interactive context}
@@ -898,29 +912,29 @@ emptyModIface mod
 \begin{code}
 -- | Interactive context, recording information about the state of the
 -- context in which statements are executed in a GHC session.
---
 data InteractiveContext 
   = InteractiveContext { 
-         -- This field is only stored here so that the client
-         -- can retrieve it with GHC.getContext.  GHC itself doesn't
-         -- use it, but does reset it to empty sometimes (such
-         -- as before a GHC.load).  The context is set with GHC.setContext.
-         ic_imports :: [InteractiveImport],
+         ic_imports    :: [InteractiveImport],
              -- ^ The GHCi context is extended with these imports
+             --
+             -- This field is only stored here so that the client
+             -- can retrieve it with GHC.getContext. GHC itself doesn't
+             -- use it, but does reset it to empty sometimes (such
+             -- as before a GHC.load). The context is set with GHC.setContext.
 
          ic_rn_gbl_env :: GlobalRdrEnv,
              -- ^ The cached 'GlobalRdrEnv', built by
              -- 'InteractiveEval.setContext' and updated regularly
 
-         ic_tythings :: [TyThing],
+         ic_tythings   :: [TyThing],
              -- ^ TyThings defined by the user, in reverse order of
              -- definition.
 
-         ic_sys_vars  :: [Id],
+         ic_sys_vars   :: [Id],
              -- ^ Variables defined automatically by the system (e.g.
              -- record field selectors).  See Notes [ic_sys_vars]
 
-         ic_instances :: ([Instance], [FamInst]),
+         ic_instances  :: ([Instance], [FamInst]),
              -- ^ All instances and family instances created during
              -- this session.  These are grabbed en masse after each
              -- update to be sure that proper overlapping is retained.
@@ -939,7 +953,7 @@ data InteractiveContext
 
 {-
 Note [ic_sys_vars]
-
+~~~~~~~~~~~~~~~~~~
 This list constains any Ids that arise from TyCons, Classes or
 instances defined interactively, but that are not given by
 'implicitTyThings'.  This includes record selectors, default methods,
@@ -960,16 +974,16 @@ hscDeclsWithLocation) and save them in ic_sys_vars.
 
 -- | Constructs an empty InteractiveContext.
 emptyInteractiveContext :: InteractiveContext
-emptyInteractiveContext = InteractiveContext {
-    ic_imports      = [],
-    ic_rn_gbl_env   = emptyGlobalRdrEnv,
-    ic_tythings     = [],
-    ic_sys_vars     = [],
-    ic_instances    = ([],[]),
+emptyInteractiveContext
+  = InteractiveContext { ic_imports    = [],
+                         ic_rn_gbl_env = emptyGlobalRdrEnv,
+                         ic_tythings   = [],
+                         ic_sys_vars   = [],
+                         ic_instances  = ([],[]),
 #ifdef GHCI
-    ic_resume       = [],
+                         ic_resume     = [],
 #endif
-    ic_cwd          = Nothing }
+                         ic_cwd        = Nothing }
 
 -- | This function returns the list of visible TyThings (useful for
 -- e.g. showBindings)
@@ -987,47 +1001,46 @@ icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } =
 -- whether they are entirely shadowed, but as you could still have references 
 -- to them (e.g. instances for classes or values of the type for TyCons), it's
 -- not clear whether removing them is even the appropriate behavior.
-extendInteractiveContext
-        :: InteractiveContext
-        -> [TyThing]
-        -> InteractiveContext
+extendInteractiveContext :: InteractiveContext -> [TyThing] -> InteractiveContext
 extendInteractiveContext ictxt new_tythings
-  = ictxt { ic_tythings = new_tythings ++ old_tythings
+  = ictxt { ic_tythings   = new_tythings ++ old_tythings
           , ic_rn_gbl_env = new_tythings `icPlusGblRdrEnv` ic_rn_gbl_env ictxt
           }
   where
     old_tythings = filter (not . shadowed) (ic_tythings ictxt)
 
     shadowed (AnId id) = ((`elem` new_names) . nameOccName . idName) id
-    shadowed _ = False
+    shadowed _         = False
 
     new_names = [ nameOccName (getName id) | AnId id <- new_tythings ]
 
-    -- XXX should not add Ids to the gbl env here
+    -- ToDo: should not add Ids to the gbl env here
 
--- | Add TyThings to the GlobalRdrEnv, earlier ones in the list
--- shadowing later ones, and shadowing existing entries in the
--- GlobalRdrEnv.
+-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing
+-- later ones, and shadowing existing entries in the GlobalRdrEnv.
 icPlusGblRdrEnv :: [TyThing] -> GlobalRdrEnv -> GlobalRdrEnv
 icPlusGblRdrEnv tythings env = extendOccEnvList env list
   where new_gres = gresFromAvails LocalDef (map tyThingAvailInfo tythings)
         list = [ (nameOccName (gre_name gre), [gre]) | gre <- new_gres ]
 
 substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
-substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt
+substInteractiveContext ictxt subst
+    | isEmptyTvSubst subst = ictxt
+
 substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst 
-  = ictxt { ic_tythings = map subst_ty tts }
-  where
-   subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id)
-   subst_ty tt = tt
+    = ictxt { ic_tythings = map subst_ty tts }
+  where subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id)
+        subst_ty tt        = tt
 
 data InteractiveImport
-  = IIDecl (ImportDecl RdrName) -- Bring the exports of a particular module
-                                -- (filtered by an import decl) into scope
+  = IIDecl (ImportDecl RdrName)
+      -- ^ Bring the exports of a particular module
+      -- (filtered by an import decl) into scope
 
-  | IIModule Module     -- Bring into scope the entire top-level envt of
-                    -- of this module, including the things imported
-                    -- into it.
+  | IIModule Module
+      -- ^ Bring into scope the entire top-level envt of
+      -- of this module, including the things imported
+      -- into it.
 
 instance Outputable InteractiveImport where
   ppr (IIModule m) = char '*' <> ppr m
@@ -1125,7 +1138,7 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
      where lookup = lookupModuleInAllPackages dflags (moduleName mod)
 
 -- Note [Outputable Orig RdrName]
---
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- This is a Grotesque Hack.  The Outputable instance for RdrEnv wants
 -- to print Orig names, which are just pairs of (Module,OccName).  But
 -- we want to use full Names here, because in GHCi we might have Ids
@@ -1211,9 +1224,6 @@ implicitCoTyCon tc
                               -- Just if family instance, Nothing if not
                               tyConFamilyCoercion_maybe tc] 
 
--- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y)
-
-
 -- | Returns @True@ if there should be no interface-file declaration
 -- for this thing on its own: either it is built-in, or it is part
 -- of some other declaration, or it is generated implicitly by some
@@ -1224,13 +1234,13 @@ isImplicitTyThing (AnId id)     = isImplicitId id
 isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc
 isImplicitTyThing (ACoAxiom {}) = True
 
-tyThingParent_maybe :: TyThing -> Maybe TyThing
--- (tyThingParent_maybe x) returns (Just p)
+-- | tyThingParent_maybe x returns (Just p)
 -- when pprTyThingInContext sould print a declaration for p
 -- (albeit with some "..." in it) when asked to show x
 -- It returns the *immediate* parent.  So a datacon returns its tycon
 -- but the tycon could be the associated type of a class, so it in turn
 -- might have a parent.
+tyThingParent_maybe :: TyThing -> Maybe TyThing
 tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
 tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of
                                       Just cls -> Just (ATyCon (classTyCon cls))
@@ -1307,14 +1317,14 @@ mkTypeEnvWithImplicits things =
     `plusNameEnv`
   mkTypeEnv (concatMap implicitTyThings things)
 
-typeEnvFromEntities :: [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv
-typeEnvFromEntities ids tcs clss faminsts =
+typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+typeEnvFromEntities ids tcs faminsts =
   mkTypeEnv (   map AnId ids
              ++ map ATyCon all_tcs
              ++ concatMap implicitTyConThings all_tcs
             )
  where
-  all_tcs = tcs ++ map classTyCon clss ++ map famInstTyCon faminsts
+  all_tcs = tcs ++ map famInstTyCon faminsts
 
 lookupTypeEnv = lookupNameEnv
 
@@ -1561,7 +1571,7 @@ data Dependencies
                         -- instances are from the home or an external package)
          }
   deriving( Eq )
-        -- Equality used only for old/new comparison in MkIface.addVersionInfo
+        -- Equality used only for old/new comparison in MkIface.addFingerprints
         -- See 'TcRnTypes.ImportAvails' for details on dependencies.
 
 noDependencies :: Dependencies
@@ -2051,7 +2061,7 @@ data Linkable = LM {
     -- If this list is empty, the Linkable represents a fake linkable, which
     -- is generated in HscNothing mode to avoid recompiling modules.
     --
-    -- XXX: Do items get removed from this list when they get linked?
+    -- ToDo: Do items get removed from this list when they get linked?
  }
 
 isObjectLinkable :: Linkable -> Bool
@@ -2143,10 +2153,11 @@ data ModBreaks
         -- ^ An array giving the names of the declarations enclosing each breakpoint.
    }
 
+-- | Construct an empty ModBreaks
 emptyModBreaks :: ModBreaks
 emptyModBreaks = ModBreaks
    { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
-         -- Todo: can we avoid this? 
+         -- ToDo: can we avoid this? 
    , modBreaks_locs  = array (0,-1) []
    , modBreaks_vars  = array (0,-1) []
    , modBreaks_decls = array (0,-1) []
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 9c291e817b..d7dc6bc764 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -724,13 +724,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
 -}
 
   let
-      flags = reverse (packageFlags dflags) ++ dphPackage
-      -- expose the appropriate DPH backend library
-      dphPackage = case dphBackend dflags of
-                     DPHPar  -> [ExposePackage "dph-prim-par", ExposePackage "dph-par"]
-                     DPHSeq  -> [ExposePackage "dph-prim-seq", ExposePackage "dph-seq"]
-                     DPHThis -> []
-                     DPHNone -> []
+      flags = reverse (packageFlags dflags)
 
       -- pkgs0 with duplicate packages filtered out.  This is
       -- important: it is possible for a package in the global package
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index b2a6b5bb67..ef17f3120a 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -129,7 +129,6 @@ mkBootModDetailsTc hsc_env
         TcGblEnv{ tcg_exports   = exports,
                   tcg_type_env  = type_env, -- just for the Ids
                   tcg_tcs       = tcs,
-                  tcg_clss      = clss,
                   tcg_insts     = insts,
                   tcg_fam_insts = fam_insts
                 }
@@ -139,7 +138,7 @@ mkBootModDetailsTc hsc_env
 	; let { insts'     = tidyInstances globaliseAndTidyId insts
 	      ; dfun_ids   = map instanceDFunId insts'
               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
-                                (typeEnvIds type_env) tcs clss fam_insts
+                                (typeEnvIds type_env) tcs fam_insts
 	      ; type_env'  = extendTypeEnvWithIds type_env1 dfun_ids
 	      }
 	; return (ModDetails { md_types     = type_env'
@@ -153,10 +152,10 @@ mkBootModDetailsTc hsc_env
 	}
   where
 
-mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv
-mkBootTypeEnv exports ids tcs clss fam_insts
+mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+mkBootTypeEnv exports ids tcs fam_insts
   = tidyTypeEnv True False exports $
-       typeEnvFromEntities final_ids tcs clss fam_insts
+       typeEnvFromEntities final_ids tcs fam_insts
   where
         -- Find the LocalIds in the type env that are exported
 	-- Make them into GlobalIds, and tidy their types
@@ -294,7 +293,6 @@ tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
 tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_exports   = exports
                               , mg_tcs       = tcs
-                              , mg_clss      = clss
                               , mg_insts     = insts
                               , mg_fam_insts = fam_insts
                               , mg_binds     = binds
@@ -314,7 +312,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               }
         ; showPass dflags CoreTidy
 
-        ; let { type_env = typeEnvFromEntities [] tcs clss fam_insts
+        ; let { type_env = typeEnvFromEntities [] tcs fam_insts
 
               ; implicit_binds
                   = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 9ae312c363..b32dd8a675 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -477,6 +477,7 @@ data Token
   | ITgenerated_prag
   | ITcore_prag                 -- hdaume: core annotations
   | ITunpack_prag
+  | ITnounpack_prag
   | ITann_prag
   | ITclose_prag
   | IToptions_prag String
@@ -523,6 +524,7 @@ data Token
   | ITcomma
   | ITunderscore
   | ITbackquote
+  | ITsimpleQuote               --  '
 
   | ITvarid   FastString        -- identifiers
   | ITconid   FastString
@@ -557,7 +559,6 @@ data Token
   | ITcloseQuote                --  |]
   | ITidEscape   FastString     --  $x
   | ITparenEscape               --  $(
-  | ITvarQuote                  --  '
   | ITtyQuote                   --  ''
   | ITquasiQuote (FastString,FastString,RealSrcSpan) --  [:...|...|]
 
@@ -1228,7 +1229,7 @@ lex_stringgap s = do
 lex_char_tok :: Action
 -- Here we are basically parsing character literals, such as 'x' or '\n'
 -- but, when Template Haskell is on, we additionally spot
--- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
+-- 'x and ''T, returning ITsimpleQuote and ITtyQuote respectively,
 -- but WITHOUT CONSUMING the x or T part  (the parser does that).
 -- So we have to do two characters of lookahead: when we see 'x we need to
 -- see if there's a trailing quote
@@ -1239,11 +1240,8 @@ lex_char_tok span _buf _len = do        -- We've seen '
         Nothing -> lit_error  i1
 
         Just ('\'', i2@(AI end2 _)) -> do       -- We've seen ''
-                  th_exts <- extension thEnabled
-                  if th_exts then do
-                        setInput i2
-                        return (L (mkRealSrcSpan loc end2)  ITtyQuote)
-                   else lit_error i1
+                   setInput i2
+                   return (L (mkRealSrcSpan loc end2)  ITtyQuote)
 
         Just ('\\', i2@(AI _end2 _)) -> do      -- We've seen 'backslash
                   setInput i2
@@ -1266,10 +1264,8 @@ lex_char_tok span _buf _len = do        -- We've seen '
                 _other -> do            -- We've seen 'x not followed by quote
                                         -- (including the possibility of EOF)
                                         -- If TH is on, just parse the quote only
-                        th_exts <- extension thEnabled
                         let (AI end _) = i1
-                        if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote)
-                                   else lit_error i2
+                        return (L (mkRealSrcSpan loc end) ITsimpleQuote)
 
 finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token)
 finish_char_tok loc ch  -- We've already seen the closing quote
@@ -2267,6 +2263,7 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
                            ("generated", token ITgenerated_prag),
                            ("core", token ITcore_prag),
                            ("unpack", token ITunpack_prag),
+                           ("nounpack", token ITnounpack_prag),
                            ("ann", token ITann_prag),
                            ("vectorize", token ITvect_prag),
                            ("novectorize", token ITnovect_prag)])
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 62075e724b..b390009fbf 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -32,7 +32,7 @@ import RdrHsSyn
 import HscTypes         ( IsBootInterface, WarningTxt(..) )
 import Lexer
 import RdrName
-import TysPrim          ( eqPrimTyCon )
+import TysPrim          ( liftedTypeKindTyConName, eqPrimTyCon )
 import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
                           unboxedSingletonTyCon, unboxedSingletonDataCon,
                           listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
@@ -45,8 +45,7 @@ import DataCon          ( DataCon, dataConName )
 import SrcLoc
 import Module
 import StaticFlags      ( opt_SccProfilingOn, opt_Hpc )
-import Type             ( Kind, liftedTypeKind, unliftedTypeKind )
-import Coercion         ( mkArrowKind )
+import Kind             ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
 import Class            ( FunDep )
 import BasicTypes
 import DynFlags
@@ -263,6 +262,7 @@ incorrect.
  '{-# DEPRECATED'         { L _ ITdeprecated_prag }
  '{-# WARNING'            { L _ ITwarning_prag }
  '{-# UNPACK'             { L _ ITunpack_prag }
+ '{-# NOUNPACK'           { L _ ITnounpack_prag }
  '{-# ANN'                { L _ ITann_prag }
  '{-# VECTORISE'          { L _ ITvect_prag }
  '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }
@@ -309,6 +309,7 @@ incorrect.
  ';'            { L _ ITsemi }
  ','            { L _ ITcomma }
  '`'            { L _ ITbackquote }
+ SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x
 
  VARID          { L _ (ITvarid    _) }          -- identifiers
  CONID          { L _ (ITconid    _) }
@@ -348,7 +349,6 @@ incorrect.
 '|]'            { L _ ITcloseQuote    }
 TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x
 '$('            { L _ ITparenEscape   }     -- $( exp )
-TH_VAR_QUOTE    { L _ ITvarQuote      }     -- 'x
 TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T
 TH_QUASIQUOTE   { L _ (ITquasiQuote _) }
 
@@ -717,9 +717,9 @@ data_or_newtype :: { Located NewOrData }
         : 'data'        { L1 DataType }
         | 'newtype'     { L1 NewType }
 
-opt_kind_sig :: { Located (Maybe Kind) }
+opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
         :                               { noLoc Nothing }
-        | '::' kind                     { LL (Just (unLoc $2)) }
+        | '::' kind                     { LL (Just $2) }
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
@@ -967,12 +967,13 @@ sigtypes1 :: { [LHsType RdrName] }      -- Always HsForAllTys
 -- Types
 
 infixtype :: { LHsType RdrName }
-        : btype qtyconop type         { LL $ HsOpTy $1 $2 $3 }
-        | btype tyvarop  type    { LL $ HsOpTy $1 $2 $3 }
+        : btype qtyconop type         { LL $ mkHsOpTy $1 $2 $3 }
+        | btype tyvarop  type    { LL $ mkHsOpTy $1 $2 $3 }
 
 strict_mark :: { Located HsBang }
         : '!'                           { L1 HsStrict }
         | '{-# UNPACK' '#-}' '!'        { LL HsUnpack }
+        | '{-# NOUNPACK' '#-}' '!'      { LL HsNoUnpack }
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
@@ -1018,18 +1019,21 @@ context :: { LHsContext RdrName }
 
 type :: { LHsType RdrName }
         : btype                         { $1 }
-        | btype qtyconop type           { LL $ HsOpTy $1 $2 $3 }
-        | btype tyvarop  type           { LL $ HsOpTy $1 $2 $3 }
+        | btype qtyconop type           { LL $ mkHsOpTy $1 $2 $3 }
+        | btype tyvarop  type           { LL $ mkHsOpTy $1 $2 $3 }
         | btype '->'     ctype          { LL $ HsFunTy $1 $3 }
         | btype '~'      btype          { LL $ HsEqTy $1 $3 }
+                                        -- see Note [Promotion]
+        | btype SIMPLEQUOTE qconop type     { LL $ mkHsOpTy $1 $3 $4 }
+        | btype SIMPLEQUOTE varop  type     { LL $ mkHsOpTy $1 $3 $4 }
 
 typedoc :: { LHsType RdrName }
         : btype                          { $1 }
         | btype docprev                  { LL $ HsDocTy $1 $2 }
-        | btype qtyconop type            { LL $ HsOpTy $1 $2 $3 }
-        | btype qtyconop type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
-        | btype tyvarop  type            { LL $ HsOpTy $1 $2 $3 }
-        | btype tyvarop  type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
+        | btype qtyconop type            { LL $ mkHsOpTy $1 $2 $3 }
+        | btype qtyconop type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
+        | btype tyvarop  type            { LL $ mkHsOpTy $1 $2 $3 }
+        | btype tyvarop  type docprev    { LL $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
         | btype '->'     ctypedoc        { LL $ HsFunTy $1 $3 }
         | btype docprev '->' ctypedoc    { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 }
         | btype '~'      btype           { LL $ HsEqTy $1 $3 }
@@ -1048,11 +1052,17 @@ atype :: { LHsType RdrName }
         | '[' ctype ']'                 { LL $ HsListTy  $2 }
         | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
         | '(' ctype ')'                 { LL $ HsParTy   $2 }
-        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 (unLoc $4) }
+        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 $4 }
         | quasiquote                    { L1 (HsQuasiQuoteTy (unLoc $1)) }
         | '$(' exp ')'                  { LL $ mkHsSpliceTy $2 }
-        | TH_ID_SPLICE                  { LL $ mkHsSpliceTy $ L1 $ HsVar $ 
+        | TH_ID_SPLICE                  { LL $ mkHsSpliceTy $ L1 $ HsVar $
                                           mkUnqual varName (getTH_ID_SPLICE $1) }
+                                                      -- see Note [Promotion] for the followings
+        | SIMPLEQUOTE qconid                          { LL $ HsTyVar $ unLoc $2 }
+        | SIMPLEQUOTE  '(' ')'                        { LL $ HsTyVar $ getRdrName unitDataCon }
+        | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) }
+        | SIMPLEQUOTE  '[' comma_types0 ']'           { LL $ HsExplicitListTy placeHolderKind $3 }
+        | '[' ctype ',' comma_types1 ']'              { LL $ HsExplicitListTy placeHolderKind ($2 : $4) }
 
 -- An inst_type is what occurs in the head of an instance decl
 --      e.g.  (Foo a, Gaz b) => Wibble a b
@@ -1079,8 +1089,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
         : tyvar                         { L1 (UserTyVar (unLoc $1) placeHolderKind) }
-        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) 
-                                                          (unLoc $4)) }
+        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }
@@ -1101,15 +1110,55 @@ varids0 :: { Located [RdrName] }
 -----------------------------------------------------------------------------
 -- Kinds
 
-kind    :: { Located Kind }
-        : akind                 { $1 }
-        | akind '->' kind       { LL (mkArrowKind (unLoc $1) (unLoc $3)) }
+kind :: { LHsKind RdrName }
+        : bkind                  { $1 }
+        | bkind '->' kind        { LL $ HsFunTy $1 $3 }
+
+bkind :: { LHsKind RdrName }
+        : akind                  { $1 }
+        | bkind akind            { LL $ HsAppTy $1 $2 }
+
+akind :: { LHsKind RdrName }
+        : '*'                    { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
+        | '(' kind ')'           { LL $ HsParTy $2 }
+        | pkind                  { $1 }
+
+pkind :: { LHsKind RdrName }  -- promoted type, see Note [Promotion]
+        : qtycon                          { L1 $ HsTyVar $ unLoc $1 }
+        | '(' ')'                         { LL $ HsTyVar $ getRdrName unitTyCon }
+        | '(' kind ',' comma_kinds1 ')'   { LL $ HsTupleTy (HsBoxyTuple placeHolderKind) ($2 : $4) }
+        | '[' kind ']'                    { LL $ HsListTy $2 }
+
+comma_kinds1 :: { [LHsKind RdrName] }
+        : kind                          { [$1] }
+        | kind  ',' comma_kinds1        { $1 : $3 }
+
+{- Note [Promotion]
+   ~~~~~~~~~~~~~~~~
+
+- Syntax of promoted qualified names
+We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified
+names. Moreover ticks are only allowed in types, not in kinds, for a
+few reasons:
+  1. we don't need quotes since we cannot define names in kinds
+  2. if one day we merge types and kinds, tick would mean look in DataName
+  3. we don't have a kind namespace anyway
+
+- Syntax of explicit kind polymorphism  (IA0_TODO: not yet implemented)
+Kind abstraction is implicit. We write
+> data SList (s :: k -> *) (as :: [k]) where ...
+because it looks like what we do in terms
+> id (x :: a) = x
+
+- Name resolution
+When the user write Zero instead of 'Zero in types, we parse it a
+HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We
+deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not
+bounded in the type level, then we look for it in the term level (we
+change its namespace to DataName, see Note [Demotion] in OccName). And
+both become a HsTyVar ("Zero", DataName) after the renamer.
 
-akind   :: { Located Kind }
-        : '*'                   { L1 liftedTypeKind }
-        | '!'                   { L1 unliftedTypeKind }
-        | CONID                 {% checkKindName (L1 (getCONID $1)) }
-        | '(' kind ')'          { LL (unLoc $2) }
+-}
 
 
 -----------------------------------------------------------------------------
@@ -1409,10 +1458,10 @@ aexp2   :: { LHsExpr RdrName }
         | '$(' exp ')'          { LL $ HsSpliceE (mkHsSplice $2) }               
 
 
-        | TH_VAR_QUOTE qvar     { LL $ HsBracket (VarBr (unLoc $2)) }
-        | TH_VAR_QUOTE qcon     { LL $ HsBracket (VarBr (unLoc $2)) }
-        | TH_TY_QUOTE tyvar     { LL $ HsBracket (VarBr (unLoc $2)) }
-        | TH_TY_QUOTE gtycon    { LL $ HsBracket (VarBr (unLoc $2)) }
+        | SIMPLEQUOTE  qvar     { LL $ HsBracket (VarBr True  (unLoc $2)) }
+        | SIMPLEQUOTE  qcon     { LL $ HsBracket (VarBr True  (unLoc $2)) }
+        | TH_TY_QUOTE tyvar     { LL $ HsBracket (VarBr False (unLoc $2)) }
+        | TH_TY_QUOTE gtycon    { LL $ HsBracket (VarBr False (unLoc $2)) }
         | '[|' exp '|]'         { LL $ HsBracket (ExpBr $2) }                       
         | '[t|' ctype '|]'      { LL $ HsBracket (TypBr $2) }                       
         | '[p|' infixexp '|]'   {% checkPattern $2 >>= \p ->
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 99efa7a4ae..3a786ea04b 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -20,7 +20,7 @@ import Type ( Kind,
               liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
               argTypeKindTyCon, ubxTupleKindTyCon, mkTyConApp
             )
-import Coercion( mkArrowKind )
+import Kind( mkArrowKind )
 import Name( Name, nameOccName, nameModule, mkExternalName, wiredInNameTyThing_maybe )
 import Module
 import ParserCoreUtils
@@ -346,7 +346,7 @@ eqTc (IfaceTc name) tycon = name == tyConName tycon
 -- Tiresomely, we have to generate both HsTypes (in type/class decls) 
 -- and IfaceTypes (in Core expressions).  So we parse them as IfaceTypes,
 -- and convert to HsTypes here.  But the IfaceTypes we can see here
--- are very limited (see the productions for 'ty', so the translation
+-- are very limited (see the productions for 'ty'), so the translation
 -- isn't hard
 toHsType :: IfaceType -> LHsType RdrName
 toHsType (IfaceTyVar v)        		 = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS v))
@@ -355,12 +355,12 @@ toHsType (IfaceFunTy t1 t2)    		 = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) 
 toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)
 
--- We also need to convert IfaceKinds to Kinds (now that they are different).
 -- Only a limited form of kind will be encountered... hopefully
-toKind :: IfaceKind -> Kind
-toKind (IfaceFunTy ifK1 ifK2)  = mkArrowKind (toKind ifK1) (toKind ifK2)
-toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
-toKind other                   = pprPanic "toKind" (ppr other)
+toHsKind :: IfaceKind -> LHsKind RdrName
+-- IA0_NOTE: Shouldn't we add kind variables?
+toHsKind (IfaceFunTy ifK1 ifK2)  = noLoc $ HsFunTy (toHsKind ifK1) (toHsKind ifK2)
+toHsKind (IfaceTyConApp ifKc []) = noLoc $ HsTyVar (nameRdrName (tyConName (toKindTc ifKc)))
+toHsKind other                   = pprPanic "toHsKind" (ppr other)
 
 toKindTc :: IfaceTyCon -> TyCon
 toKindTc (IfaceTc n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n = tc
@@ -375,7 +375,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toKind k)
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind
 
 ifaceExtRdrName :: Name -> RdrName
 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 20055e3b7d..8ab71f3885 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -42,7 +42,6 @@ module RdrHsSyn (
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkDoAndIfThenElse,
-        checkKindName,
         checkRecordSyntax,
         parseError,
         parseErrorSDoc,
@@ -50,16 +49,13 @@ module RdrHsSyn (
 
 import HsSyn            -- Lots of it
 import Class            ( FunDep )
-import TypeRep          ( Kind )
-import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
+import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
-import OccName          ( occNameFS )
-import Name             ( Name, nameOccName )
+import Name             ( Name )
 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
                           InlinePragma(..), InlineSpec(..) )
 import Lexer
 import TysWiredIn       ( unitTyCon )
-import TysPrim          ( constraintKindTyConName, constraintKind )
 import ForeignCall
 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
                           occNameString )
@@ -110,6 +106,8 @@ extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt)
 extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
 extract_ltys tys acc = foldr extract_lty acc tys
 
+-- IA0_NOTE: Should this function also return kind variables?
+-- (explicit kind poly)
 extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
 extract_lty (L loc ty) acc
   = case ty of
@@ -123,7 +121,7 @@ extract_lty (L loc ty) acc
       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
       HsIParamTy _ ty           -> extract_lty ty acc
       HsEqTy ty1 ty2            -> extract_lty ty1 (extract_lty ty2 acc)
-      HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
+      HsOpTy ty1 (_, (L loc tv)) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
       HsParTy ty                -> extract_lty ty acc
       HsCoreTy {}               -> acc  -- The type is closed
       HsQuasiQuoteTy {}         -> acc  -- Quasi quotes mention no type variables
@@ -135,6 +133,9 @@ extract_lty (L loc ty) acc
                                 where
                                    locals = hsLTyVarNames tvs
       HsDocTy ty _              -> extract_lty ty acc
+      HsExplicitListTy _ tys    -> extract_ltys tys acc
+      HsExplicitTupleTy _ tys   -> extract_ltys tys acc
+      HsWrapTy _ _              -> panic "extract_lty"
 
 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
@@ -191,7 +192,7 @@ mkTyData :: SrcSpan
          -> NewOrData
          -> Bool                -- True <=> data family instance
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-         -> Maybe Kind
+         -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
@@ -219,7 +220,7 @@ mkTySynonym loc is_family lhs rhs
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
            -> LHsType RdrName   -- LHS
-           -> Maybe Kind        -- Optional kind signature
+           -> Maybe (LHsKind RdrName) -- Optional kind signature
            -> P (LTyClDecl RdrName)
 mkTyFamily loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
@@ -493,7 +494,7 @@ checkTyVars tycl_hdr tparms = mapM chk tparms
   where
         -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
+        | isRdrTyVar tv    = return (L l (KindedTyVar tv k placeHolderKind))
     chk (L l (HsTyVar tv))
         | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
     chk t@(L l _)
@@ -532,10 +533,10 @@ checkTyClHdr ty
   where
     goL (L l ty) acc = go l ty acc
 
-    go l (HsTyVar tc) acc
+    go l (HsTyVar tc) acc 
         | isRdrTc tc         = return (L l tc, acc)
-
-    go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
+                                     
+    go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc
         | isRdrTc tc         = return (ltc, t1:t2:acc)
     go _ (HsParTy ty)    acc = goL ty acc
     go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
@@ -776,17 +777,6 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
           expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
                  text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
                  text "else" <+> ppr elseExpr
-
-checkKindName :: Located FastString -> P (Located Kind)
-checkKindName (L l fs) = do
-    pState <- getPState
-    let ext_enabled = xopt Opt_ConstraintKinds (dflags pState)
-        is_kosher = fs == occNameFS (nameOccName constraintKindTyConName)
-    if not ext_enabled || not is_kosher
-     then parseErrorSDoc l (text "Unexpected named kind:"
-                         $$ nest 4 (ppr fs)
-                         $$ if (not ext_enabled && is_kosher) then text "Perhaps you meant to use -XConstraintKinds?" else empty)
-     else return (L l constraintKind)
 \end{code}
 
 
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 7eacbd5388..cd6a621868 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -156,7 +156,6 @@ basicKnownKeyNames :: [Name]
 basicKnownKeyNames
  = genericTyConNames
  ++ typeableClassNames
- ++ dphKnownKeyNames dphSeqPackageId ++ dphKnownKeyNames dphParPackageId
  ++ [   -- Type constructors (synonyms especially)
         ioTyConName, ioDataConName,
         runMainIOName,
@@ -306,20 +305,6 @@ genericTyConNames = [
     d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
     repTyConName, rep1TyConName
   ]
-
--- Know names from the DPH package which vary depending on the selected DPH backend.
---
-dphKnownKeyNames :: PackageId -> [Name]
-dphKnownKeyNames dphPkg
-  = map ($ dphPkg)
-    [
-        -- Parallel array operations
-          nullPName, lengthPName, replicatePName,       singletonPName, mapPName,
-          filterPName, zipPName, crossMapPName, indexPName,
-          toPName, emptyPName, appPName,
-        enumFromToPName, enumFromThenToPName
-
-    ]
 \end{code}
 
 
@@ -399,12 +384,6 @@ rANDOM          = mkBaseModule (fsLit "System.Random")
 gHC_EXTS        = mkBaseModule (fsLit "GHC.Exts")
 cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
 
-dATA_ARRAY_PARALLEL_PRIM :: PackageId -> Module
-dATA_ARRAY_PARALLEL_PRIM pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel.Prim"))
-
-gHC_PARR :: PackageId -> Module
-gHC_PARR pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel"))
-
 gHC_PARR' :: Module
 gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
 
@@ -423,6 +402,10 @@ pRELUDE_NAME, mAIN_NAME :: ModuleName
 pRELUDE_NAME   = mkModuleNameFS (fsLit "Prelude")
 mAIN_NAME      = mkModuleNameFS (fsLit "Main")
 
+dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName
+dATA_ARRAY_PARALLEL_NAME      = mkModuleNameFS (fsLit "Data.Array.Parallel")
+dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim")
+
 mkPrimModule :: FastString -> Module
 mkPrimModule m = mkModule primPackageId (mkModuleNameFS m)
 
@@ -964,26 +947,6 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
 constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
 selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
 
--- parallel array types and functions
-enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
-    singletonPName, replicatePName, mapPName, filterPName,
-    zipPName, crossMapPName, indexPName, toPName,
-    emptyPName, appPName :: PackageId -> Name
-enumFromToPName     pkg = varQual (gHC_PARR pkg) (fsLit "enumFromToP")     enumFromToPIdKey
-enumFromThenToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromThenToP") enumFromThenToPIdKey
-nullPName           pkg = varQual (gHC_PARR pkg) (fsLit "nullP")           nullPIdKey
-lengthPName         pkg = varQual (gHC_PARR pkg) (fsLit "lengthP")         lengthPIdKey
-singletonPName      pkg = varQual (gHC_PARR pkg) (fsLit "singletonP")      singletonPIdKey
-replicatePName      pkg = varQual (gHC_PARR pkg) (fsLit "replicateP")      replicatePIdKey
-mapPName            pkg = varQual (gHC_PARR pkg) (fsLit "mapP")            mapPIdKey
-filterPName         pkg = varQual (gHC_PARR pkg) (fsLit "filterP")         filterPIdKey
-zipPName            pkg = varQual (gHC_PARR pkg) (fsLit "zipP")            zipPIdKey
-crossMapPName       pkg = varQual (gHC_PARR pkg) (fsLit "crossMapP")       crossMapPIdKey
-indexPName          pkg = varQual (gHC_PARR pkg) (fsLit "!:")              indexPIdKey
-toPName             pkg = varQual (gHC_PARR pkg) (fsLit "toP")             toPIdKey
-emptyPName          pkg = varQual (gHC_PARR pkg) (fsLit "emptyP")          emptyPIdKey
-appPName            pkg = varQual (gHC_PARR pkg) (fsLit "+:+")             appPIdKey
-
 -- IO things
 ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
     failIOName :: Name
@@ -1278,11 +1241,13 @@ eitherTyConKey                          = mkPreludeTyConUnique 84
 
 -- Super Kinds constructors
 tySuperKindTyConKey :: Unique
-tySuperKindTyConKey                    = mkPreludeTyConUnique 85
+tySuperKindTyConKey                     = mkPreludeTyConUnique 85
 
 -- Kind constructors
-liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey,
-    ubxTupleKindTyConKey, argTypeKindTyConKey, constraintKindTyConKey :: Unique
+liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey,
+  unliftedTypeKindTyConKey, ubxTupleKindTyConKey, argTypeKindTyConKey,
+  constraintKindTyConKey :: Unique
+anyKindTyConKey                         = mkPreludeTyConUnique 86
 liftedTypeKindTyConKey                  = mkPreludeTyConUnique 87
 openTypeKindTyConKey                    = mkPreludeTyConUnique 88
 unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89
@@ -1539,25 +1504,6 @@ dollarIdKey           = mkPreludeMiscIdUnique 123
 coercionTokenIdKey :: Unique
 coercionTokenIdKey    = mkPreludeMiscIdUnique 124
 
--- Parallel array functions
-singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey,
-    filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey,
-    enumFromToPIdKey, enumFromThenToPIdKey, emptyPIdKey, appPIdKey :: Unique
-singletonPIdKey               = mkPreludeMiscIdUnique 130
-nullPIdKey                    = mkPreludeMiscIdUnique 131
-lengthPIdKey                  = mkPreludeMiscIdUnique 132
-replicatePIdKey               = mkPreludeMiscIdUnique 133
-mapPIdKey                     = mkPreludeMiscIdUnique 134
-filterPIdKey                  = mkPreludeMiscIdUnique 135
-zipPIdKey                     = mkPreludeMiscIdUnique 136
-crossMapPIdKey                = mkPreludeMiscIdUnique 137
-indexPIdKey                   = mkPreludeMiscIdUnique 138
-toPIdKey                      = mkPreludeMiscIdUnique 139
-enumFromToPIdKey              = mkPreludeMiscIdUnique 140
-enumFromThenToPIdKey          = mkPreludeMiscIdUnique 141
-emptyPIdKey                   = mkPreludeMiscIdUnique 142
-appPIdKey                     = mkPreludeMiscIdUnique 143
-
 -- dotnet interop
 unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey,
     unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique
@@ -1647,6 +1593,24 @@ mzipIdKey       = mkPreludeMiscIdUnique 197
 
 %************************************************************************
 %*                                                                      *
+\subsection{Standard groups of types}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+kindKeys :: [Unique]
+kindKeys = [ anyKindTyConKey
+           , liftedTypeKindTyConKey
+           , openTypeKindTyConKey
+           , unliftedTypeKindTyConKey
+           , ubxTupleKindTyConKey
+           , argTypeKindTyConKey
+           , constraintKindTyConKey ]
+\end{code}
+
+
+%************************************************************************
+%*                                                                      *
 \subsection[Class-std-groups]{Standard groups of Prelude classes}
 %*                                                                      *
 %************************************************************************
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 202d48e018..5cb07a14da 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -21,20 +21,21 @@ module TysPrim(
         tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
 	alphaTy, betaTy, gammaTy, deltaTy,
 	openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
-        argAlphaTyVars, argAlphaTyVar, argAlphaTy, argBetaTy, argBetaTyVar,
+        argAlphaTy, argAlphaTyVar, argAlphaTyVars, argBetaTy, argBetaTyVar,
+        kKiVar,
 
         -- Kind constructors...
-        tySuperKindTyCon, tySuperKind,
+        tySuperKindTyCon, tySuperKind, anyKindTyCon,
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
         argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon,
 
-        tySuperKindTyConName, liftedTypeKindTyConName,
+        tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
         openTypeKindTyConName, unliftedTypeKindTyConName,
         ubxTupleKindTyConName, argTypeKindTyConName,
         constraintKindTyConName,
 
         -- Kinds
-	liftedTypeKind, unliftedTypeKind, openTypeKind,
+	anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind, constraintKind,
         mkArrowKind, mkArrowKinds,
 
@@ -74,21 +75,20 @@ module TysPrim(
         eqPrimTyCon,            -- ty1 ~# ty2
 
 	-- * Any
-	anyTy, anyTyCon, anyTyConOfKind, anyTypeOfKind
+	anyTy, anyTyCon, anyTypeOfKind
   ) where
 
 #include "HsVersions.h"
 
-import Var		( TyVar, mkTyVar )
+import Var		( TyVar, KindVar, mkTyVar )
 import Name		( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
-import OccName          ( mkTcOcc,mkTyVarOccFS, mkTcOccFS )
+import OccName          ( mkTyVarOccFS, mkTcOccFS )
 import TyCon
 import TypeRep
 import SrcLoc
 import Unique		( mkAlphaTyVarUnique )
 import PrelNames
 import FastString
-import Outputable
 
 import Data.Char
 \end{code}
@@ -127,6 +127,7 @@ primTyCons
     , word32PrimTyCon
     , word64PrimTyCon
     , anyTyCon
+    , anyKindTyCon
     , eqPrimTyCon
 
     , liftedTypeKindTyCon
@@ -223,6 +224,10 @@ argAlphaTyVars@(argAlphaTyVar : argBetaTyVar : _) = tyVarList argTypeKind
 argAlphaTy, argBetaTy :: Type
 argAlphaTy = mkTyVarTy argAlphaTyVar
 argBetaTy  = mkTyVarTy argBetaTyVar
+
+kKiVar :: KindVar
+kKiVar = (tyVarList tySuperKind) !! 10
+
 \end{code}
 
 
@@ -239,9 +244,6 @@ funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
 funTyCon :: TyCon
 funTyCon = mkFunTyCon funTyConName $ 
            mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
--- DV: used to be (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
---     but I am modifying this in-flight for the GHC kinds merge
-
         -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
 	-- But if we do that we get kind errors when saying
 	--	instance Control.Arrow (->)
@@ -250,6 +252,20 @@ funTyCon = mkFunTyCon funTyConName $
 	-- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
 	-- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
         -- because they are never in scope in the source
+
+-- One step to remove subkinding.
+-- (->) :: * -> * -> *
+-- but we should have (and want) the following typing rule for fully applied arrows
+--      Gamma |- tau   :: k1    k1 in {*, #}
+--      Gamma |- sigma :: k2    k2 in {*, #, (#)}
+--      -----------------------------------------
+--      Gamma |- tau -> sigma :: *
+-- Currently we have the following rule which achieves more or less the same effect
+--      Gamma |- tau   :: ??
+--      Gamma |- sigma :: ?
+--      --------------------------
+--      Gamma |- tau -> sigma :: *
+-- In the end we don't want subkinding at all.
 \end{code}
 
 
@@ -261,18 +277,19 @@ funTyCon = mkFunTyCon funTyConName $
 
 \begin{code}
 -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
-tySuperKindTyCon, liftedTypeKindTyCon,
+tySuperKindTyCon, anyKindTyCon, liftedTypeKindTyCon,
       openTypeKindTyCon, unliftedTypeKindTyCon,
       ubxTupleKindTyCon, argTypeKindTyCon,
       constraintKindTyCon
    :: TyCon
-tySuperKindTyConName, liftedTypeKindTyConName,
+tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
       openTypeKindTyConName, unliftedTypeKindTyConName,
       ubxTupleKindTyConName, argTypeKindTyConName,
       constraintKindTyConName
    :: Name
 
 tySuperKindTyCon      = mkSuperKindTyCon tySuperKindTyConName
+anyKindTyCon          = mkKindTyCon anyKindTyConName          tySuperKind
 liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName   tySuperKind
 openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName     tySuperKind
 unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
@@ -284,6 +301,7 @@ constraintKindTyCon   = mkKindTyCon constraintKindTyConName   tySuperKind
 -- ... and now their names
 
 tySuperKindTyConName      = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
+anyKindTyConName      = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon
 liftedTypeKindTyConName   = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
 openTypeKindTyConName     = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
 unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
@@ -306,13 +324,15 @@ kindTyConType :: TyCon -> Type
 kindTyConType kind = TyConApp kind []
 
 -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind
+anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind
 
+-- See Note [Any kinds]
+anyKind          = kindTyConType anyKindTyCon
 liftedTypeKind   = kindTyConType liftedTypeKindTyCon
 unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
 openTypeKind     = kindTyConType openTypeKindTyCon
 argTypeKind      = kindTyConType argTypeKindTyCon
-ubxTupleKind	 = kindTyConType ubxTupleKindTyCon
+ubxTupleKind     = kindTyConType ubxTupleKindTyCon
 constraintKind   = kindTyConType constraintKindTyCon
 
 -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
@@ -410,15 +430,13 @@ Note [The ~# TyCon)
 ~~~~~~~~~~~~~~~~~~~~
 There is a perfectly ordinary type constructor ~# that represents the type
 of coercions (which, remember, are values).  For example
-   Refl Int :: ~# Int Int
+   Refl Int :: ~# * Int Int
 
-Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic:
-   Refl Maybe :: ~# Maybe Maybe
+It is a kind-polymorphic type constructor like Any:
+   Refl Maybe :: ~# (* -> *) Maybe Maybe
 
-So the true kind of ~# :: forall k. k -> k -> #.  But we don't have
-polymorphic kinds (yet). However, (~) really only appears saturated in
-which case there is no problem in finding the kind of (ty1 ~# ty2). So
-we check that in CoreLint (and, in an assertion, in Kind.typeKind).
+(~) only appears saturated. So we check that in CoreLint (and, in an
+assertion, in Kind.typeKind).
 
 Note [The State# TyCon]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -440,7 +458,10 @@ statePrimTyCon	 = pcPrimTyCon statePrimTyConName 1 VoidRep
 
 eqPrimTyCon :: TyCon  -- The representation type for equality predicates
 		      -- See Note [The ~# TyCon]
-eqPrimTyCon  = pcPrimTyCon eqPrimTyConName 2 VoidRep
+eqPrimTyCon  = mkPrimTyCon eqPrimTyConName kind 3 VoidRep
+  where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind
+        kv = kKiVar
+        k = mkTyVarTy kv
 \end{code}
 
 RealWorld is deeply magical.  It is *primitive*, but it is not
@@ -610,7 +631,7 @@ threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep
 
 Note [Any types]
 ~~~~~~~~~~~~~~~~
-The type constructor Any::* has these properties
+The type constructor Any of kind forall k. k -> k has these properties:
 
   * It is defined in module GHC.Prim, and exported so that it is 
     available to users.  For this reason it's treated like any other 
@@ -633,31 +654,18 @@ The type constructor Any::* has these properties
     For example   	length Any []
     See Note [Strangely-kinded void TyCons]
 
-In addition, we have a potentially-infinite family of types, one for
-each kind /other than/ *, needed to instantiate otherwise
-un-constrained type variables of kinds other than *.  This is a bit
-like tuples; there is a potentially-infinite family.  They have slightly
-different characteristics to Any::*:
-  
-  * They are built with TyCon.AnyTyCon
-  * They have non-user-writable names like "Any(*->*)" 
-  * They are not exported by GHC.Prim
-  * They are uninhabited (of course; not kind *)
-  * They have a unique derived from their OccName (see Note [Uniques of Any])
-  * Their Names do not live in the global name cache
-
-Note [Uniques of Any]
-~~~~~~~~~~~~~~~~~~~~~
-Although Any(*->*), say, doesn't have a binding site, it still needs
-to have a Unique.  Unlike tuples (which are also an infinite family)
-there is no convenient way to index them, so we use the Unique from
-their OccName instead.  That should be unique, 
-  - both wrt each other, because their strings differ
-
-  - and wrt any other Name, because Names get uniques with 
-    various 'char' tags, but the OccName of Any will 
-    get a Unique built with mkTcOccUnique, which has a particular 'char' 
-    tag; see Unique.mkTcOccUnique!
+Note [Any kinds]
+~~~~~~~~~~~~~~~~
+
+The type constructor AnyK (of sort BOX) is used internally only to zonk kind
+variables with no constraints on them. It appears in similar circumstances to
+Any, but at the kind level. For example:
+
+  type family Length (l :: [k]) :: Nat
+  type instance Length [] = Zero
+
+Length is kind-polymorphic, and when applied to the empty (promoted) list it
+will be supplied the kind AnyL: Length AnyK [].
 
 Note [Strangely-kinded void TyCons]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -687,25 +695,9 @@ anyTy :: Type
 anyTy = mkTyConTy anyTyCon
 
 anyTyCon :: TyCon
-anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
+anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep
+  where kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
 
 anyTypeOfKind :: Kind -> Type
-anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []
-
-anyTyConOfKind :: Kind -> TyCon
--- Map all superkinds of liftedTypeKind to liftedTypeKind
-anyTyConOfKind kind 
-  | isLiftedTypeKind kind = anyTyCon
-  | otherwise             = tycon
-  where
-	  -- Derive the name from the kind, thus:
-	  --     Any(*->*), Any(*->*->*)
-	  -- These are names that can't be written by the user,
-	  -- and are not allocated in the global name cache
-    str = "Any" ++ showSDoc (pprParendKind kind)
-
-    occ   = mkTcOcc str
-    uniq  = getUnique occ  -- See Note [Uniques of Any]
-    name  = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax
-    tycon = mkAnyTyCon name kind 
+anyTypeOfKind kind = mkTyConApp anyTyCon [kind]
 \end{code}
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 54acefc087..c6991e1591 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -420,16 +420,25 @@ mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip
 \begin{code}
 eqTyCon :: TyCon
 eqTyCon = mkAlgTyCon eqTyConName
-            (mkArrowKinds [openTypeKind, openTypeKind] constraintKind)
-            [alphaTyVar, betaTyVar]
+            (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
+            [kv, a, b]
             []      -- No stupid theta
             (DataTyCon [eqBoxDataCon] False)
             NoParentTyCon
             NonRecursive
             False
-    
+  where
+    kv = kKiVar
+    k = mkTyVarTy kv
+    a:b:_ = tyVarList k
+
 eqBoxDataCon :: DataCon
-eqBoxDataCon = pcDataCon eqBoxDataConName [alphaTyVar, betaTyVar] [TyConApp eqPrimTyCon [mkTyVarTy alphaTyVar, mkTyVarTy betaTyVar]] eqTyCon
+eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVarTy args)] eqTyCon
+  where
+    kv = kKiVar
+    k = mkTyVarTy kv
+    a:b:_ = tyVarList k
+    args = [kv, a, b]
 \end{code}
 
 \begin{code}
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 5d53713225..fa3a287432 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -1762,13 +1762,13 @@ primtype BCO#
    {Primitive bytecode type.}
 
 primop   AddrToAnyOp "addrToAny#" GenPrimOp
-   Addr# -> (# Any #)
+   Addr# -> (# a #)
    {Convert an {\tt Addr\#} to a followable Any type.}
    with
    code_size = 0
 
 primop   MkApUpd0_Op "mkApUpd0#" GenPrimOp
-   BCO# -> (# Any #)
+   BCO# -> (# a #)
    with
    out_of_line = True
 
@@ -1849,7 +1849,7 @@ pseudoop   "lazy"
 
 	Like {\tt seq}, the argument of {\tt lazy} can have an unboxed type. }
 
-primtype Any
+primtype Any a
 	{ The type constructor {\tt Any} is type to which you can unsafely coerce any
 	lifted type, and back. 
 
@@ -1880,6 +1880,9 @@ primtype Any
 	into interface files, we'll get a crash; at least until we add interface-file
 	syntax to support them. }
 
+primtype AnyK
+	{ JPM Todo }
+
 pseudoop   "unsafeCoerce#"
    a -> b
    { The function {\tt unsafeCoerce\#} allows you to side-step the typechecker entirely. That
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index faecd40b53..51cd09fb07 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -696,7 +696,7 @@ renameSig ctxt sig@(GenericSig vs ty)
 	; return (GenericSig new_v new_ty) }
 
 renameSig _ (SpecInstSig ty)
-  = do	{ new_ty <- rnLHsType (text "In a SPECIALISE instance pragma") ty
+  = do	{ new_ty <- rnLHsType SpecInstSigCtx ty
 	; return (SpecInstSig new_ty) }
 
 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index c6ab6bb592..c919e46972 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -14,7 +14,7 @@
 module RnEnv ( 
 	newTopSrcBinder, 
 	lookupLocatedTopBndrRn, lookupTopBndrRn,
-	lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe,
+	lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, lookupPromotedOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
 
 	HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
@@ -32,14 +32,16 @@ module RnEnv (
 	addLocalFixities,
 	bindLocatedLocalsFV, bindLocatedLocalsRn,
 	bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
-	bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
+	extendTyVarEnvFVRn,
 
 	checkDupRdrNames, checkDupAndShadowedRdrNames,
         checkDupNames, checkDupAndShadowedNames, 
 	addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
 	warnUnusedMatches,
 	warnUnusedTopBinds, warnUnusedLocalBinds,
-	dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
+	dataTcOccs, unknownNameErr, kindSigErr, polyKindsErr, perhapsForallMsg,
+
+        HsDocContext(..), docOfHsDocContext
     ) where
 
 #include "HsVersions.h"
@@ -444,31 +446,61 @@ lookupLocalOccRn_maybe rdr_name
        ; return (lookupLocalRdrEnv local_env rdr_name) }
 
 -- lookupOccRn looks up an occurrence of a RdrName
+lookupOccRn :: RdrName -> RnM Name
+lookupOccRn rdr_name = do
+  opt_name <- lookupOccRn_maybe rdr_name
+  maybe (unboundName WL_Any rdr_name) return opt_name
+
+-- lookupPromotedOccRn looks up an optionally promoted RdrName.
+lookupPromotedOccRn :: RdrName -> RnM Name
+-- see Note [Demotion] in OccName
+lookupPromotedOccRn rdr_name = do {
+    -- 1. lookup the name
+    opt_name <- lookupOccRn_maybe rdr_name 
+  ; case opt_name of
+      -- 1.a. we found it!
+      Just name -> return name
+      -- 1.b. we did not find it -> 2
+      Nothing -> do {
+  ; -- 2. maybe it was implicitly promoted
+    case demoteRdrName rdr_name of
+      -- 2.a it was not in a promoted namespace
+      Nothing -> err
+      -- 2.b let's try every thing again -> 3
+      Just demoted_rdr_name -> do {
+  ; poly_kinds <- xoptM Opt_PolyKinds
+    -- 3. lookup again
+  ; opt_demoted_name <- lookupOccRn_maybe demoted_rdr_name ;
+  ; case opt_demoted_name of
+      -- 3.a. it was implicitly promoted, but confirm that we can promote
+      -- JPM: We could try to suggest turning on PolyKinds here
+      Just demoted_name -> if poly_kinds then return demoted_name else err
+      -- 3.b. use rdr_name to have a correct error message
+      Nothing -> err } } }
+  where err = unboundName WL_Any rdr_name
+
+-- lookupOccRn looks up an occurrence of a RdrName
 lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
 lookupOccRn_maybe rdr_name
   = do { local_env <- getLocalRdrEnv
-       ; case lookupLocalRdrEnv local_env rdr_name of 
-          Just name -> return (Just name)
-          Nothing   -> lookupGlobalOccRn_maybe rdr_name }
-
-lookupOccRn :: RdrName -> RnM Name
-lookupOccRn rdr_name
-  = do { mb_name <- lookupOccRn_maybe rdr_name
+       ; case lookupLocalRdrEnv local_env rdr_name of {
+          Just name -> return (Just name) ;
+          Nothing   -> do
+       { mb_name <- lookupGlobalOccRn_maybe rdr_name
        ; case mb_name of {
-		Just n  -> return n ;
-		Nothing -> do
-
-       { -- We allow qualified names on the command line to refer to 
-	 --  *any* name exported by any module in scope, just as if there
-	 -- was an "import qualified M" declaration for every module.
-	 allow_qual <- doptM Opt_ImplicitImportQualified
+                Just name  -> return (Just name) ;
+                Nothing -> do
+       { -- We allow qualified names on the command line to refer to
+         --  *any* name exported by any module in scope, just as if there
+         -- was an "import qualified M" declaration for every module.
+         allow_qual <- doptM Opt_ImplicitImportQualified
        ; is_ghci <- getIsGHCi
                -- This test is not expensive,
                -- and only happens for failed lookups
        ; if isQual rdr_name && allow_qual && is_ghci
          then lookupQualifiedName rdr_name
          else do { traceRn (text "lookupOccRn" <+> ppr rdr_name)
-                 ; unboundName WL_Any rdr_name } } } }
+                 ; return Nothing } } } } } }
 
 
 lookupGlobalOccRn :: RdrName -> RnM Name
@@ -564,7 +596,7 @@ addUsedRdrNames rdrs
 
 -- A qualified name on the command line can refer to any module at all: we
 -- try to load the interface if we don't already have it.
-lookupQualifiedName :: RdrName -> RnM Name
+lookupQualifiedName :: RdrName -> RnM (Maybe Name)
 lookupQualifiedName rdr_name
   | Just (mod,occ) <- isQual_maybe rdr_name
    -- Note: we want to behave as we would for a source file import here,
@@ -575,9 +607,9 @@ lookupQualifiedName rdr_name
 	 | avail <- mi_exports iface,
     	   name  <- availNames avail,
     	   nameOccName name == occ ] of
-      (n:ns) -> ASSERT (null ns) return n
+      (n:ns) -> ASSERT (null ns) return (Just n)
       _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name)
-              ; unboundName WL_Any rdr_name }
+              ; return Nothing }
 
   | otherwise
   = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name)
@@ -962,28 +994,6 @@ bindLocatedLocalsFV rdr_names enclosed_scope
     return (thing, delFVs names fvs)
 
 -------------------------------------
-bindTyVarsFV ::  [LHsTyVarBndr RdrName]
-	      -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-	      -> RnM (a, FreeVars)
-bindTyVarsFV tyvars thing_inside
-  = bindTyVarsRn tyvars $ \ tyvars' ->
-    do { (res, fvs) <- thing_inside tyvars'
-       ; return (res, delFVs (map hsLTyVarName tyvars') fvs) }
-
-bindTyVarsRn ::  [LHsTyVarBndr RdrName]
-	      -> ([LHsTyVarBndr Name] -> RnM a)
-	      -> RnM a
--- Haskell-98 binding of type variables; e.g. within a data type decl
-bindTyVarsRn tyvar_names enclosed_scope
-  = bindLocatedLocalsRn located_tyvars	$ \ names ->
-    do { kind_sigs_ok <- xoptM Opt_KindSignatures
-       ; unless (null kinded_tyvars || kind_sigs_ok) 
-       	 	(mapM_ (addErr . kindSigErr) kinded_tyvars)
-       ; enclosed_scope (zipWith replaceLTyVarName tyvar_names names) }
-  where 
-    located_tyvars = hsLTyVarLocNames tyvar_names
-    kinded_tyvars  = [n | L _ (KindedTyVar n _) <- tyvar_names]
-
 bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a
   -- Find the type variables in the pattern type 
   -- signatures that must be brought into scope
@@ -1402,6 +1412,11 @@ kindSigErr thing
   = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing))
        2 (ptext (sLit "Perhaps you intended to use -XKindSignatures"))
 
+polyKindsErr :: Outputable a => a -> SDoc
+polyKindsErr thing
+  = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing))
+       2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
+
 
 badQualBndrErr :: RdrName -> SDoc
 badQualBndrErr rdr_name
@@ -1412,3 +1427,56 @@ opDeclErr n
   = hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n))
        2 (ptext (sLit "Use -XTypeOperators to declare operators in type and declarations"))
 \end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Contexts for renaming errors}
+%*									*
+%************************************************************************
+
+\begin{code}
+
+data HsDocContext
+  = TypeSigCtx SDoc
+  | PatCtx
+  | SpecInstSigCtx
+  | DefaultDeclCtx
+  | ForeignDeclCtx (Located RdrName)
+  | DerivDeclCtx
+  | RuleCtx FastString
+  | TyDataCtx (Located RdrName)
+  | TySynCtx (Located RdrName)
+  | TyFamilyCtx (Located RdrName)
+  | ConDeclCtx (Located RdrName)
+  | ClassDeclCtx (Located RdrName)
+  | ExprWithTySigCtx
+  | TypBrCtx
+  | HsTypeCtx
+  | GHCiCtx
+  | SpliceTypeCtx (LHsType RdrName)
+  | ClassInstanceCtx
+  | VectDeclCtx (Located RdrName)
+
+docOfHsDocContext :: HsDocContext -> SDoc
+docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc
+docOfHsDocContext PatCtx = text "In a pattern type-signature"
+docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma"
+docOfHsDocContext DefaultDeclCtx = text "In a `default' declaration"
+docOfHsDocContext (ForeignDeclCtx name) = ptext (sLit "In the foreign declaration for") <+> ppr name
+docOfHsDocContext DerivDeclCtx = text "In a deriving declaration"
+docOfHsDocContext (RuleCtx name) = text "In the transformation rule" <+> ftext name
+docOfHsDocContext (TyDataCtx tycon) = text "In the data type declaration for" <+> quotes (ppr tycon)
+docOfHsDocContext (TySynCtx name) = text "In the declaration for type synonym" <+> quotes (ppr name)
+docOfHsDocContext (TyFamilyCtx name) = text "In the declaration for type family" <+> quotes (ppr name)
+docOfHsDocContext (ConDeclCtx name) = text "In the definition of data constructor" <+> quotes (ppr name)
+docOfHsDocContext (ClassDeclCtx name) = text "In the declaration for class" 	<+> ppr name
+docOfHsDocContext ExprWithTySigCtx = text "In an expression type signature"
+docOfHsDocContext TypBrCtx = ptext (sLit "In a Template-Haskell quoted type")
+docOfHsDocContext HsTypeCtx = text "In a type argument"
+docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input")
+docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty
+docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances")
+docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
+
+\end{code}
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index f57998ef44..7f863808eb 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -169,8 +169,13 @@ rnExpr (NegApp e _)
 -- Don't ifdef-GHCI them because we want to fail gracefully
 -- (not with an rnExpr crash) in a stage-1 compiler.
 rnExpr e@(HsBracket br_body)
-  = checkTH e "bracket"		`thenM_`
-    rnBracket br_body		`thenM` \ (body', fvs_e) ->
+  = do
+    thEnabled <- xoptM Opt_TemplateHaskell
+    unless thEnabled $
+      failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e
+                      , ptext (sLit "Perhaps you intended to use -XTemplateHaskell") ] )
+    checkTH e "bracket"
+    (body', fvs_e) <- rnBracket br_body
     return (HsBracket body', fvs_e)
 
 rnExpr (HsSpliceE splice)
@@ -265,12 +270,10 @@ rnExpr (RecordUpd expr rbinds _ _ _)
 		  fvExpr `plusFV` fvRbinds) }
 
 rnExpr (ExprWithTySig expr pty)
-  = do	{ (pty', fvTy) <- rnHsTypeFVs doc pty
+  = do	{ (pty', fvTy) <- rnHsTypeFVs ExprWithTySigCtx pty
 	; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
 		  	     rnLExpr expr
 	; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
-  where 
-    doc = text "In an expression type signature"
 
 rnExpr (HsIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
@@ -280,10 +283,8 @@ rnExpr (HsIf _ p b1 b2)
        ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
 
 rnExpr (HsType a)
-  = rnHsTypeFVs doc a	`thenM` \ (t, fvT) -> 
+  = rnHsTypeFVs HsTypeCtx a	`thenM` \ (t, fvT) -> 
     return (HsType t, fvT)
-  where 
-    doc = text "In a type argument"
 
 rnExpr (ArithSeq _ seq)
   = rnArithSeq seq	 `thenM` \ (new_seq, fvs) ->
@@ -590,14 +591,14 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
 
 \begin{code}
 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
-rnBracket (VarBr n) 
+rnBracket (VarBr flg n) 
   = do { name <- lookupOccRn n
        ; this_mod <- getModule
        ; unless (nameIsLocalOrFrom this_mod name) $  -- Reason: deprecation checking assumes
          do { _ <- loadInterfaceForName msg name     -- the home interface is loaded, and
             ; return () }			     -- this is the only way that is going
 	      	     				     -- to happen
-       ; return (VarBr name, unitFV name) }
+       ; return (VarBr flg name, unitFV name) }
   where
     msg = ptext (sLit "Need interface for Template Haskell quoted Name")
 
@@ -606,10 +607,8 @@ rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 
 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
 
-rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
+rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs TypBrCtx t
 			 ; return (TypBr t', fvs) }
-		    where
-		      doc = ptext (sLit "In a Template-Haskell quoted type")
 
 rnBracket (DecBrL decls) 
   = do { (group, mb_splice) <- findSplice decls
diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot
index 2d59537b95..5ca81d6db4 100644
--- a/compiler/rename/RnExpr.lhs-boot
+++ b/compiler/rename/RnExpr.lhs-boot
@@ -1,4 +1,4 @@
-\begin{code}

+\begin{code}
 {-# OPTIONS -fno-warn-tabs #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
@@ -6,19 +6,19 @@
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
 
-module RnExpr where

-import HsSyn

-import Name	( Name )

-import NameSet	( FreeVars )

-import RdrName	( RdrName )

-import TcRnTypes

-

-rnLExpr :: LHsExpr RdrName

-	-> RnM (LHsExpr Name, FreeVars)

-

-rnStmts :: --forall thing.

-	   HsStmtContext Name -> [LStmt RdrName] 

-        -> ([Name] -> RnM (thing, FreeVars))

-	-> RnM (([LStmt Name], thing), FreeVars)

-\end{code}

-

+module RnExpr where
+import HsSyn
+import Name	( Name )
+import NameSet	( FreeVars )
+import RdrName	( RdrName )
+import TcRnTypes
+
+rnLExpr :: LHsExpr RdrName
+	-> RnM (LHsExpr Name, FreeVars)
+
+rnStmts :: --forall thing.
+	   HsStmtContext Name -> [LStmt RdrName]
+        -> ([Name] -> RnM (thing, FreeVars))
+	-> RnM (([LStmt Name], thing), FreeVars)
+\end{code}
+
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index 7b0591dd19..e2369bb776 100644
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -16,6 +16,7 @@ module RnHsSyn(
         charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name,
         extractHsTyVars, extractHsTyNames, extractHsTyNames_s,
         extractFunDepNames, extractHsCtxtTyNames,
+        extractHsTyVarBndrNames, extractHsTyVarBndrNames_s,
 
         -- Free variables
         hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
@@ -30,6 +31,7 @@ import Name             ( Name, getName, isTyVarName )
 import NameSet
 import BasicTypes       ( TupleSort )
 import SrcLoc
+import Panic            ( panic )
 \end{code}
 
 %************************************************************************
@@ -56,6 +58,7 @@ extractFunDepNames :: FunDep Name -> NameSet
 extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2
 
 extractHsTyNames   :: LHsType Name -> NameSet
+-- Also extract names in kinds.
 extractHsTyNames ty
   = getl ty
   where
@@ -68,22 +71,24 @@ extractHsTyNames ty
     get (HsFunTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
     get (HsIParamTy _ ty)      = getl ty
     get (HsEqTy ty1 ty2)       = getl ty1 `unionNameSets` getl ty2
-    get (HsOpTy ty1 op ty2)    = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
+    get (HsOpTy ty1 (_, op) ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
     get (HsParTy ty)           = getl ty
     get (HsBangTy _ ty)        = getl ty
     get (HsRecTy flds)         = extractHsTyNames_s (map cd_fld_type flds)
     get (HsTyVar tv)           = unitNameSet tv
     get (HsSpliceTy _ fvs _)   = fvs
     get (HsQuasiQuoteTy {})    = emptyNameSet
-    get (HsKindSig ty _)       = getl ty
+    get (HsKindSig ty ki)      = getl ty `unionNameSets` getl ki
     get (HsForAllTy _ tvs
-                    ctxt ty)   = (extractHsCtxtTyNames ctxt
-                                         `unionNameSets` getl ty)
-                                            `minusNameSet`
-                                  mkNameSet (hsLTyVarNames tvs)
+                    ctxt ty)   = extractHsTyVarBndrNames_s tvs
+                                 (extractHsCtxtTyNames ctxt
+                                  `unionNameSets` getl ty)
     get (HsDocTy ty _)         = getl ty
     get (HsCoreTy {})          = emptyNameSet	-- This probably isn't quite right
     		  	       	 		-- but I don't think it matters
+    get (HsExplicitListTy _ tys) = extractHsTyNames_s tys
+    get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys
+    get (HsWrapTy {})          = panic "extractHsTyNames"
 
 extractHsTyNames_s  :: [LHsType Name] -> NameSet
 extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
@@ -91,6 +96,18 @@ extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet t
 extractHsCtxtTyNames :: LHsContext Name -> NameSet
 extractHsCtxtTyNames (L _ ctxt)
   = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt
+
+extractHsTyVarBndrNames :: LHsTyVarBndr Name -> NameSet
+extractHsTyVarBndrNames (L _ (UserTyVar _ _)) = emptyNameSet
+extractHsTyVarBndrNames (L _ (KindedTyVar _ ki _)) = extractHsTyNames ki
+
+extractHsTyVarBndrNames_s :: [LHsTyVarBndr Name] -> NameSet -> NameSet
+-- Update the name set 'body' by adding the names in the binders
+-- kinds and handling scoping.
+extractHsTyVarBndrNames_s [] body = body
+extractHsTyVarBndrNames_s (b:bs) body =
+  (extractHsTyVarBndrNames_s bs body `delFromNameSet` hsTyVarName (unLoc b))
+  `unionNameSets` extractHsTyVarBndrNames b
 \end{code}
 
 
@@ -125,7 +142,7 @@ hsSigFVs _                 = emptyFVs
 conDeclFVs :: LConDecl Name -> FreeVars
 conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context,
                            con_details = details, con_res = res_ty}))
-  = delFVs (map hsLTyVarName tyvars) $
+  = extractHsTyVarBndrNames_s tyvars $
     extractHsCtxtTyNames context  `plusFV`
     conDetailsFVs details         `plusFV`
     conResTyFVs res_ty
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 5c28f73a56..740acc42c5 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -314,12 +314,11 @@ rnPatAndThen mk (SigPatIn pat ty)
   = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables)
        ; if patsigs
          then do { pat' <- rnLPatAndThen mk pat
-                 ; ty' <- liftCpsFV (rnHsTypeFVs tvdoc ty)
+                 ; ty' <- liftCpsFV (rnHsTypeFVs PatCtx ty)
 		 ; return (SigPatIn pat' ty') }
          else do { liftCps (addErr (patSigErr ty))
                  ; rnPatAndThen mk (unLoc pat) } }
-  where
-    tvdoc = text "In a pattern type-signature"
+
        
 rnPatAndThen mk (LitPat lit)
   | HsString s <- lit
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 8b34fb4e5b..b6247d449b 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -50,7 +50,7 @@ import SrcLoc
 import DynFlags
 import HscTypes		( HscEnv, hsc_dflags )
 import ListSetOps       ( findDupsEq )
-import Digraph		( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
+import Digraph		( SCC, flattenSCCs, stronglyConnCompFromEdgedVertices )
 
 import Control.Monad
 import Maybes( orElse )
@@ -359,7 +359,7 @@ rnDefaultDecl (DefaultDecl tys)
   = do { (tys', fvs) <- mapFvRn (rnHsTypeFVs doc_str) tys
        ; return (DefaultDecl tys', fvs) }
   where
-    doc_str = text "In a `default' declaration"
+    doc_str = DefaultDeclCtx
 \end{code}
 
 %*********************************************************
@@ -373,7 +373,7 @@ rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
 rnHsForeignDecl (ForeignImport name ty _ spec)
   = do { topEnv :: HscEnv <- getTopEnv
        ; name' <- lookupLocatedTopBndrRn name
-       ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty
+       ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty
 
         -- Mark any PackageTarget style imports as coming from the current package
        ; let packageId = thisPackage $ hsc_dflags topEnv
@@ -383,16 +383,12 @@ rnHsForeignDecl (ForeignImport name ty _ spec)
 
 rnHsForeignDecl (ForeignExport name ty _ spec)
   = do { name' <- lookupLocatedOccRn name
-       ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty
+       ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty
        ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
 	-- NB: a foreign export is an *occurrence site* for name, so 
 	--     we add it to the free-variable list.  It might, for example,
 	--     be imported from another module
 
-fo_decl_msg :: Located RdrName -> SDoc
-fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
-
-
 -- | For Windows DLLs we need to know what packages imported symbols are from
 --	to generate correct calls. Imported symbols are tagged with the current
 --	package, so if they get inlined across a package boundry we'll still
@@ -546,7 +542,7 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
 	; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 		  fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
   where
-    doc = text "In the transformation rule" <+> ftext rule_name
+    doc = RuleCtx rule_name
   
     get_var (RuleBndr v)      = v
     get_var (RuleBndrSig v _) = v
@@ -715,7 +711,13 @@ rnTyClDecls tycl_ds
 
              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
 
-       ; return (map flattenSCC sccs, all_fvs) }
+       ; return ([flattenSCCs sccs], all_fvs) }
+-- JPM: This is wrong. We are calculating the SCCs but then ignore them and
+-- merge into a single, big group. This is a quick fix to allow
+-- mutually-recursive types across modules to work, given the new way of kind
+-- checking and type checking declarations in groups (see
+-- Note [Grouping of type and class declarations] in TcTyClsDecls). This "fix"
+-- fully breaks promotion; we will fix that later.
 
 rnTyClDecl :: Maybe Name  -- Just cls => this TyClDecl is nested 
 	      	    	  --             inside an *instance decl* for cls
@@ -731,12 +733,16 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
 -- and "data family"), both top level and (for an associated type) 
 -- in a class decl
 rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
-                            , tcdFlavour = flav, tcdKind = kind }) 
-  = bindQTvs mb_cls tyvars $ \tyvars' ->
+                            , tcdFlavour = flav, tcdKind = kind })
+  = bindQTvs fmly_doc mb_cls tyvars $ \tyvars' ->
     do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; kind' <- rnLHsMaybeKind fmly_doc kind
+       ; let fv_kind = maybe emptyFVs extractHsTyNames kind'
+             fvs = extractHsTyVarBndrNames_s tyvars' fv_kind
        ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
-                           , tcdFlavour = flav, tcdKind = kind }
-                , emptyFVs)  }
+                           , tcdFlavour = flav, tcdKind = kind' }
+                , fvs) }
+  where fmly_doc = TyFamilyCtx tycon
 
 -- "data", "newtype", "data instance, and "newtype instance" declarations
 -- both top level and (for an associated type) in an instance decl
@@ -745,17 +751,19 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 			   	 tcdTyPats = typats, tcdCons = condecls, 
 			   	 tcdKindSig = sig, tcdDerivs = derivs}
   = do	{ tycon' <- lookupTcdName mb_cls tydecl
+        ; sig' <- rnLHsMaybeKind data_doc sig
 	; checkTc (h98_style || null (unLoc context)) 
                   (badGadtStupidTheta tycon)
 
     	; ((tyvars', context', typats', derivs'), stuff_fvs)
-		<- bindQTvs mb_cls tyvars $ \ tyvars' -> do
+		<- bindQTvs data_doc mb_cls tyvars $ \ tyvars' -> do
 		         	 -- Checks for distinct tyvars
 		   { context' <- rnContext data_doc context
                    ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
                    ; (derivs', fvs2) <- rn_derivs derivs
                    ; let fvs = fvs1 `plusFV` fvs2 `plusFV` 
                                extractHsCtxtTyNames context'
+                               `plusFV` maybe emptyFVs extractHsTyNames sig'
 		   ; return ((tyvars', context', typats', derivs'), fvs) }
 
 	-- For the constructor declarations, bring into scope the tyvars 
@@ -772,7 +780,7 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 
 	; return (TyData {tcdND = new_or_data, tcdCtxt = context', 
 			   tcdLName = tycon', tcdTyVars = tyvars', 
-			   tcdTyPats = typats', tcdKindSig = sig,
+			   tcdTyPats = typats', tcdKindSig = sig',
 			   tcdCons = condecls', tcdDerivs = derivs'}, 
 	     	   con_fvs `plusFV` stuff_fvs)
         }
@@ -780,8 +788,8 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
     h98_style = case condecls of	 -- Note [Stupid theta]
 		     L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
 		     _    		                           -> True
-               		     						  
-    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
+
+    data_doc = TyDataCtx tycon
 
     rn_derivs Nothing   = return (Nothing, emptyFVs)
     rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds
@@ -790,16 +798,16 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 -- "type" and "type instance" declarations
 rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
 		  	              tcdTyPats = typats, tcdSynRhs = ty})
-  = bindQTvs mb_cls tyvars $ \ tyvars' -> do
+  = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do
     {    	 -- Checks for distinct tyvars
       name' <- lookupTcdName mb_cls tydecl
     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
     ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
-    ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' 
-    			, tcdTyPats = typats', tcdSynRhs = ty'},
-    	      fvs1 `plusFV` fvs2) }
+    ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
+    			, tcdTyPats = typats', tcdSynRhs = ty'}
+             , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) }
   where
-    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
+    syn_doc = TySynCtx name
 
 rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
 		         tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
@@ -810,10 +818,10 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 
 	-- Tyvars scope over superclass context and method signatures
 	; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
-	    <- bindTyVarsFV tyvars $ \ tyvars' -> do
+	    <- bindTyVarsFV cls_doc tyvars $ \ tyvars' -> do
          	 -- Checks for distinct tyvars
 	     { context' <- rnContext cls_doc context
-	     ; fds'  <- rnFds cls_doc fds
+	     ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
              ; let rn_at = rnTyClDecl (Just cls')
              ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats
 	     ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs
@@ -859,21 +867,20 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 			      tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 			      tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
                               tcdDocs = docs'},
-	     	  meth_fvs `plusFV` stuff_fvs) }
+	     	  extractHsTyVarBndrNames_s tyvars' (meth_fvs `plusFV` stuff_fvs)) }
   where
-    cls_doc  = text "In the declaration for class" <+> ppr lcls
+    cls_doc  = ClassDeclCtx lcls
 
 
-bindQTvs :: Maybe Name -> [LHsTyVarBndr RdrName]
+bindQTvs :: HsDocContext -> Maybe Name -> [LHsTyVarBndr RdrName]
          -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
          -> RnM (a, FreeVars)
--- For *associated* type/data family instances (in an instance decl)
--- don't quantify over the already-in-scope type variables
-bindQTvs mb_cls tyvars thing_inside
+bindQTvs doc mb_cls tyvars thing_inside
   | isNothing mb_cls    -- Not associated
-  = bindTyVarsFV tyvars thing_inside
+  = bindTyVarsFV doc tyvars thing_inside
   | otherwise 	 	-- Associated
   = do { let tv_rdr_names = map hsLTyVarLocName tyvars
+       	     -- *All* the free vars of the family patterns
 
        -- Check for duplicated bindings
        -- This test is irrelevant for data/type *instances*, where the tyvars
@@ -882,9 +889,10 @@ bindQTvs mb_cls tyvars thing_inside
        ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names)
 
        ; rdr_env <- getLocalRdrEnv
+
        ; tv_ns <- mapM (mk_tv_name rdr_env) tv_rdr_names
-       ; (thing, fvs) <- bindLocalNamesFV tv_ns $
-                         thing_inside (zipWith replaceLTyVarName tyvars tv_ns)
+       ; tyvars' <- zipWithM (\old new -> replaceLTyVarName old new (rnLHsKind doc)) tyvars tv_ns
+       ; (thing, fvs) <- bindLocalNamesFV tv_ns $ thing_inside tyvars'
 
 	-- Check that the RHS of the decl mentions only type variables
 	-- bound on the LHS.  For example, this is not ok
@@ -942,10 +950,21 @@ depAnalTyClDecls ds_w_fvs
     edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
             | (d, fvs) <- ds_w_fvs ]
     get_assoc n = lookupNameEnv assoc_env n `orElse` n
-    assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name) 
-                          | (L _ (ClassDecl { tcdLName = L _ cls_name
-                                            , tcdATs   = ats }) ,_) <- ds_w_fvs
-                          , L _ assoc_decl <- ats ]
+    assoc_env = mkNameEnv assoc_env_list
+    -- We also need to consider data constructor names since they may
+    -- appear in types because of promotion.
+    assoc_env_list = do
+      (L _ d, _) <- ds_w_fvs
+      case d of
+        ClassDecl { tcdLName = L _ cls_name
+                  , tcdATs = ats } -> do
+                       L _ assoc_decl <- ats
+                       return (tcdName assoc_decl, cls_name)
+        TyData { tcdLName = L _ data_name
+               , tcdCons = cons } -> do
+                       L _ dc <- cons
+                       return (unLoc (con_name dc), data_name)
+        _ -> []
 \end{code}
 
 Note [Dependency analysis of type and class decls]
@@ -969,7 +988,7 @@ is jolly confusing.  See Trac #4875
 %*********************************************************
 
 \begin{code}
-rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
+rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
 -- Although, we are processing type patterns here, all type variables will
 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 -- type declaration to which these patterns belong)
@@ -1009,22 +1028,22 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 	 -- With Implicit, find the mentioned ones, and use them as binders
 	; new_tvs <- case expl of
 	    	       Implicit -> return (userHsTyVarBndrs mentioned_tvs)
-            	       Explicit -> do { warnUnusedForAlls doc tvs mentioned_tvs
+            	       Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs
                                       ; return tvs }
 
         ; mb_doc' <- rnMbLHsDoc mb_doc 
 
-        ; bindTyVarsRn new_tvs $ \new_tyvars -> do
+        ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
 	{ new_context <- rnContext doc cxt
 	; new_details <- rnConDeclDetails doc details
         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context 
                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
  where
-    doc = text "In the definition of data constructor" <+> quotes (ppr name)
+    doc = ConDeclCtx name
     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy (HsBoxyTuple liftedTypeKind) tys))
 
-rnConResult :: SDoc
+rnConResult :: HsDocContext
             -> HsConDetails (LHsType Name) [ConDeclField Name]
             -> ResType RdrName
             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
@@ -1044,10 +1063,10 @@ rnConResult doc details (ResTyGADT ty)
 			  -- See Note [Sorting out the result type] in RdrHsSyn
 		
        ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
-              (addErr (badRecResTy doc))
+              (addErr (badRecResTy (docOfHsDocContext doc)))
        ; return (details', ResTyGADT res_ty) }
 
-rnConDeclDetails :: SDoc
+rnConDeclDetails :: HsDocContext
                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
 rnConDeclDetails doc (PrefixCon tys)
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 3607170e70..df6008b574 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -14,6 +14,7 @@
 module RnTypes ( 
 	-- Type related stuff
 	rnHsType, rnLHsType, rnLHsTypes, rnContext,
+        rnHsKind, rnLHsKind, rnLHsMaybeKind,
 	rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields,
         rnIPName,
 
@@ -22,7 +23,10 @@ module RnTypes (
 	checkPrecMatch, checkSectionPrec, warnUnusedForAlls,
 
 	-- Splice related stuff
-	rnSplice, checkTH
+	rnSplice, checkTH,
+
+        -- Binding related stuff
+        bindTyVarsRn, bindTyVarsFV
   ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -33,7 +37,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
 import DynFlags
 import HsSyn
 import RdrHsSyn		( extractHsRhoRdrTyVars )
-import RnHsSyn		( extractHsTyNames )
+import RnHsSyn		( extractHsTyNames, extractHsTyVarBndrNames_s )
 import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
 import RnEnv
 import TcRnMonad
@@ -50,7 +54,7 @@ import BasicTypes	( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi
 			  Fixity(..), FixityDirection(..) )
 import Outputable
 import FastString
-import Control.Monad	( unless )
+import Control.Monad	( unless, zipWithM )
 
 #include "HsVersions.h"
 \end{code}
@@ -65,7 +69,7 @@ to break several loop.
 %*********************************************************
 
 \begin{code}
-rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
+rnHsTypeFVs :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
 rnHsTypeFVs doc_str ty  = do
     ty' <- rnLHsType doc_str ty
     return (ty', extractHsTyNames ty')
@@ -74,12 +78,12 @@ rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
 	-- rnHsSigType is used for source-language type signatures,
 	-- which use *implicit* universal quantification.
 rnHsSigType doc_str ty
-  = rnLHsType (text "In the type signature for" <+> doc_str) ty
+  = rnLHsType (TypeSigCtx doc_str) ty
 
 rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
 -- Rename the type in an instance or standalone deriving decl
 rnLHsInstType doc_str ty 
-  = do { ty' <- rnLHsType doc_str ty
+  = do { ty' <- rnLHsType (TypeSigCtx doc_str) ty
        ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
        ; return ty' }
   where
@@ -96,12 +100,28 @@ rnHsType is here because we call it from loadInstDecl, and I didn't
 want a gratuitous knot.
 
 \begin{code}
-rnLHsType  :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
-rnLHsType doc = wrapLocM (rnHsType doc)
-
-rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
-
-rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
+rnLHsTyKi  :: Bool --  True <=> renaming a type, False <=> a kind
+           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name)
+rnLHsTyKi isType doc = wrapLocM (rnHsTyKi isType doc)
+
+rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name)
+rnLHsType = rnLHsTyKi True
+rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name)
+rnLHsKind = rnLHsTyKi False
+rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name))
+rnLHsMaybeKind _ Nothing = return Nothing
+rnLHsMaybeKind doc (Just k) = do
+  k' <- rnLHsKind doc k
+  return (Just k')
+
+rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name)
+rnHsType = rnHsTyKi True
+rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name)
+rnHsKind = rnHsTyKi False
+
+rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name)
+
+rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) = ASSERT ( isType ) do
 	-- Implicit quantifiction in source code (no kinds on tyvars)
 	-- Given the signature  C => T  we universally quantify 
 	-- over FV(T) \ {in-scope-tyvars} 
@@ -118,120 +138,141 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
 
     rnForAll doc Implicit tyvar_bndrs ctxt ty
 
-rnHsType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau)
-  = do { 	-- Explicit quantification.
+rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau)
+  = ASSERT ( isType ) do { 	-- Explicit quantification.
          -- Check that the forall'd tyvars are actually 
 	 -- mentioned in the type, and produce a warning if not
          let mentioned   = extractHsRhoRdrTyVars ctxt tau
              in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
-       ; warnUnusedForAlls (in_type_doc $$ doc) forall_tyvars mentioned
+       ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
 
        ; -- rnForAll does the rest
          rnForAll doc Explicit forall_tyvars ctxt tau }
 
-rnHsType _ (HsTyVar tyvar) = do
-    tyvar' <- lookupOccRn tyvar
-    return (HsTyVar tyvar')
+rnHsTyKi isType _ (HsTyVar rdr_name) = do
+  -- We use lookupOccRn in kinds because all the names are in
+  -- TcClsName, and we don't want to look in DataName.
+  name <- (if isType then lookupPromotedOccRn else lookupOccRn) rdr_name
+  return (HsTyVar name)
 
 -- If we see (forall a . ty), without foralls on, the forall will give
 -- a sensible error message, but we don't want to complain about the dot too
 -- Hence the jiggery pokery with ty1
-rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
-  = setSrcSpan loc $ 
+rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
+  = ASSERT ( isType ) setSrcSpan loc $ 
     do	{ ops_ok <- xoptM Opt_TypeOperators
 	; op' <- if ops_ok
-		 then lookupOccRn op 
+		 then lookupPromotedOccRn op
 		 else do { addErr (opTyErr op ty)
 			 ; return (mkUnboundName op) }	-- Avoid double complaint
 	; let l_op' = L loc op'
 	; fix <- lookupTyFixityRn l_op'
 	; ty1' <- rnLHsType doc ty1
 	; ty2' <- rnLHsType doc ty2
-	; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' }
+	; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' }
 
-rnHsType doc (HsParTy ty) = do
-    ty' <- rnLHsType doc ty
+rnHsTyKi isType doc (HsParTy ty) = do
+    ty' <- rnLHsTyKi isType doc ty
     return (HsParTy ty')
 
-rnHsType doc (HsBangTy b ty)
-  = do { ty' <- rnLHsType doc ty
+rnHsTyKi isType doc (HsBangTy b ty)
+  = ASSERT ( isType ) do { ty' <- rnLHsType doc ty
        ; return (HsBangTy b ty') }
 
-rnHsType doc (HsRecTy flds)
-  = do { flds' <- rnConDeclFields doc flds
+rnHsTyKi isType doc (HsRecTy flds)
+  = ASSERT ( isType ) do { flds' <- rnConDeclFields doc flds
        ; return (HsRecTy flds') }
 
-rnHsType doc (HsFunTy ty1 ty2) = do
-    ty1' <- rnLHsType doc ty1
+rnHsTyKi isType doc (HsFunTy ty1 ty2) = do
+    ty1' <- rnLHsTyKi isType doc ty1
 	-- Might find a for-all as the arg of a function type
-    ty2' <- rnLHsType doc ty2
+    ty2' <- rnLHsTyKi isType doc ty2
 	-- Or as the result.  This happens when reading Prelude.hi
 	-- when we find return :: forall m. Monad m -> forall a. a -> m a
 
 	-- Check for fixity rearrangements
-    mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
-
-rnHsType doc (HsListTy ty) = do
-    ty' <- rnLHsType doc ty
+    if isType
+      then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
+      else return (HsFunTy ty1' ty2')
+
+rnHsTyKi isType doc listTy@(HsListTy ty) = do
+    poly_kinds <- xoptM Opt_PolyKinds
+    unless (poly_kinds || isType) (addErr (polyKindsErr listTy))
+    ty' <- rnLHsTyKi isType doc ty
     return (HsListTy ty')
 
-rnHsType doc (HsKindSig ty k)
-  = do { kind_sigs_ok <- xoptM Opt_KindSignatures
+rnHsTyKi isType doc (HsKindSig ty k)
+  = ASSERT ( isType ) do { 
+       ; kind_sigs_ok <- xoptM Opt_KindSignatures
        ; unless kind_sigs_ok (addErr (kindSigErr ty))
        ; ty' <- rnLHsType doc ty
-       ; return (HsKindSig ty' k) }
+       ; k' <- rnLHsKind doc k
+       ; return (HsKindSig ty' k') }
 
-rnHsType doc (HsPArrTy ty) = do
+rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do
     ty' <- rnLHsType doc ty
     return (HsPArrTy ty')
 
 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsType doc (HsTupleTy tup_con tys) = do
-    tys' <- mapM (rnLHsType doc) tys
+rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do
+    poly_kinds <- xoptM Opt_PolyKinds
+    unless (poly_kinds || isType) (addErr (polyKindsErr tupleTy))
+    tys' <- mapM (rnLHsTyKi isType doc) tys
     return (HsTupleTy tup_con tys')
 
-rnHsType doc (HsAppTy ty1 ty2) = do
-    ty1' <- rnLHsType doc ty1
-    ty2' <- rnLHsType doc ty2
+rnHsTyKi isType doc (HsAppTy ty1 ty2) = do
+    ty1' <- rnLHsTyKi isType doc ty1
+    ty2' <- rnLHsTyKi isType doc ty2
     return (HsAppTy ty1' ty2')
 
-rnHsType doc (HsIParamTy n ty) = do
+rnHsTyKi isType doc (HsIParamTy n ty) = ASSERT( isType ) do
     ty' <- rnLHsType doc ty
     n' <- rnIPName n
     return (HsIParamTy n' ty')
 
-rnHsType doc (HsEqTy ty1 ty2) = do
+rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do
     ty1' <- rnLHsType doc ty1
     ty2' <- rnLHsType doc ty2
     return (HsEqTy ty1' ty2')
 
-rnHsType _ (HsSpliceTy sp _ k)
-  = do { (sp', fvs) <- rnSplice sp	-- ToDo: deal with fvs
+rnHsTyKi isType _ (HsSpliceTy sp _ k)
+  = ASSERT ( isType ) do { (sp', fvs) <- rnSplice sp	-- ToDo: deal with fvs
        ; return (HsSpliceTy sp' fvs k) }
 
-rnHsType doc (HsDocTy ty haddock_doc) = do
+rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType ) do
     ty' <- rnLHsType doc ty
     haddock_doc' <- rnLHsDoc haddock_doc
     return (HsDocTy ty' haddock_doc')
 
 #ifndef GHCI
-rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
+rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
 #else
-rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
+rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT ( isType ) do { ty <- runQuasiQuoteType qq
                                       ; rnHsType doc (unLoc ty) }
 #endif
-rnHsType _ (HsCoreTy ty) = return (HsCoreTy ty)
+rnHsTyKi isType _ (HsCoreTy ty) = ASSERT ( isType ) return (HsCoreTy ty)
+rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi"
+
+rnHsTyKi isType doc (HsExplicitListTy k tys) = 
+  ASSERT( isType )
+  do tys' <- mapM (rnLHsType doc) tys
+     return (HsExplicitListTy k tys')
+
+rnHsTyKi isType doc (HsExplicitTupleTy kis tys) =
+  ASSERT( isType )
+  do tys' <- mapM (rnLHsType doc) tys
+     return (HsExplicitTupleTy kis tys')
 
 --------------
-rnLHsTypes :: SDoc -> [LHsType RdrName]
+rnLHsTypes :: HsDocContext -> [LHsType RdrName]
            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
 \end{code}
 
 
 \begin{code}
-rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
+rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
 	 -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 
 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
@@ -244,17 +285,41 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
 	-- of kind *.
 
 rnForAll doc exp forall_tyvars ctxt ty
-  = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do
+  = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
     new_ctxt <- rnContext doc ctxt
     new_ty <- rnLHsType doc ty
     return (HsForAllTy exp new_tyvars new_ctxt new_ty)
 	-- Retain the same implicit/explicit flag as before
 	-- so that we can later print it correctly
 
-rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
+bindTyVarsFV :: HsDocContext -> [LHsTyVarBndr RdrName]
+	      -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
+	      -> RnM (a, FreeVars)
+bindTyVarsFV doc tyvars thing_inside
+  = bindTyVarsRn doc tyvars $ \ tyvars' ->
+    do { (res, fvs) <- thing_inside tyvars'
+       ; return (res, extractHsTyVarBndrNames_s tyvars' fvs) }
+
+bindTyVarsRn ::  HsDocContext -> [LHsTyVarBndr RdrName]
+	      -> ([LHsTyVarBndr Name] -> RnM a)
+	      -> RnM a
+-- Haskell-98 binding of type variables; e.g. within a data type decl
+bindTyVarsRn doc tyvar_names enclosed_scope
+  = bindLocatedLocalsRn located_tyvars	$ \ names ->
+    do { kind_sigs_ok <- xoptM Opt_KindSignatures
+       ; unless (null kinded_tyvars || kind_sigs_ok)
+           (mapM_ (addErr . kindSigErr) kinded_tyvars)
+       ; tyvar_names' <- zipWithM replace tyvar_names names
+       ; enclosed_scope tyvar_names' }
+  where
+    replace (L loc n1) n2 = replaceTyVarName n1 n2 (rnLHsKind doc) >>= return . L loc
+    located_tyvars = hsLTyVarLocNames tyvar_names
+    kinded_tyvars  = [n | L _ (KindedTyVar n _ _) <- tyvar_names]
+
+rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
 rnConDeclFields doc fields = mapM (rnField doc) fields
 
-rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
+rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name)
 rnField doc (ConDeclField name ty haddock_doc)
   = do { new_name <- lookupLocatedTopBndrRn name
        ; new_ty <- rnLHsType doc ty
@@ -269,10 +334,10 @@ rnField doc (ConDeclField name ty haddock_doc)
 %*********************************************************
 
 \begin{code}
-rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
+rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name)
 rnContext doc = wrapLocM (rnContext' doc)
 
-rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
+rnContext' :: HsDocContext -> HsContext RdrName -> RnM (HsContext Name)
 rnContext' doc ctxt = mapM (rnLHsType doc) ctxt
 
 rnIPName :: IPName RdrName -> RnM (IPName Name)
@@ -311,10 +376,10 @@ mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
 	   -> Name -> Fixity -> LHsType Name -> LHsType Name 
 	   -> RnM (HsType Name)
 
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
   = do  { fix2 <- lookupTyFixityRn op2
 	; mk_hs_op_ty mk1 pp_op1 fix1 ty1 
-		      (\t1 t2 -> HsOpTy t1 op2 t2)
+		      (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
 		      (unLoc op2) fix2 ty21 ty22 loc2 }
 
 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs
index 1b2555d018..00d6554790 100644
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -567,9 +567,17 @@ wrapTick t (FB tops defns)
   where
     wrap_defns = mapBag wrap_one 
 
-    wrap_bind (NonRec binder rhs) = NonRec binder (mkTick t rhs)
-    wrap_bind (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)
+    wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)
+    wrap_bind (Rec pairs)         = Rec (mapSnd maybe_tick pairs)
 
     wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)
-    wrap_one (FloatCase e b c bs) = FloatCase (mkTick t e) b c bs
+    wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
+
+    maybe_tick e | exprIsHNF e = e
+                 | otherwise   = mkTick t e
+      -- we don't need to wrap a tick around an HNF when we float it
+      -- outside a tick: that is an invariant of the tick semantics
+      -- Conversely, inlining of HNFs inside an SCC is allowed, and
+      -- indeed the HNF we're floating here might well be inlined back
+      -- again, and we don't want to end up with duplicate ticks.
 \end{code}
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 9af757c1af..7e3b44c7d5 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -78,7 +78,8 @@ import Literal		( litIsTrivial )
 import Demand		( StrictSig, increaseStrictSigArity )
 import Name		( getOccName, mkSystemVarName )
 import OccName		( occNameString )
-import Type		( isUnLiftedType, Type )
+import Type		( isUnLiftedType, Type, sortQuantVars )
+import Kind		( kiVarsOfKinds )
 import BasicTypes	( Arity )
 import UniqSupply
 import Util
@@ -996,22 +997,13 @@ abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
 	-- whose level is greater than the destination level
 	-- These are the ones we are going to abstract out
 abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs
-  = map zap $ uniq $ sortLe le 
+  = map zap $ uniq $ sortQuantVars  -- IA0_NOTE: centralizing sorting on variables
 	[var | fv <- varSetElems fvs
 	     , var <- absVarsOf id_env fv
 	     , abstract_me var ]
 	-- NB: it's important to call abstract_me only on the OutIds the
 	-- come from absVarsOf (not on fv, which is an InId)
   where
-	-- Sort the variables so the true type variables come first;
-	-- the tyvars scope over Ids and coercion vars
-    v1 `le` v2 = case (is_tv v1, is_tv v2) of
-		   (True, False) -> True
-		   (False, True) -> False
-		   _    	 -> v1 <= v2	-- Same family
-
-    is_tv v = isTyVar v 
-
     uniq :: [Var] -> [Var]
 	-- Remove adjacent duplicates; the sort will have brought them together
     uniq (v1:v2:vs) | v1 == v2  = uniq (v2:vs)
@@ -1036,7 +1028,9 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var]
 	-- variables
 	--
 	-- Also, if x::a is an abstracted variable, then so is a; that is,
-	--	we must look in x's type
+	-- we must look in x's type. What's more, if a mentions kind variables,
+	-- we must also return those.
+	-- 
 	-- And similarly if x is a coercion variable.
 absVarsOf id_env v 
   | isId v    = [av2 | av1 <- lookup_avs v
@@ -1047,7 +1041,9 @@ absVarsOf id_env v
 			Just (abs_vars, _) -> abs_vars
 			Nothing	           -> [v]
 
-    add_tyvars v = v : varSetElems (varTypeTyVars v)
+    add_tyvars v = v : (varSetElems tyvars ++ varSetElems kivars)
+    tyvars = varTypeTyVars v
+    kivars = kiVarsOfKinds (map tyVarKind (varSetElems tyvars))
 \end{code}
 
 \begin{code}
diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 022b354061..62f96e7c6e 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -37,7 +37,7 @@ module SimplEnv (
 	-- Floats
   	Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
 	wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
-        doFloatFromRhs, getFloatBinds, getFloats, mapFloatRhss
+        doFloatFromRhs, getFloatBinds, getFloats, mapFloats
     ) where
 
 #include "HsVersions.h"
@@ -63,7 +63,6 @@ import BasicTypes
 import MonadUtils
 import Outputable
 import FastString
-import Util
 
 import Data.List
 \end{code}
@@ -428,12 +427,12 @@ addNonRec env id rhs
     env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
 	  seInScope = extendInScopeSet (seInScope env) id }
 
-mapFloatRhss :: SimplEnv -> (CoreExpr -> CoreExpr) -> SimplEnv
-mapFloatRhss env@SimplEnv { seFloats = Floats fs ff } fun
+mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv
+mapFloats env@SimplEnv { seFloats = Floats fs ff } fun
    = env { seFloats = Floats (mapOL app fs) ff }
    where
-     app (NonRec b e) = NonRec b (fun e)
-     app (Rec bs)     = Rec (mapSnd fun bs)
+     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
+     app (Rec bs)     = Rec (map fun bs)
 
 extendFloats :: SimplEnv -> OutBind -> SimplEnv
 -- Add these bindings to the floats, and extend the in-scope env too
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 2b6d8e9887..c326cbc74d 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -1181,7 +1181,7 @@ findArity dicts_cheap bndr rhs old_arity
 
     init_cheap_app :: CheapAppFun
     init_cheap_app fn n_val_args
-      | fn == bndr = True
+      | fn == bndr = True   -- On the first pass, this binder gets infinite arity
       | otherwise  = isCheapApp fn n_val_args
  
 mk_cheap_fn :: Bool -> CheapAppFun -> CheapFun
@@ -1383,7 +1383,7 @@ abstractFloats main_tvs body_env body
 	   ; return (subst', (NonRec poly_id poly_rhs)) }
       where
 	rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
-	tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+	tvs_here = varSetElemsKvsFirst (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
 	
 		-- Abstract only over the type variables free in the rhs
 		-- wrt which the new binding is abstracted.  But the naive
@@ -1422,7 +1422,7 @@ abstractFloats main_tvs body_env body
 		-- If you ever want to be more selective, remember this bizarre case too:
 		--	x::a = x
 		-- Here, we must abstract 'x' over 'a'.
-	 tvs_here = main_tvs
+	 tvs_here = sortQuantVars main_tvs
 
     mk_poly tvs_here var
       = do { uniq <- getUniqueM
@@ -1745,18 +1745,21 @@ mkCase dflags scrut bndr alts = mkCase1 dflags scrut bndr alts
 mkCase1 _dflags scrut case_bndr alts	-- Identity case
   | all identity_alt alts
   = do { tick (CaseIdentity case_bndr)
-       ; return (re_cast scrut) }
+       ; return (re_cast scrut rhs1) }
   where
-    identity_alt (con, args, rhs) = check_eq con args (de_cast rhs)
+    identity_alt (con, args, rhs) = check_eq con args rhs
 
-    check_eq DEFAULT       _    (Var v)   = v == case_bndr
-    check_eq (LitAlt lit') _    (Lit lit) = lit == lit'
-    check_eq (DataAlt con) args rhs       = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
-					 || rhs `cheapEqExpr` Var case_bndr
-    check_eq _ _ _ = False
+    check_eq con           args (Cast e co) | not (any (`elemVarSet` tyCoVarsOfCo co) args)
+        {- See Note [RHS casts] -}          = check_eq con args e
+    check_eq _             _    (Var v)     = v == case_bndr
+    check_eq (LitAlt lit') _    (Lit lit)   = lit == lit'
+    check_eq (DataAlt con) args rhs         = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
+    check_eq _             _    _           = False
 
     arg_tys = map Type (tyConAppArgs (idType case_bndr))
 
+        -- Note [RHS casts]
+        -- ~~~~~~~~~~~~~~~~
 	-- We've seen this:
 	--	case e of x { _ -> x `cast` c }
 	-- And we definitely want to eliminate this case, to give
@@ -1766,12 +1769,11 @@ mkCase1 _dflags scrut case_bndr alts	-- Identity case
 	-- if (all identity_alt alts) holds.
 	-- 
 	-- Don't worry about nested casts, because the simplifier combines them
-    de_cast (Cast e _) = e
-    de_cast e	       = e
 
-    re_cast scrut = case head alts of
-			(_,_,Cast _ co) -> Cast scrut co
-			_    	        -> scrut
+    ((_,_,rhs1):_) = alts
+
+    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co
+    re_cast scrut _             = scrut
 
 --------------------------------------------------
 --	3. Merge Identical Alternatives
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 5d79ff575d..60b6889d5c 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1025,40 +1025,22 @@ simplTick env tickish expr cont
        ; return (env', mkTick tickish expr')
        }
 
-  -- the last case handles scoped/counting ticks, where all we
-  -- can do is simplify the inner expression and then rebuild.
-  --
-  -- NB. float handling here is tricky.  We have some floats already
-  -- in the env, and there may be floats arising from the inner
-  -- expression.  We must be careful to wrap any floats arising from
-  -- the inner expression with a non-counting tick, but not those from
-  -- the env passed in.
-  --
-
   -- For breakpoints, we cannot do any floating of bindings around the
   -- tick, because breakpoints cannot be split into tick/scope pairs.
-  | Breakpoint{} <- tickish
-  = do { let (inc,outc) = splitCont cont
-       ; (env', expr') <- simplExprF (zapFloats env) expr inc
-       ; let tickish' = simplTickish env tickish
-       ; (env'', expr'') <- rebuild (zapFloats env') (wrapFloats env' expr') (TickIt tickish' outc)
-       ; return (env'', wrapFloats env expr'')
-       }
+  | not (tickishCanSplit tickish)
+  = no_floating_past_tick
 
   | Just expr' <- want_to_push_tick_inside
     -- see Note [case-of-scc-of-case]
   = simplExprF env expr' cont
 
   | otherwise
-  = do { let (inc,outc) = splitCont cont
-       ; (env', expr') <- simplExprF (zapFloats env) expr inc
-       ; let tickish' = simplTickish env tickish
-       ; let env'' = addFloats env (mapFloatRhss env' (mkTick (mkNoTick tickish')))
-       ; rebuild env'' expr' (TickIt tickish' outc)
-       }
+  = no_floating_past_tick -- was: wrap_floats, see below
+
  where
   want_to_push_tick_inside
      | not interesting_cont = Nothing
+     | not (tickishCanSplit tickish) = Nothing
      | otherwise
        = case expr of
            Case scrut bndr ty alts
@@ -1066,10 +1048,39 @@ simplTick env tickish expr cont
              where t_scope = mkNoTick tickish -- drop the tick on the dup'd ones
                    alts'   = [ (c,bs, mkTick t_scope e) | (c,bs,e) <- alts]
            _other -> Nothing
+    where
+      interesting_cont = case cont of
+                            Select _ _ _ _ _ -> True
+                            _ -> False
+
+  no_floating_past_tick =
+    do { let (inc,outc) = splitCont cont
+       ; (env', expr') <- simplExprF (zapFloats env) expr inc
+       ; let tickish' = simplTickish env tickish
+       ; (env'', expr'') <- rebuild (zapFloats env')
+                                    (wrapFloats env' expr')
+                                    (TickIt tickish' outc)
+       ; return (addFloats env env'', expr'')
+       }
 
-  interesting_cont = case cont of
-                          Select _ _ _ _ _ -> True
-                          _ -> False
+-- Alternative version that wraps outgoing floats with the tick.  This
+-- results in ticks being duplicated, as we don't make any attempt to
+-- eliminate the tick if we re-inline the binding (because the tick
+-- semantics allows unrestricted inlining of HNFs), so I'm not doing
+-- this any more.  FloatOut will catch any real opportunities for
+-- floating.
+--
+--  wrap_floats =
+--    do { let (inc,outc) = splitCont cont
+--       ; (env', expr') <- simplExprF (zapFloats env) expr inc
+--       ; let tickish' = simplTickish env tickish
+--       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),
+--                                   mkTick (mkNoTick tickish') rhs)
+--              -- when wrapping a float with mkTick, we better zap the Id's
+--              -- strictness info and arity, because it might be wrong now.
+--       ; let env'' = addFloats env (mapFloats env' wrap_float)
+--       ; rebuild env'' expr' (TickIt tickish' outc)
+--       }
 
 
   simplTickish env tickish
@@ -1136,7 +1147,8 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 rebuild env expr cont
   = case cont of
       Stop {}                      -> return (env, expr)
-      CoerceIt co cont             -> rebuild env (mkCast expr co) cont
+      CoerceIt co cont             -> rebuild env (mkCast expr co) cont 
+                                         -- NB: mkCast implements the (Coercion co |> g) optimisation
       Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts cont
       StrictArg info _ cont        -> rebuildCall env (info `addArgTo` expr) cont
       StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 97ba4e8ab7..0a94b2b5a7 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -255,6 +255,7 @@ addLocalFamInst home_fie famInst = do
     -- If there are any conflicts, we should probably error
     -- But, if we're allowed to overwrite and the conflict is in the home FIE,
     -- then overwrite instead of error.
+    traceTc "checkForConflicts" (ppr conflicts $$ ppr famInst $$ ppr inst_envs)
     isGHCi <- getIsGHCi
     case conflicts of
         dup : _ ->  case (isGHCi, home_conflicts) of
diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs
index 62690a50bd..e6943ea4ca 100644
--- a/compiler/typecheck/TcArrows.lhs
+++ b/compiler/typecheck/TcArrows.lhs
@@ -287,9 +287,14 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
 		-- Check that it has the right shape:
 		-- 	((w,s1) .. sn)
 		-- where the si do not mention w
-	   ; checkTc (corner_ty `eqType` mkTyVarTy w_tv && 
-		      not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
+           ; _bogus <- unifyType corner_ty (mkTyVarTy w_tv)
+	   ; checkTc (not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
 		     (badFormFun i tup_ty')
+     -- JPM: WARNING: this test is utterly bogus; see #5609
+     -- We are not using the coercion returned by the unify;
+     -- and (even more seriously) the w not in arg_tys test is totally
+     -- bogus if there are suspended equality constraints. This code
+     -- needs to be re-architected.
 
 	   ; tcCmdTop (env { cmd_arr = b }) cmd arg_tys s }
 
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index ac2fe8c11b..f12bad426d 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -1273,6 +1273,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
           ATyVar {}                 -> False          -- In-scope type variables
           AGlobal {}                -> True           --    are not closed!
           AThing {}                 -> pprPanic "is_closed_id" (ppr name)
+          ANothing {}               -> pprPanic "is_closed_id" (ppr name)
       | otherwise
       = WARN( isInternalName name, ppr name ) True
         -- The free-var set for a top level binding mentions
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 26cb3ab0bc..adc0ea730c 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -23,6 +23,7 @@ import FunDeps
 import qualified TcMType as TcM
 import TcType
 import Type
+import Kind
 import Coercion
 import Class
 import TyCon
@@ -748,20 +749,23 @@ canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
   , tc1 == tc2
   , length tys1 == length tys2
   = -- Generate equalities for each of the corresponding arguments
-    do { argeqvs <- zipWithM (newEqVar fl) tys1 tys2
+    do { let (kis1,  tys1') = span isKind tys1
+             (_kis2, tys2') = span isKind tys2
+       ; let kicos = map mkReflCo kis1
+
+       ; argeqvs <- zipWithM (newEqVar fl) tys1 tys2
        ; case fl of 
            Wanted {} -> 
              setEqBind eqv $ 
-             mkTyConAppCo tc1 (map (mkEqVarLCo . evc_the_evvar) argeqvs)
+             mkTyConAppCo tc1 (kicos ++ map (mkEqVarLCo . evc_the_evvar) argeqvs)
            Given {} ->
              let do_one argeqv n = setEqBind (evc_the_evvar argeqv) 
                                              (mkNthCo n (mkEqVarLCo eqv))
-             in do { _unused <- zipWithM do_one argeqvs [0..]; return ()}
+             in zipWithM_ do_one argeqvs [(length kicos)..]
            Derived {} -> return ()
 
        ; canEqEvVarsCreated d fl argeqvs tys1 tys2 }
 
-
 -- See Note [Equality between type applications]
 --     Note [Care with type applications] in TcUnify
 canEq d fl eqv ty1 ty2
@@ -769,7 +773,8 @@ canEq d fl eqv ty1 ty2
   , Nothing <- tcView ty2  -- See Note [Naked given applications]
   , Just (s1,t1) <- tcSplitAppTy_maybe ty1
   , Just (s2,t2) <- tcSplitAppTy_maybe ty2
-  = if isGivenOrSolved fl then 
+  = ASSERT( not (isKind t1) && not (isKind t2) )
+    if isGivenOrSolved fl then 
         do { traceTcS "canEq/(app case)" $
                 text "Ommitting decomposition of given equality between: " 
                     <+> ppr ty1 <+> text "and" <+> ppr ty2
@@ -1039,18 +1044,26 @@ canEqLeafOriented :: SubGoalDepth -- Depth
 canEqLeafOriented d fl eqv s1 s2
   | let k1 = typeKind s1
   , let k2 = typeKind s2
-  , not (k1 `compatKind` k2) -- Establish kind invariants for CFunEqCan and CTyEqCan
-  = do { traceTcS "canEqLeafOriented" $ text "kind mismatch!"
-       ; canEqFailure d fl eqv }
-  | Just (fn,tys1) <- splitTyConApp_maybe s1
-  = canEqLeafFunEqLeftRec d fl eqv (fn,tys1) s2
-  | Just tv <- getTyVar_maybe s1
-  = canEqLeafTyVarLeftRec d fl eqv tv s2
-  | otherwise 
-  = pprPanic "canEqLeafOriented" $
-    text "Non-variable or non-family equality LHS" <+> ppr eqv <+> 
+  -- Establish kind invariants for CFunEqCan and CTyEqCan
+  = do { are_compat <- compatKindTcS k1 k2
+       ; can_unify <- if not are_compat
+                      then unifyKindTcS s1 s2 k1 k2
+                      else return False
+         -- If the kinds cannot be unified or are not compatible, don't fail
+         -- right away; instead, emit a frozen error
+       ; if (not are_compat && not can_unify) then 
+             canEqFailure fl eqv 
+         else can_eq_kinds_ok d fl eqv s1 s2 }
+
+  where can_eq_kinds_ok d fl eqv s1 s2
+          | Just (fn,tys1) <- splitTyConApp_maybe s1
+          = canEqLeafFunEqLeftRec d fl eqv (fn,tys1) s2
+          | Just tv <- getTyVar_maybe s1
+          = canEqLeafTyVarLeftRec d fl eqv tv s2
+          | otherwise
+          = pprPanic "canEqLeafOriented" $
+            text "Non-variable or non-family equality LHS" <+> ppr eqv <+> 
                                                        dcolon <+> ppr (evVarPred eqv)
-
 canEqLeafFunEqLeftRec :: SubGoalDepth
                       -> CtFlavor 
                       -> EqVar 
@@ -1422,7 +1435,7 @@ instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))]
 instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
                         , fd_pred1 = d1, fd_pred2 = d2 })
   = do { let tvs = varSetElems qtvs
-       ; tvs' <- mapM instFlexiTcS tvs
+       ; tvs' <- mapM instFlexiTcS tvs  -- IA0_TODO: we might need to do kind substitution
        ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs')
        ; foldM (do_one subst) [] eqs }
   where 
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index ab938d368a..68f27148b6 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -119,7 +119,7 @@ tcClassSigs clas sigs def_methods
     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 
     tc_sig genop_env (op_names, op_hs_ty)
-      = do { op_ty <- tcHsKindedType op_hs_ty	-- Class tyvars already in scope
+      = do { op_ty <- tcHsType op_hs_ty	-- Class tyvars already in scope
            ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
            where
              f nm | nm `elemNameEnv` genop_env = GenericDM
@@ -127,7 +127,7 @@ tcClassSigs clas sigs def_methods
                   | otherwise                  = NoDM
 
     tc_gen_sig (op_names, gen_hs_ty)
-      = do { gen_op_ty <- tcHsKindedType gen_hs_ty
+      = do { gen_op_ty <- tcHsType gen_hs_ty
            ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
 \end{code}
 
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index a5c55263a3..db25c134d7 100755
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -34,7 +34,7 @@ import TcMType
 import TcSimplify
 
 import RnBinds
-import RnEnv
+import RnEnv  
 import RnSource   ( addTcgDUs )
 import HscTypes
 
@@ -474,13 +474,12 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
   = setSrcSpan loc                   $
     addErrCtxt (standaloneCtxt deriv_ty)  $
     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
-       ; (tvs, theta, cls, inst_tys) <- tcHsInstHead deriv_ty
+       ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty
        ; traceTc "Standalone deriving;" $ vcat
               [ text "tvs:" <+> ppr tvs
               , text "theta:" <+> ppr theta
               , text "cls:" <+> ppr cls
               , text "tys:" <+> ppr inst_tys ]
-       ; checkValidInstance deriv_ty tvs theta cls inst_tys
 		-- C.f. TcInstDcls.tcLocalInstDecl1
 
        ; let cls_tys = take (length inst_tys - 1) inst_tys
@@ -494,6 +493,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
 
 ------------------------------------------------------------------
 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
+-- The deriving clause of a data or newtype declaration
 deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
 					           tcdTyVars = tv_names,
 				    	           tcdTyPats = ty_pats }))
@@ -541,7 +541,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
 	; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
 		  (typeFamilyPapErr tc cls cls_tys inst_ty)
 
-	; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
+	; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } }
   where
 	-- Tiresomely we must figure out the "lhs", which is awkward for type families
 	-- E.g.   data T a b = .. deriving( Eq )
@@ -553,6 +553,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
     get_lhs Nothing     = do { tc <- tcLookupTyCon tycon_name
 			     ; let tvs = tyConTyVars tc
 			     ; return (tvs, tc, mkTyVarTys tvs) }
+    -- JPM: to fix
     get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
 			     ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
 			     ; let (tc, tc_args) = tcSplitTyConApp tc_app
@@ -1111,7 +1112,7 @@ mkNewTypeEqn orig dflags tvs
 	; dfun_name <- new_dfun_name cls tycon
   	; loc <- getSrcSpanM
 	; let spec = DS { ds_loc = loc, ds_orig = orig
-			, ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs
+			, ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs
 			, ds_cls = cls, ds_tys = inst_tys
 			, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
 			, ds_theta =  mtheta `orElse` all_preds
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 48b637bdd8..4fe7ee1b93 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -14,13 +14,13 @@ module TcEnv(
         -- Global environment
         tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
         tcExtendGlobalValEnv,
-        tcLookupLocatedGlobal,  tcLookupGlobal, 
+        tcLookupLocatedGlobal, tcLookupGlobal, 
         tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
         tcLookupLocatedClass, tcLookupInstance,
         
         -- Local environment
-        tcExtendKindEnv, tcExtendKindEnvTvs,
+        tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv,
         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
         tcExtendGhciEnv, tcExtendLetEnv,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
@@ -32,13 +32,13 @@ module TcEnv(
         tcExtendRecEnv,         -- For knot-tying
 
         -- Rules
-        tcExtendRules,
+         tcExtendRules,
 
         -- Defaults
         tcGetDefaultTys,
 
         -- Global type variables
-        tcGetGlobalTyVars,
+        tcGetGlobalTyVars, zapLclTypeEnv,
 
         -- Template Haskell stuff
         checkWellStaged, tcMetaTy, thLevel, 
@@ -221,36 +221,31 @@ setGlobalTypeEnv tcg_env new_type_env
          ; return (tcg_env { tcg_type_env = new_type_env }) }
 
 
-tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
-  -- Given a mixture of Ids, TyCons, Classes, all defined in the
-  -- module being compiled, extend the global environment
-tcExtendGlobalEnv things thing_inside
-  = do { env <- getGblEnv
-       ; let env' = env { tcg_tcs  = [ tc | ATyCon tc <- things,
-                                            not (isClassTyCon tc)]
-                                      ++ tcg_tcs env
-                        , tcg_clss = [ cl | ATyCon tc <- things,
-                                            Just cl <- [tyConClass_maybe tc]]
-                                      ++ tcg_clss env }
-       ; setGblEnv env' $
-            tcExtendGlobalEnvImplicit things thing_inside
-       }
-
 tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
   -- Extend the global environment with some TyThings that can be obtained
   -- via implicitTyThings from other entities in the environment.  Examples
   -- are dfuns, famInstTyCons, data cons, etc.
-  -- These TyThings are not added to tcg_tcs or tcg_clss.
+  -- These TyThings are not added to tcg_tcs.
 tcExtendGlobalEnvImplicit things thing_inside
    = do { tcg_env <- getGblEnv
         ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
         ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
         ; setGblEnv tcg_env' thing_inside }
 
+tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
+  -- Given a mixture of Ids, TyCons, Classes, all defined in the
+  -- module being compiled, extend the global environment
+tcExtendGlobalEnv things thing_inside
+  = do { env <- getGblEnv
+       ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env }
+       ; setGblEnv env' $
+            tcExtendGlobalEnvImplicit things thing_inside
+       }
+
 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
   -- Same deal as tcExtendGlobalEnv, but for Ids
 tcExtendGlobalValEnv ids thing_inside 
-  = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
+  = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
 
 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
 -- Extend the global environments for the type/class knot tying game
@@ -319,6 +314,13 @@ getInLocalScope = do { lcl_env <- getLclTypeEnv
 \end{code}
 
 \begin{code}
+tcExtendTcTyThingEnv :: [(Name, TcTyThing)] -> TcM r -> TcM r
+tcExtendTcTyThingEnv things thing_inside
+  = updLclEnv upd thing_inside
+  where
+    upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
+    extend env  = extendNameEnvList env things
+
 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
 tcExtendKindEnv things thing_inside
   = updLclEnv upd thing_inside
@@ -442,6 +444,14 @@ tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
 tcExtendGlobalTyVars gtv_var extra_global_tvs
   = do { global_tvs <- readMutVar gtv_var
        ; newMutVar (global_tvs `unionVarSet` extra_global_tvs) }
+
+zapLclTypeEnv :: TcM a -> TcM a
+zapLclTypeEnv thing_inside
+  = do { tvs_var <- newTcRef emptyVarSet 
+       ; let upd env = env { tcl_env = emptyNameEnv
+                           , tcl_rdr = emptyLocalRdrEnv
+                           , tcl_tyvars = tvs_var }
+       ; updLclEnv upd thing_inside }
 \end{code}
 
 
@@ -724,11 +734,15 @@ pprBinders bndrs  = pprWithCommas ppr bndrs
 
 notFound :: Name -> TcM TyThing
 notFound name 
-  = do { (gbl,lcl) <- getEnvs
+  = do { (_gbl,lcl) <- getEnvs
        ; failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> 
                      ptext (sLit "is not in scope during type checking, but it passed the renamer"),
-                     ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env gbl),
                      ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)]
+                       -- Take case: printing the whole gbl env can
+                       -- cause an infnite loop, in the case where we
+                       -- are in the middle of a recursive TyCon/Class group;
+                       -- so let's just not print it!  Getting a loop here is
+                       -- very unhelpful, because it hides one compiler bug with another
                     ) }
 
 wrongThingErr :: String -> TcTyThing -> Name -> TcM a
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 63ce0767a0..52177567e3 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -39,11 +39,13 @@ import TcHsType
 import TcPat
 import TcMType
 import TcType
+import DsMonad hiding (Splice)
 import Id
 import DataCon
 import Name
 import TyCon
 import Type
+import Kind( splitKiTyVars )
 import Coercion
 import Var
 import VarSet
@@ -52,7 +54,6 @@ import TysWiredIn
 import TysPrim( intPrimTy )
 import PrimOp( tagToEnumKey )
 import PrelNames
-import Module
 import DynFlags
 import SrcLoc
 import Util
@@ -290,8 +291,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
 
        -- Make sure that the argument and result types have kind '*'
        -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
-       ; unifyKind (typeKind arg2_ty) liftedTypeKind
-       ; unifyKind (typeKind res_ty)  liftedTypeKind
+       ; _ <- unifyKind (typeKind arg2_ty) liftedTypeKind
+       ; _ <- unifyKind (typeKind res_ty)  liftedTypeKind
 
        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
        ; co_res <- unifyType op_res_ty res_ty
@@ -646,16 +647,24 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
 	-- 
 	; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
 	      is_fixed_tv tv = tv `elemVarSet` fixed_tvs
-	      mk_inst_ty tv result_inst_ty 
+	      mk_inst_ty subst tv result_inst_ty 
 	        | is_fixed_tv tv = return result_inst_ty	    -- Same as result type
-	        | otherwise      = newFlexiTyVarTy (tyVarKind tv)  -- Fresh type, of correct kind
+	        | otherwise      = newFlexiTyVarTy (subst (tyVarKind tv))  -- Fresh type, of correct kind
 
 	; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
-	; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
 
-	; let rec_res_ty    = TcType.substTy result_inst_env con1_res_ty
+        ; let (con1_r_kvs, con1_r_tvs) = splitKiTyVars con1_tvs
+              n_kinds = length con1_r_kvs
+              (result_inst_r_kis, result_inst_r_tys) = splitAt n_kinds result_inst_tys
+	; scrut_inst_r_kis <- zipWithM (mk_inst_ty (TcType.substTy (zipTopTvSubst [] []))) con1_r_kvs result_inst_r_kis
+          -- IA0_NOTE: we have to build the kind substitution
+        ; let kind_subst = TcType.substTy (zipTopTvSubst con1_r_kvs scrut_inst_r_kis)
+	; scrut_inst_r_tys <- zipWithM (mk_inst_ty kind_subst) con1_r_tvs result_inst_r_tys
+
+	; let scrut_inst_tys = scrut_inst_r_kis ++ scrut_inst_r_tys
+              rec_res_ty    = TcType.substTy result_inst_env con1_res_ty
 	      con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys
-	      scrut_subst   = zipTopTvSubst con1_tvs scrut_inst_tys
+              scrut_subst   = zipTopTvSubst con1_tvs scrut_inst_tys
 	      scrut_ty      = TcType.substTy scrut_subst con1_res_ty
 
         ; co_res <- unifyType rec_res_ty res_ty
@@ -749,8 +758,9 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
   = do	{ (coi, elt_ty) <- matchExpectedPArrTy res_ty
 	; expr1' <- tcPolyExpr expr1 elt_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
+	; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
 	; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) 
-				 (enumFromToPName basePackageId) elt_ty    -- !!!FIXME: chak
+				 (idName enumFromToP) elt_ty
 	; return $ mkHsWrapCo coi 
                      (PArrSeq enum_from_to (FromTo expr1' expr2')) }
 
@@ -759,13 +769,14 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 	; expr1' <- tcPolyExpr expr1 elt_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
 	; expr3' <- tcPolyExpr expr3 elt_ty
+	; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
 	; eft <- newMethodFromName (PArrSeqOrigin seq)
-		      (enumFromThenToPName basePackageId) elt_ty        -- !!!FIXME: chak
+		      (idName enumFromThenToP) elt_ty        -- !!!FIXME: chak
 	; return $ mkHsWrapCo coi 
                      (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
 
 tcExpr (PArrSeq _ _) _ 
-  = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
+  = panic "TcExpr.tcExpr: Infinite parallel array!"
     -- the parser shouldn't have generated it and the renamer shouldn't have
     -- let it through
 \end{code}
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 5d6f8cc20c..1b50a57a78 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -26,7 +26,7 @@ module TcHsSyn (
 	-- re-exported from TcMonad
 	TcId, TcIdSet, 
 
-	zonkTopDecls, zonkTopExpr, zonkTopLExpr,
+	zonkTopDecls, zonkTopExpr, zonkTopLExpr, mkZonkTcTyVar,
 	zonkId, zonkTopBndrs
   ) where
 
@@ -45,6 +45,8 @@ import TcMType
 import Coercion
 import TysPrim
 import TysWiredIn
+import Type
+import Kind
 import DataCon
 import Name
 import NameSet
@@ -189,8 +191,15 @@ It's all pretty boring stuff, because HsSyn is such a large type, and
 the environment manipulation is tiresome.
 
 \begin{code}
-data ZonkEnv = ZonkEnv	(TcType -> TcM Type) 	-- How to zonk a type
-			(VarEnv Var)		-- What variables are in scope
+type UnboundTyVarZonker = TcTyVar-> TcM Type 
+	-- How to zonk an unbound type variable
+        -- Note [Zonking the LHS of a RULE]
+
+data ZonkEnv 
+  = ZonkEnv 
+      UnboundTyVarZonker
+      (TyVarEnv TyVar)          -- 
+      (IdEnv Var)		-- What variables are in scope
 	-- Maps an Id or EvVar to its zonked version; both have the same Name
 	-- Note that all evidence (coercion variables as well as dictionaries)
 	-- 	are kept in the ZonkEnv
@@ -202,21 +211,25 @@ instance Outputable ZonkEnv where
 
 
 emptyZonkEnv :: ZonkEnv
-emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
+emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv emptyVarEnv
 
-extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
-extendZonkEnv (ZonkEnv zonk_ty env) ids 
-  = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
+extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
+extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids 
+  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
 
-extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
-extendZonkEnv1 (ZonkEnv zonk_ty env) id 
-  = ZonkEnv zonk_ty (extendVarEnv env id id)
+extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
+extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id 
+  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
 
-setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
-setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
+extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
+extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
+  = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env
+
+setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
+setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env
 
 zonkEnvIds :: ZonkEnv -> [Id]
-zonkEnvIds (ZonkEnv _ env) = varEnvElts env
+zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
 
 zonkIdOcc :: ZonkEnv -> TcId -> Id
 -- Ids defined in this module should be in the envt; 
@@ -234,7 +247,7 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id
 --
 -- Even without template splices, in module Main, the checking of
 -- 'main' is done as a separate chunk.
-zonkIdOcc (ZonkEnv _zonk_ty env) id 
+zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id 
   | isLocalVar id = lookupVarEnv env id `orElse` id
   | otherwise	  = id
 
@@ -261,17 +274,30 @@ zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
 -- Works for dictionaries and coercions
 zonkEvBndrX env var
   = do { var' <- zonkEvBndr env var
-       ; return (extendZonkEnv1 env var', var') }
+       ; return (extendIdZonkEnv1 env var', var') }
 
 zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
 -- Works for dictionaries and coercions
 -- Does not extend the ZonkEnv
 zonkEvBndr env var 
-  = do { ty' <- zonkTcTypeToType env (varType var)
-       ; return (setVarType var ty') }
+  = do { ty <- zonkTcTypeToType env (varType var)
+       ; return (setVarType var ty) }
 
 zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
 zonkEvVarOcc env v = zonkIdOcc env v
+
+zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
+zonkTyBndrsX = mapAccumLM zonkTyBndrX 
+
+zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
+zonkTyBndrX env tv
+  = do { tv' <- zonkTyBndr env tv
+       ; return (extendTyZonkEnv1 env tv', tv') }
+
+zonkTyBndr :: ZonkEnv -> TyVar -> TcM TyVar
+zonkTyBndr env tv
+  = do { ki <- zonkTcTypeToType env (tyVarKind tv)
+       ; return (setVarType tv ki) }
 \end{code}
 
 
@@ -335,7 +361,7 @@ zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
   = mappM (wrapLocM zonk_ip_bind) binds	`thenM` \ new_binds ->
     let
-	env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
+	env1 = extendIdZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
     in
     zonkTcEvBinds env1 dict_binds 	`thenM` \ (env2, new_dict_binds) -> 
     returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
@@ -349,7 +375,7 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
 zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
 zonkRecMonoBinds env sig_warn binds 
  = fixM (\ ~(_, new_binds) -> do 
-	{ let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
+	{ let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
         ; binds' <- zonkMonoBinds env1 sig_warn binds
         ; return (env1, binds') })
 
@@ -429,15 +455,17 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
 			         , abs_exports = exports
                                  , abs_binds = val_binds })
   = ASSERT( all isImmutableTyVar tyvars )
-    do { (env1, new_evs) <- zonkEvBndrsX env evs
+    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
        ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
        ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
-    	 do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds)
+         do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
     	    ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
     	    ; new_exports   <- mapM (zonkExport env3) exports
     	    ; return (new_val_binds, new_exports) } 
        ; sig_warn True (map abe_poly new_exports)
-       ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
+       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
+                          , abs_ev_binds = new_ev_binds
 			  , abs_exports = new_exports, abs_binds = new_val_bind }) }
   where
     zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id
@@ -699,7 +727,8 @@ zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
 zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg 
                                  ; return (env, WpEvApp arg') }
 zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
-                              return (env, WpTyLam tv) 
+                              do { (env', tv') <- zonkTyBndrX env tv
+				 ; return (env', WpTyLam tv') }
 zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
 				 ; return (env, WpTyApp ty') }
 zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
@@ -748,7 +777,7 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
   = mappM zonk_branch stmts_w_bndrs	`thenM` \ new_stmts_w_bndrs ->
     let 
 	new_binders = concat (map snd new_stmts_w_bndrs)
-	env1 = extendZonkEnv env new_binders
+	env1 = extendIdZonkEnv env new_binders
     in
     zonkExpr env1 mzip_op   `thenM` \ new_mzip ->
     zonkExpr env1 bind_op   `thenM` \ new_bind ->
@@ -767,12 +796,12 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id
        ; new_ret_id  <- zonkExpr env ret_id
        ; new_mfix_id <- zonkExpr env mfix_id
        ; new_bind_id <- zonkExpr env bind_id
-       ; let env1 = extendZonkEnv env new_rvs
+       ; let env1 = extendIdZonkEnv env new_rvs
        ; (env2, new_segStmts) <- zonkStmts env1 segStmts
 	-- Zonk the ret-expressions in an envt that 
 	-- has the polymorphic bindings in the envt
        ; new_rets <- mapM (zonkExpr env2) rets
-       ; return (extendZonkEnv env new_lvs,     -- Only the lvs are needed
+       ; return (extendIdZonkEnv env new_lvs,     -- Only the lvs are needed
                  RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
                          , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
@@ -800,7 +829,7 @@ zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
     ; return_op' <- zonkExpr env' return_op
     ; bind_op'   <- zonkExpr env' bind_op
     ; liftM_op'  <- zonkExpr env' liftM_op
-    ; let env'' = extendZonkEnv env' (map snd binderMap')
+    ; let env'' = extendIdZonkEnv env' (map snd binderMap')
     ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
                                , trS_by = by', trS_form = form, trS_using = using'
                                , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
@@ -862,7 +891,7 @@ zonk_pat env (WildPat ty)
 
 zonk_pat env (VarPat v)
   = do	{ v' <- zonkIdBndr env v
-	; return (extendZonkEnv1 env v', VarPat v') }
+	; return (extendIdZonkEnv1 env v', VarPat v') }
 
 zonk_pat env (LazyPat pat)
   = do	{ (env', pat') <- zonkPat env pat
@@ -874,7 +903,7 @@ zonk_pat env (BangPat pat)
 
 zonk_pat env (AsPat (L loc v) pat)
   = do	{ v' <- zonkIdBndr env v
-	; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
+	; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
  	; return (env', AsPat (L loc v') pat') }
 
 zonk_pat env (ViewPat expr pat ty)
@@ -925,7 +954,7 @@ zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
 	; lit' <- zonkOverLit env lit
  	; e1' <- zonkExpr env e1
 	; e2' <- zonkExpr env e2
-	; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
+	; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
 
 zonk_pat env (CoPat co_fn pat ty) 
   = do { (env', co_fn') <- zonkCoFn env co_fn
@@ -987,35 +1016,21 @@ zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 
 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
-  = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars
-
-       ; unbound_tv_set <- newMutVar emptyVarSet
-       ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
-	-- We need to gather the type variables mentioned on the LHS so we can 
-	-- quantify over them.  Example:
-	--   data T a = C
-	-- 
-	--   foo :: T a -> Int
-	--   foo C = 1
-	--
-	--   {-# RULES "myrule"  foo C = 1 #-}
-	-- 
-	-- After type checking the LHS becomes (foo a (C a))
-	-- and we do not want to zap the unbound tyvar 'a' to (), because
-	-- that limits the applicability of the rule.  Instead, we
-	-- want to quantify over it!  
-	--
-	-- It's easiest to find the free tyvars here. Attempts to do so earlier
-	-- are tiresome, because (a) the data type is big and (b) finding the 
-	-- free type vars of an expression is necessarily monadic operation.
-	--	(consider /\a -> f @ b, where b is side-effected to a)
-
-       ; new_lhs <- zonkLExpr env_lhs lhs
-       ; new_rhs <- zonkLExpr env_rhs rhs
-
-       ; unbound_tvs <- readMutVar unbound_tv_set
+  = do { unbound_tkv_set <- newMutVar emptyVarSet
+       ; let env_rule = setZonkType env (zonkTvCollecting unbound_tkv_set)
+              -- See Note [Zonking the LHS of a RULE]
+
+       ; (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env_rule vars
+
+       ; new_lhs <- zonkLExpr env_inside lhs
+       ; new_rhs <- zonkLExpr env_inside rhs
+
+       ; unbound_tkvs <- readMutVar unbound_tkv_set
+
        ; let final_bndrs :: [RuleBndr Var]
-	     final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs
+             final_bndrs = map (RuleBndr . noLoc)
+                             (varSetElemsKvsFirst unbound_tkvs)
+                           ++ new_bndrs
 
        ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
   where
@@ -1024,7 +1039,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
    zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
 
    zonk_it env v
-     | isId v     = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
+     | isId v     = do { v' <- zonkIdBndr env v; return (extendIdZonkEnv1 env v', v') }
      | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
 \end{code}
 
@@ -1089,7 +1104,7 @@ zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
 zonkEvBinds env binds
   = fixM (\ ~( _, new_binds) -> do
-	 { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds)
+	 { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds)
          ; binds' <- mapBagM (zonkEvBind env1) binds
          ; return (env1, binds') })
   where
@@ -1110,39 +1125,108 @@ zonkEvBind env (EvBind var term)
 %*									*
 %************************************************************************
 
+Note [Zonking the LHS of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to gather the type variables mentioned on the LHS so we can 
+quantify over them.  Example:
+  data T a = C
+
+  foo :: T a -> Int
+  foo C = 1
+
+  {-# RULES "myrule"  foo C = 1 #-}
+
+After type checking the LHS becomes (foo a (C a))
+and we do not want to zap the unbound tyvar 'a' to (), because
+that limits the applicability of the rule.  Instead, we
+want to quantify over it!  
+
+It's easiest to get zonkTvCollecting to gather the free tyvars
+here. Attempts to do so earlier are tiresome, because (a) the data
+type is big and (b) finding the free type vars of an expression is
+necessarily monadic operation. (consider /\a -> f @ b, where b is
+side-effected to a)
+
+And that in turn is why ZonkEnv carries the function to use for
+type variables!
+
+Note [Zonking mutable unbound type or kind variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an
+arbitrary type. We know if they are unbound even though we don't carry an
+environment, because at the binding site for a variable we bind the mutable
+var to a fresh immutable one.  So the mutable store plays the role of an
+environment.  If we come across a mutable variable that isn't so bound, it
+must be completely free. We zonk the expected kind to make sure we don't get
+some unbound meta variable as the kind.
+
+Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both
+type and kind variables. Consider the following datatype:
+
+  data Phantom a = Phantom Int
+
+The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and
+`k` are unbound variables. We want to zonk this to
+(forall (k : AnyK). forall (a : Any AnyK). Int). For that we have to check if
+we have a type or a kind variable; for kind variables we just return AnyK (and
+not the ill-kinded Any BOX).
+
 \begin{code}
+mkZonkTcTyVar :: (TcTyVar -> TcM Type)	-- What to do for an *mutable Flexi* var
+	      -> (TcTyVar -> Type)	-- What to do for an immutable var
+ 	      -> TcTyVar -> TcM TcType
+mkZonkTcTyVar unbound_mvar_fn unbound_ivar_fn
+  = zonk_tv
+  where
+    zonk_tv tv 
+     = ASSERT( isTcTyVar tv )
+       case tcTyVarDetails tv of
+         SkolemTv {}    -> return (unbound_ivar_fn tv)
+         RuntimeUnk {}  -> return (unbound_ivar_fn tv)
+         FlatSkol ty    -> zonkType zonk_tv ty
+         MetaTv _ ref   -> do { cts <- readMutVar ref
+           		      ; case cts of    
+           		           Flexi -> do { kind <- zonkType zonk_tv (tyVarKind tv)
+                                               ; unbound_mvar_fn (setTyVarKind tv kind) }
+           		           Indirect ty -> zonkType zonk_tv ty }
+
 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
-zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
+zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env)
+  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar)
+  where
+    zonk_bound_tyvar tv = case lookupVarEnv tv_env tv of
+                            Nothing  -> mkTyVarTy tv
+                            Just tv' -> mkTyVarTy tv'
 
 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
 
-zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
+zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker
 -- This variant collects unbound type variables in a mutable variable
-zonkTypeCollecting unbound_tv_set
-  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
-  where
-    zonk_unbound_tyvar tv 
-        = do { tv' <- zonkQuantifiedTyVar tv
-	     ; tv_set <- readMutVar unbound_tv_set
-	     ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
-	     ; return (mkTyVarTy tv') }
-
-zonkTypeZapping :: TcType -> TcM Type
+-- Works on both types and kinds
+zonkTvCollecting unbound_tv_set tv
+  = do { poly_kinds <- xoptM Opt_PolyKinds
+       ; if isKiVar tv && not poly_kinds then
+            do { defaultKindVarToStar tv
+               ; return liftedTypeKind }
+         else do
+       { tv' <- zonkQuantifiedTyVar tv
+       ; tv_set <- readMutVar unbound_tv_set
+       ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
+       ; return (mkTyVarTy tv') } }
+
+zonkTypeZapping :: UnboundTyVarZonker
 -- This variant is used for everything except the LHS of rules
 -- It zaps unbound type variables to (), or some other arbitrary type
-zonkTypeZapping ty 
-  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) ty 
-  where
-	-- Zonk a mutable but unbound type variable to an arbitrary type
-	-- We know it's unbound even though we don't carry an environment,
-	-- because at the binding site for a type variable we bind the
-	-- mutable tyvar to a fresh immutable one.  So the mutable store
-	-- plays the role of an environment.  If we come across a mutable
-	-- type variable that isn't so bound, it must be completely free.
-    zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
-			       ; writeMetaTyVar tv ty
-			       ; return ty }
+-- Works on both types and kinds
+zonkTypeZapping tv
+  = do { let ty = if isKiVar tv
+                  -- ty is actually a kind, zonk to AnyK
+                  then anyKind
+                  else anyTypeOfKind (tyVarKind tv)
+       ; writeMetaTyVar tv ty
+       ; return ty }
+
 
 zonkTcLCoToLCo :: ZonkEnv -> LCoercion -> TcM LCoercion
 -- NB: zonking often reveals that the coercion is an identity
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index b0ef207799..8f1fb54df3 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -20,11 +20,16 @@ module TcHsType (
 		-- Kind checking
 	kcHsTyVars, kcHsSigType, kcHsLiftedSigType, 
 	kcLHsType, kcCheckLHsType, kcHsContext, kcApps,
-	
-		-- Typechecking kinded types
-	tcHsKindedContext, tcHsKindedType, tcHsBangType,
-	tcTyVarBndrs, dsHsType,
-	tcDataKindSig,
+        kindGeneralizeKind, kindGeneralizeKinds,
+
+		-- Sort checking
+	scDsLHsKind, scDsLHsMaybeKind,
+
+                -- Typechecking kinded types
+	tcHsType, tcCheckHsType,
+        tcHsKindedContext, tcHsKindedType, tcHsBangType,
+	tcTyVarBndrs, tcTyVarBndrsKindGen, dsHsType,
+	tcDataKindSig, tcTyClTyVars,
 
         ExpKind(..), EkCtxt(..), ekConstraint,
         checkExpectedKind,
@@ -42,27 +47,34 @@ import {-# SOURCE #-}	TcSplice( kcSpliceType )
 import HsSyn
 import RnHsSyn
 import TcRnMonad
+import RnEnv   ( polyKindsErr )
+import TcHsSyn ( mkZonkTcTyVar )
 import TcEnv
 import TcMType
 import TcUnify
 import TcIface
 import TcType
 import {- Kind parts of -} Type
-import Kind ( isConstraintKind )
+import Kind
 import Var
 import VarSet
 import TyCon
+import DataCon ( DataCon, dataConUserType )
+import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
 import Class
+import RdrName ( rdrNameSpace, nameRdrName )
 import Name
 import NameSet
 import TysWiredIn
 import BasicTypes
 import SrcLoc
-import DynFlags ( ExtensionFlag( Opt_ConstraintKinds ) )
+import DynFlags ( ExtensionFlag( Opt_ConstraintKinds, Opt_PolyKinds ) )
 import Util
 import UniqSupply
 import Outputable
+import BuildTyCl ( buildPromotedDataTyCon )
 import FastString
+import Control.Monad ( unless )
 \end{code}
 
 
@@ -163,34 +175,37 @@ tcHsSigTypeNC ctxt hs_ty
     	  -- The kind is checked by checkValidType, and isn't necessarily
 	  -- of kind * in a Template Haskell quote eg [t| Maybe |]
 	; ty <- tcHsKindedType kinded_ty
-	; checkValidType ctxt ty	
+	; checkValidType ctxt ty
 	; return ty }
 
-tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type])
+-- Like tcHsType, but takes an expected kind
+tcCheckHsType :: LHsType Name -> Kind -> TcM Type
+tcCheckHsType hs_ty exp_kind
+  = do { kinded_ty <- kcCheckLHsType hs_ty (EK exp_kind EkUnk) -- JPM add context
+       ; ty <- tcHsKindedType kinded_ty
+       ; return ty }
+
+tcHsType :: LHsType Name -> TcM Type
+-- kind check and desugar
+-- no validity checking because of knot-tying
+tcHsType hs_ty
+  = do { (kinded_ty, _) <- kc_lhs_type hs_ty
+       ; ty <- tcHsKindedType kinded_ty
+       ; return ty }
+
+tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type])
 -- Typecheck an instance head.  We can't use 
 -- tcHsSigType, because it's not a valid user type.
-tcHsInstHead (L loc hs_ty)
+tcHsInstHead ctxt lhs_ty@(L loc hs_ty)
   = setSrcSpan loc   $	-- No need for an "In the type..." context
                         -- because that comes from the caller
-    kc_ds_inst_head hs_ty
-  where
-    kc_ds_inst_head ty = case splitHsClassTy_maybe cls_ty of
-        Just _ -> do -- Kind-checking first
-          (tvs, ctxt, cls_ty) <- kcHsTyVars tv_names $ \ tv_names' -> do
-            ctxt' <- mapM kcHsLPredType ctxt
-            cls_ty' <- kc_check_hs_type cls_ty ekConstraint
-               -- The body of a forall is usually lifted, but in an instance
-               -- head we only allow something of kind Constraint.
-            return (tv_names', ctxt', cls_ty')
-          -- Now desugar the kind-checked type
-          let Just (cls_name, tys) = splitHsClassTy_maybe cls_ty
-          tcTyVarBndrs tvs  $ \ tvs' -> do
-            ctxt' <- dsHsTypes ctxt
-            clas <- tcLookupClass cls_name
-            tys' <- dsHsTypes tys
-            return (tvs', ctxt', clas, tys')
-        _ -> failWithTc (ptext (sLit "Malformed instance type"))
-      where (tv_names, ctxt, cls_ty) = splitHsForAllTy ty
+    do { kinded_ty <- kc_check_hs_type hs_ty ekConstraint
+       ; ty <- ds_type kinded_ty
+       ; let (tvs, theta, tau) = tcSplitSigmaTy ty
+       ; case getClassPredTys_maybe tau of
+           Nothing          -> failWithTc (ptext (sLit "Malformed instance type"))
+           Just (clas,tys)  -> do { checkValidInstance ctxt lhs_ty tvs theta clas tys
+                                  ; return (tvs, theta, clas, tys) } }
 
 tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type)
 -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
@@ -219,7 +234,7 @@ tc_hs_deriv tv_names ty
   = kcHsTyVars tv_names                 $ \ tv_names' ->
     do  { cls_kind <- kcClass cls_name
         ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys
-        ; tcTyVarBndrs tv_names'        $ \ tyvars ->
+        ; tcTyVarBndrsKindGen tv_names'        $ \ tyvars ->
     do  { arg_tys <- dsHsTypes tys
         ; cls <- tcLookupClass cls_name
         ; return (tyvars, cls, arg_tys) }}
@@ -249,7 +264,7 @@ tcHsVectInst ty
 \begin{code}
 kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name)
 	-- Used for type signatures
-kcHsSigType ty 	     = addKcTypeCtxt ty $ kcTypeType ty
+kcHsSigType ty 	     = addKcTypeCtxt ty $ kcArgType ty
 kcHsLiftedSigType ty = addKcTypeCtxt ty $ kcLiftedType ty
 
 tcHsKindedType :: LHsType Name -> TcM Type
@@ -261,6 +276,7 @@ tcHsKindedType hs_ty = dsHsType hs_ty
 
 tcHsBangType :: LHsType Name -> TcM Type
 -- Permit a bang, but discard it
+-- Input type has already been kind-checked
 tcHsBangType (L _ (HsBangTy _ ty)) = tcHsKindedType ty
 tcHsBangType ty                    = tcHsKindedType ty
 
@@ -287,7 +303,7 @@ kcLiftedType ty = kc_check_lhs_type ty ekLifted
     
 ---------------------------
 kcTypeType :: LHsType Name -> TcM (LHsType Name)
--- The type ty must be a *type*, but it can be lifted or 
+-- The type ty must be a *type*, but it can be lifted or
 -- unlifted or an unboxed tuple.
 kcTypeType ty = kc_check_lhs_type ty ekOpen
 
@@ -297,6 +313,11 @@ kcArgs what tys kind
              | (ty,n) <- tys `zip` [1..] ]
 
 ---------------------------
+kcArgType :: LHsType Name -> TcM (LHsType Name)
+-- The type ty must be an *arg* *type* (lifted or unlifted)
+kcArgType ty = kc_check_lhs_type ty ekArg
+
+---------------------------
 kcCheckLHsType :: LHsType Name -> ExpKind -> TcM (LHsType Name)
 kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_check_lhs_type ty kind
 
@@ -333,7 +354,8 @@ kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind
 
 -- This is the general case: infer the kind and compare
 kc_check_hs_type ty exp_kind
-  = do	{ (ty', act_kind) <- kc_hs_type ty
+  = do	{ traceTc "kc_check_hs_type" (ppr ty)
+        ; (ty', act_kind) <- kc_hs_type ty
 		-- Add the context round the inner check only
 		-- because checkExpectedKind already mentions
 		-- 'ty' by name in any error message
@@ -361,7 +383,8 @@ kcLHsType ty = addKcTypeCtxt ty (kc_lhs_type ty)
 kc_lhs_type :: LHsType Name -> TcM (LHsType Name, TcKind)
 kc_lhs_type (L span ty)
   = setSrcSpan span $
-    do { (ty', kind) <- kc_hs_type ty
+    do { traceTc "kc_lhs_type" (ppr ty)
+       ; (ty', kind) <- kc_hs_type ty
        ; return (L span ty', kind) }
 
 -- kc_hs_type *returns* the kind of the type, rather than taking an expected
@@ -383,9 +406,7 @@ kc_hs_type (HsTyVar name)
   -- Special case for the unit tycon so it benefits from kind overloading
   | name == tyConName unitTyCon
   = kc_hs_type (HsTupleTy (HsBoxyTuple placeHolderKind) [])
-  | otherwise = do
-    kind <- kcTyVar name
-    return (HsTyVar name, kind)
+  | otherwise = kcTyVar name
 
 kc_hs_type (HsListTy ty) = do
     ty' <- kcLiftedType ty
@@ -396,13 +417,14 @@ kc_hs_type (HsPArrTy ty) = do
     return (HsPArrTy ty', liftedTypeKind)
 
 kc_hs_type (HsKindSig ty k) = do
-    ty' <- kc_check_lhs_type ty (EK k EkKindSig)
-    return (HsKindSig ty' k, k)
+    k' <- scDsLHsKind k
+    ty' <- kc_check_lhs_type ty (EK k' EkKindSig)
+    return (HsKindSig ty' k, k')
 
 kc_hs_type (HsTupleTy (HsBoxyTuple _) tys)
   = do { fact_tup_ok <- xoptM Opt_ConstraintKinds
        ; k <- if fact_tup_ok
-              then newKindVar
+              then newMetaKindVar
               else return liftedTypeKind
        ; tys' <- kcArgs (ptext (sLit "a tuple")) tys k
        ; return (HsTupleTy (HsBoxyTuple k) tys', k) }
@@ -421,10 +443,14 @@ kc_hs_type (HsFunTy ty1 ty2) = do
     ty2' <- kcTypeType ty2
     return (HsFunTy ty1' ty2', liftedTypeKind)
 
-kc_hs_type (HsOpTy ty1 op ty2) = do
-    op_kind <- addLocM kcTyVar op
-    ([ty1',ty2'], res_kind) <- kcApps op op_kind [ty1,ty2]
-    return (HsOpTy ty1' op ty2', res_kind)
+kc_hs_type (HsOpTy ty1 (_, l_op@(L loc op)) ty2) = do
+    (wop, op_kind) <- kcTyVar op
+    ([ty1',ty2'], res_kind) <- kcApps l_op op_kind [ty1,ty2]
+    let op' = case wop of
+                HsTyVar name -> (WpKiApps [], L loc name)
+                HsWrapTy wrap (HsTyVar name) -> (wrap, L loc name)
+                _ -> panic "kc_hs_type HsOpTy"
+    return (HsOpTy ty1' op' ty2', res_kind)
 
 kc_hs_type (HsAppTy ty1 ty2) = do
     let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
@@ -448,17 +474,22 @@ kc_hs_type (HsCoreTy ty)
 kc_hs_type (HsForAllTy exp tv_names context ty)
   = kcHsTyVars tv_names         $ \ tv_names' ->
     do	{ ctxt' <- kcHsContext context
-	; ty'   <- kcLiftedType ty
+	; (ty', k)  <- kc_lhs_type ty
 	     -- The body of a forall is usually a type, but in principle
 	     -- there's no reason to prohibit *unlifted* types.
 	     -- In fact, GHC can itself construct a function with an
 	     -- unboxed tuple inside a for-all (via CPR analyis; see 
-	     -- typecheck/should_compile/tc170)
+	     -- typecheck/should_compile/tc170).
+             --
+             -- Moreover in instance heads we get forall-types with
+             -- kind Constraint.  
 	     --
-	     -- Still, that's only for internal interfaces, which aren't
-	     -- kind-checked, so we only allow liftedTypeKind here
+	     -- Really we should check that it's a type of value kind
+             -- {*, Constraint, #}, but I'm not doing that yet
+             -- Example that should be rejected:  
+             --          f :: (forall (a:*->*). a) Int
 
-  	; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) }
+  	; return (HsForAllTy exp tv_names' ctxt' ty', k) }
 
 kc_hs_type (HsBangTy b ty)
   = do { (ty', kind) <- kc_lhs_type ty
@@ -482,6 +513,17 @@ kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type"	-- Eliminated by renamer
 kc_hs_type (HsDocTy ty _)
   = kc_hs_type (unLoc ty) 
 
+kc_hs_type (HsExplicitListTy _ tys) 
+  = do { ty_k_s <- mapM kc_lhs_type tys
+       ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s
+       ; return (HsExplicitListTy kind (map fst ty_k_s), mkListTy kind) }
+kc_hs_type (HsExplicitTupleTy _ tys) = do
+  ty_k_s <- mapM kc_lhs_type tys
+  return ( HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)
+         , mkTyConApp (tupleTyCon BoxedTuple (length tys)) (map snd ty_k_s))
+
+kc_hs_type (HsWrapTy {}) = panic "kc_hs_type HsWrapTy"  -- it means we kind checked something twice
+
 ---------------------------
 kcApps :: Outputable a
        => a 
@@ -526,16 +568,42 @@ kcHsLPredType :: LHsType Name -> TcM (LHsType Name)
 kcHsLPredType pred = kc_check_lhs_type pred ekConstraint
 
 ---------------------------
-kcTyVar :: Name -> TcM TcKind
-kcTyVar name = do	-- Could be a tyvar or a tycon
-    traceTc "lk1" (ppr name)
-    thing <- tcLookup name
-    traceTc "lk2" (ppr name <+> ppr thing)
-    case thing of 
-        ATyVar _ ty             -> return (typeKind ty)
-        AThing kind             -> return kind
-        AGlobal (ATyCon tc)     -> return (tyConKind tc)
-        _                       -> wrongThingErr "type" thing name
+kcTyVar :: Name -> TcM (HsType Name, TcKind)
+-- See Note [Type checking recursive type and class declarations]
+-- in TcTyClsDecls
+kcTyVar name         -- Could be a tyvar, a tycon, or a datacon
+  = do { traceTc "lk1" (ppr name)
+       ; thing <- tcLookup name
+       ; traceTc "lk2" (ppr name <+> ppr thing)
+       ; case thing of
+           ATyVar _ ty           -> wrap_mono (typeKind ty)
+           AThing kind           -> wrap_poly kind
+           AGlobal (ATyCon tc)   -> wrap_poly (tyConKind tc)
+           AGlobal (ADataCon dc) -> kcDataCon dc >>= wrap_poly
+           _                     -> wrongThingErr "type" thing name }
+  where
+    wrap_mono kind = do { traceTc "lk3" (ppr name <+> dcolon <+> ppr kind)
+                        ; return (HsTyVar name, kind) }
+    wrap_poly kind
+      | null kvs = wrap_mono kind
+      | otherwise
+      = do { traceTc "lk4" (ppr name <+> dcolon <+> ppr kind)
+           ; kvs' <- mapM (const newMetaKindVar) kvs
+           ; let ki = substKiWith kvs kvs' ki_body
+           ; return (HsWrapTy (WpKiApps kvs') (HsTyVar name), ki) }
+      where (kvs, ki_body) = splitForAllTys kind
+
+-- IA0_TODO: this function should disapear, and use the dcPromoted field of DataCon
+kcDataCon :: DataCon -> TcM TcKind
+kcDataCon dc = do
+  let ty = dataConUserType dc
+  unless (isPromotableType ty) $ promoteErr dc ty
+  let ki = promoteType ty
+  traceTc "prm" (ppr ty <+> ptext (sLit "~~>") <+> ppr ki)
+  return ki
+  where
+    promoteErr dc ty = failWithTc (quotes (ppr dc) <+> ptext (sLit "of type")
+      <+> quotes (ppr ty) <+> ptext (sLit "is not promotable"))
 
 kcClass :: Name -> TcM TcKind
 kcClass cls = do	-- Must be a class
@@ -554,22 +622,51 @@ kcClass cls = do	-- Must be a class
 %*									*
 %************************************************************************
 
-The type desugarer
-
-	* Transforms from HsType to Type
-	* Zonks any kinds
-
-It cannot fail, and does no validity checking, except for 
-structural matters, such as
+Note [Desugaring types]
+~~~~~~~~~~~~~~~~~~~~~~~
+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:
+
+  * It transforms from HsType to Type
+
+  * It zonks any kinds.  The returned type should have no mutable kind
+    or type variables (hence returning Type not TcType):
+      - any unconstrained kind variables are defaulted to AnyK just 
+        as in TcHsSyn. 
+      - there are no mutable type variables because we are 
+        kind-checking a type
+    Reason: the returned type may be put in a TyCon or DataCon where
+    it will never subsequently be zonked.
+
+You might worry about nested scopes:
+        ..a:kappa in scope..
+            let f :: forall b. T '[a,b] -> Int
+In this case, f's type could have a mutable kind variable kappa in it;
+and we might then default it to AnyK when dealing with f's type
+signature.  But we don't expect this to happen because we can't get a
+lexically scoped type variable with a mutable kind variable in it.  A
+delicate point, this.  If it becomes an issue we might need to
+distinguish top-level from nested uses.
+
+Moreover
+  * it cannot fail, 
+  * it does no unifications
+  * it does no validity checking, except for structural matters, such as
 	(a) spurious ! annotations.
 	(b) a class used as a type
 
 \begin{code}
+
+zonkTcKindToKind :: TcKind -> TcM Kind
+-- When zonking a TcKind to a kind we instantiate kind variables to AnyK
+zonkTcKindToKind = zonkType (mkZonkTcTyVar (\ _ -> return anyKind) mkTyVarTy)
+
 dsHsType :: LHsType Name -> TcM Type
 -- All HsTyVarBndrs in the intput type are kind-annotated
+-- See Note [Desugaring types]
 dsHsType ty = ds_type (unLoc ty)
 
 ds_type :: HsType Name -> TcM Type
+-- See Note [Desugaring types]
 ds_type ty@(HsTyVar _)
   = ds_app ty []
 
@@ -599,7 +696,10 @@ ds_type (HsTupleTy hs_con tys) = do
     con <- case hs_con of
         HsUnboxedTuple -> return UnboxedTuple
         HsBoxyTuple kind -> do
-          kind' <- zonkTcKindToKind kind
+          -- Here we use zonkTcKind instead of zonkTcKindToKind because pairs
+          -- are a special case: we use them both for types (eg. (Int, Bool))
+          -- and for constraints (eg. (Show a, Eq a))
+          kind' <- zonkTcKind kind
           case () of
             _ | kind' `eqKind` constraintKind -> return ConstraintTuple
             _ | kind' `eqKind` liftedTypeKind -> return BoxedTuple
@@ -615,10 +715,8 @@ ds_type (HsFunTy ty1 ty2) = do
     tau_ty2 <- dsHsType ty2
     return (mkFunTy tau_ty1 tau_ty2)
 
-ds_type (HsOpTy ty1 (L span op) ty2) = do
-    tau_ty1 <- dsHsType ty1
-    tau_ty2 <- dsHsType ty2
-    setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2])
+ds_type (HsOpTy ty1 (wrap, (L span op)) ty2) =
+    setSrcSpan span (ds_app (HsWrapTy wrap (HsTyVar op)) [ty1,ty2])
 
 ds_type ty@(HsAppTy _ _)
   = ds_app ty []
@@ -633,7 +731,7 @@ ds_type (HsEqTy ty1 ty2) = do
     return (mkEqPred (tau_ty1, tau_ty2))
 
 ds_type (HsForAllTy _ tv_names ctxt ty)
-  = tcTyVarBndrs tv_names               $ \ tyvars -> do
+  = tcTyVarBndrsKindGen tv_names $ \ tyvars -> do
     theta <- mapM dsHsType (unLoc ctxt)
     tau <- dsHsType ty
     return (mkSigmaTy tyvars theta tau)
@@ -642,16 +740,51 @@ ds_type (HsDocTy ty _)  -- Remove the doc comment
   = dsHsType ty
 
 ds_type (HsSpliceTy _ _ kind) 
-  = do { kind' <- zonkTcKindToKind kind
+  = do { kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) 
+                           kind
+                     -- See Note [Kind of a type splice]
        ; newFlexiTyVarTy kind' }
 
 ds_type (HsQuasiQuoteTy {}) = panic "ds_type"	-- Eliminated by renamer
 ds_type (HsCoreTy ty)       = return ty
 
+ds_type (HsExplicitListTy kind tys) = do
+  kind' <- zonkTcKindToKind kind
+  ds_tys <- mapM dsHsType tys
+  return $
+   foldr (\a b -> mkTyConApp (buildPromotedDataTyCon consDataCon) [kind', a, b])
+         (mkTyConApp (buildPromotedDataTyCon nilDataCon) [kind']) ds_tys
+
+ds_type (HsExplicitTupleTy kis tys) = do
+  MASSERT( length kis == length tys )
+  kis' <- mapM zonkTcKindToKind kis
+  tys' <- mapM dsHsType tys
+  return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys')
+
+ds_type (HsWrapTy (WpKiApps kappas) ty) = do
+  tau <- ds_type ty
+  kappas' <- mapM zonkTcKindToKind kappas
+  return (mkAppTys tau kappas')
+
 dsHsTypes :: [LHsType Name] -> TcM [Type]
 dsHsTypes arg_tys = mapM dsHsType arg_tys
 \end{code}
 
+Note [Kind of a type splice]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider these terms, each with TH type splice inside:
+     [| e1 :: Maybe $(..blah..) |]
+     [| e2 :: $(..blah..) |]
+When kind-checking the type signature, we'll kind-check the splice
+$(..blah..); we want to give it a kind that can fit in any context,
+as if $(..blah..) :: forall k. k.  
+
+In the e1 example, the context of the splice fixes kappa to *.  But
+in the e2 example, we'll desugar the type, zonking the kind unification
+variables as we go.  When we encournter the unconstrained kappa, we
+want to default it to '*', not to AnyK.
+
+
 Help functions for type applications
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -668,15 +801,22 @@ ds_app ty tys = do
                           return (mkAppTys fun_ty arg_tys)
 
 ds_var_app :: Name -> [Type] -> TcM Type
-ds_var_app name arg_tys = do
-    thing <- tcLookup name
-    case thing of
-	ATyVar _ ty         -> return (mkAppTys ty arg_tys)
-	AGlobal (ATyCon tc) -> return (mkTyConApp tc arg_tys)
-	_                   -> wrongThingErr "type" thing name
-\end{code}
+-- See Note [Type checking recursive type and class declarations]
+-- in TcTyClsDecls
+ds_var_app name arg_tys 
+  | isTvNameSpace (rdrNameSpace (nameRdrName name))
+  = do { thing <- tcLookup name
+       ; case thing of
+           ATyVar _ ty -> return (mkAppTys ty arg_tys)
+	   _           -> wrongThingErr "type" thing name }
+
+  | otherwise
+  = do { thing <- tcLookupGlobal name
+       ; case thing of
+           ATyCon tc   -> return (mkTyConApp tc arg_tys)
+           ADataCon dc -> return (mkTyConApp (buildPromotedDataTyCon dc) arg_tys) 
+	   _           -> wrongThingErr "type" (AGlobal thing) name }
 
-\begin{code}
 addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a
 	-- Wrap a context around only if we want to show that contexts.  
 	-- Omit invisble ones and ones user's won't grok
@@ -692,6 +832,20 @@ typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty)
 %*									*
 %************************************************************************
 
+Note [Kind-checking kind-polymorphic types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+  f :: forall (f::k -> *) a. f a -> Int
+
+Here, the [LHsTyVarBndr Name] of the forall type will be [f,a], where
+  a is a  UserTyVar   -> type variable without kind annotation
+  f is a  KindedTyVar -> type variable with kind annotation
+
+If were were to allow binding sites for kind variables, thus
+  f :: forall @k (f :: k -> *) a. f a -> Int
+then we'd also need
+  k is a   UserKiVar   -> kind variable (they don't need annotation,
+                          since we only have BOX for a super kind)
 
 \begin{code}
 kcHsTyVars :: [LHsTyVarBndr Name] 
@@ -703,33 +857,141 @@ kcHsTyVars tvs thing_inside
        ; tcExtendKindEnvTvs kinded_tvs thing_inside }
 
 kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name)
-	-- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it	
-kcHsTyVar (UserTyVar name _)  = UserTyVar name <$> newKindVar
-kcHsTyVar tv@(KindedTyVar {}) = return tv
+-- Return a *kind-annotated* binder, whose PostTcKind is
+-- initialised with a kind variable.
+-- Typically the Kind inside the KindedTyVar will be a tyvar with a mutable kind 
+-- in it. We aren't yet sure whether the binder is a *type* variable or a *kind*
+-- variable. See Note [Kind-checking kind-polymorphic types]
+--
+-- If the variable is already in scope return it, instead of introducing a new
+-- one. This can occur in 
+--   instance C (a,b) where
+--     type F (a,b) c = ...
+-- Here a,b will be in scope when processing the associated type instance for F.
+kcHsTyVar tyvar = do in_scope <- getInLocalScope
+                     if in_scope (hsTyVarName tyvar)
+                      then do inscope_tyvar <- tcLookupTyVar (hsTyVarName tyvar)
+                              return (UserTyVar (tyVarName inscope_tyvar)
+                                (tyVarKind inscope_tyvar)) 
+                       else kcHsTyVar' tyvar
+    where
+        kcHsTyVar' (UserTyVar name _)        = UserTyVar name <$> newMetaKindVar
+        kcHsTyVar' (KindedTyVar name kind _) = do
+          kind' <- scDsLHsKind kind
+          return (KindedTyVar name kind kind')
 
 ------------------
-tcTyVarBndrs :: [LHsTyVarBndr Name] 	-- Kind-annotated binders, which need kind-zonking
-	     -> ([TyVar] -> TcM r)
-	     -> TcM r
+tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking
+             -> ([TyVar] -> TcM r)
+             -> TcM r
 -- Used when type-checking types/classes/type-decls
 -- Brings into scope immutable TyVars, not mutable ones that require later zonking
+-- Fix #5426: avoid abstraction over kinds containing # or (#)
 tcTyVarBndrs bndrs thing_inside = do
-    tyvars <- mapM (zonk . unLoc) bndrs
+    tyvars <- mapM (zonk . hsTyVarNameKind . unLoc) bndrs
     tcExtendTyVarEnv tyvars (thing_inside tyvars)
   where
-    zonk (UserTyVar name kind) = do { kind' <- zonkTcKindToKind kind
-				    ; return (mkTyVar name kind') }
-    zonk (KindedTyVar name kind) = return (mkTyVar name kind)
+    zonk (name, kind)
+      = do { kind' <- zonkTcKind kind
+           ; checkTc (noHashInKind kind') (ptext (sLit "Kind signature contains # or (#)"))
+           ; return (mkTyVar name kind') }
+
+tcTyVarBndrsKindGen :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM r) -> TcM r
+-- tcTyVarBndrsKindGen [(f :: ?k -> *), (a :: ?k)] thing_inside
+-- calls thing_inside with [(k :: BOX), (f :: k -> *), (a :: k)]
+tcTyVarBndrsKindGen bndrs thing_inside
+  = do { let kinds = map (hsTyVarKind . unLoc) bndrs
+       ; (kvs, zonked_kinds) <- kindGeneralizeKinds kinds
+       ; let tyvars = zipWith mkTyVar (map hsLTyVarName bndrs) zonked_kinds
+             ktvs = kvs ++ tyvars     -- See Note [Kinds of quantified type variables]
+       ; traceTc "tcTyVarBndrsKindGen" (ppr (bndrs, kvs, tyvars))
+       ; tcExtendTyVarEnv ktvs (thing_inside ktvs) }
+\end{code}
+
+Note [Kinds of quantified type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcTyVarBndrsKindGen quantifies over a specified list of type variables,
+*and* over the kind variables mentioned in the kinds of those tyvars.
+
+Note that we must zonk those kinds (obviously) but less obviously, we
+must return type variables whose kinds are zonked too. Example
+    (a :: k7)  where  k7 := k9 -> k9
+We must return
+    [k9, a:k9->k9]
+and NOT 
+    [k9, a:k7]
+Reason: we're going to turn this into a for-all type, 
+   forall k9. forall (a:k7). blah
+which the type checker will then instantiate, and instantiate does not
+look through unification variables!  
+
+Hence using zonked_kinds when forming 'tyvars'.
+
+\begin{code}
+tcTyClTyVars :: Name -> [LHsTyVarBndr Name]	-- LHS of the type or class decl
+             -> ([TyVar] -> Kind -> TcM a) -> TcM a
+-- tcTyClTyVars T [a,b] calls thing_inside with
+-- [k1,k2,a,b] (k2 -> *)  where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> *
+--
+-- No need to freshen the k's because they are just skolem 
+-- constants here, and we are at top level anyway.
+tcTyClTyVars tycon tyvars thing_inside
+  = do { thing <- tcLookup tycon
+       ; let { kind =
+                 case thing of
+                   AThing kind -> kind
+                   _ -> panic "tcTyClTyVars"
+                     -- We only call tcTyClTyVars during typechecking in
+                     -- TcTyClDecls, where the local env is extended with
+                     -- the generalized_env (mapping Names to AThings).
+             ; (kvs, body) = splitForAllTys kind
+             ; (kinds, res) = splitKindFunTysN (length names) body
+             ; names = hsLTyVarNames tyvars
+             ; tvs = zipWith mkTyVar names kinds
+             ; all_vs = kvs ++ tvs }
+       ; tcExtendTyVarEnv all_vs (thing_inside all_vs res) }
+
+-- Used when generalizing binders and type family patterns
+-- It takes a kind from the type checker (like `k0 -> *`), and returns the 
+-- final, kind-generalized kind (`forall k::BOX. k -> *`)
+kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind])
+-- INVARIANT: the returned kinds are zonked, and
+--            mention the returned kind variables
+kindGeneralizeKinds kinds 
+  = do { -- Quantify over kind variables free in
+         -- the kinds, and *not* in the environment
+       ; zonked_kinds <- mapM zonkTcKind kinds
+       ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked
+       ; let kvs_to_quantify = tyVarsOfTypes zonked_kinds 
+                               `minusVarSet` gbl_tvs
+
+       ; kvs <- ASSERT2 (all isKiVar (varSetElems kvs_to_quantify), ppr kvs_to_quantify)
+                zonkQuantifiedTyVars kvs_to_quantify
+
+         -- Zonk the kinds again, to pick up either the kind 
+         -- variables we quantify over, or *, depending on whether
+         -- zonkQuantifiedTyVars decided to generalise (which in
+         -- turn depends on PolyKinds)
+       ; final_kinds <- mapM zonkTcKind zonked_kinds
+
+       ; traceTc "generalizeKind" (    ppr kinds <+> ppr kvs_to_quantify
+                                   <+> ppr kvs   <+> ppr final_kinds)
+       ; return (kvs, final_kinds) }
+
+kindGeneralizeKind :: TcKind -> TcM ( [KindVar]  -- these were flexi kind vars
+                                    , Kind )     -- this is the old kind where flexis got zonked
+kindGeneralizeKind kind = do
+  (kvs, [kind']) <- kindGeneralizeKinds [kind]
+  return (kvs, kind')
 
 -----------------------------------
-tcDataKindSig :: Maybe Kind -> TcM [TyVar]
+tcDataKindSig :: Kind -> TcM [TyVar]
 -- GADT decls can have a (perhaps partial) kind signature
 --	e.g.  data T :: * -> * -> * where ...
 -- This function makes up suitable (kinded) type variables for 
 -- the argument kinds, and checks that the result kind is indeed *.
 -- We use it also to make up argument type variables for for data instances.
-tcDataKindSig Nothing = return []
-tcDataKindSig (Just kind)
+tcDataKindSig kind
   = do	{ checkTc (isLiftedTypeKind res_kind) (badKindSig kind)
 	; span <- getSrcSpanM
 	; us   <- newUniqueSupply 
@@ -932,12 +1194,22 @@ data EkCtxt  = EkUnk		-- Unknown context
              | EkIParam         -- Implicit parameter type
              | EkFamInst        -- Family instance
 
+instance Outputable ExpKind where
+  ppr (EK k _) = ptext (sLit "Expected kind:") <+> ppr k
 
-ekLifted, ekOpen, ekConstraint :: ExpKind
+ekLifted, ekOpen, ekArg, ekConstraint :: ExpKind
 ekLifted     = EK liftedTypeKind EkUnk
 ekOpen       = EK openTypeKind   EkUnk
+ekArg        = EK argTypeKind    EkUnk
 ekConstraint = EK constraintKind EkUnk
 
+unifyKinds :: SDoc -> [(LHsType Name, TcKind)] -> TcM TcKind
+unifyKinds fun act_kinds = do
+  kind <- newMetaKindVar
+  let exp_kind arg_no = EK kind (EkArg fun arg_no)
+  mapM_ (\(arg_no, (ty, act_kind)) -> checkExpectedKind ty act_kind (exp_kind arg_no)) (zip [1..] act_kinds)
+  return kind
+
 checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM ()
 -- A fancy wrapper for 'unifyKind', which tries
 -- to give decent error messages.
@@ -945,8 +1217,9 @@ checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM ()
 -- checks that the actual kind act_kind is compatible
 --      with the expected kind exp_kind
 -- The first argument, ty, is used only in the error message generation
-checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do
-    (_errs, mb_r) <- tryTc (unifyKind exp_kind act_kind)
+checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do
+    traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr ek)
+    (_errs, mb_r) <- tryTc (unifyKind act_kind exp_kind)
     case mb_r of
         Just _  -> return ()  -- Unification succeeded
         Nothing -> do
@@ -962,8 +1235,8 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do
                n_exp_as = length exp_as
                n_act_as = length act_as
 
-               (env1, tidy_exp_kind) = tidyKind env0 exp_kind
-               (env2, tidy_act_kind) = tidyKind env1 act_kind
+               (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind
+               (env2, tidy_act_kind) = tidyOpenKind env1 act_kind
 
                err | n_exp_as < n_act_as     -- E.g. [Maybe]
                    = quotes (ppr ty) <+> ptext (sLit "is not applied to enough type arguments")
@@ -1005,6 +1278,100 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do
 \end{code}
 
 %************************************************************************
+%*                                                                      *
+        Sort checking kinds
+%*                                                                      *
+%************************************************************************
+
+scDsLHsKind converts a user-written kind to an internal, sort-checked kind.
+It does sort checking and desugaring at the same time, in one single pass.
+It fails when the kinds are not well-formed (eg. data A :: * Int), or if there
+are non-promotable or non-fully applied kinds.
+
+\begin{code}
+scDsLHsKind :: LHsKind Name -> TcM Kind
+scDsLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $
+                  sc_ds_lhs_kind k
+
+scDsLHsMaybeKind :: Maybe (LHsKind Name) -> TcM (Maybe Kind)
+scDsLHsMaybeKind Nothing  = return Nothing
+scDsLHsMaybeKind (Just k) = do k' <- scDsLHsKind k
+                               return (Just k')
+
+sc_ds_lhs_kind :: LHsKind Name -> TcM Kind
+sc_ds_lhs_kind (L span ki) = setSrcSpan span (sc_ds_hs_kind ki)
+
+-- The main worker
+sc_ds_hs_kind :: HsKind Name -> TcM Kind
+sc_ds_hs_kind k@(HsTyVar _)   = sc_ds_app k []
+sc_ds_hs_kind k@(HsAppTy _ _) = sc_ds_app k []
+
+sc_ds_hs_kind (HsParTy ki) = sc_ds_lhs_kind ki
+
+sc_ds_hs_kind (HsFunTy ki1 ki2) =
+  do kappa_ki1 <- sc_ds_lhs_kind ki1
+     kappa_ki2 <- sc_ds_lhs_kind ki2
+     return (mkArrowKind kappa_ki1 kappa_ki2)
+
+sc_ds_hs_kind (HsListTy ki) =
+  do kappa <- sc_ds_lhs_kind ki
+     checkWiredInTyCon listTyCon
+     return $ mkListTy kappa
+
+sc_ds_hs_kind (HsTupleTy _ kis) =
+  do kappas <- mapM sc_ds_lhs_kind kis
+     checkWiredInTyCon tycon
+     return $ mkTyConApp tycon kappas
+  where tycon = tupleTyCon BoxedTuple (length kis)
+
+-- Argument not kind-shaped
+sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k)
+
+-- Special case for kind application
+sc_ds_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
+sc_ds_app (HsAppTy ki1 ki2) kis = sc_ds_app (unLoc ki1) (ki2:kis)
+sc_ds_app (HsTyVar tc)      kis =
+  do arg_kis <- mapM sc_ds_lhs_kind kis
+     sc_ds_var_app tc arg_kis
+sc_ds_app ki                _   = failWithTc (quotes (ppr ki) <+> 
+                                    ptext (sLit "is not a kind constructor"))
+
+-- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar
+sc_ds_var_app :: Name -> [Kind] -> TcM Kind
+-- Special case for * and Constraint kinds
+sc_ds_var_app name arg_kis
+  |    name == liftedTypeKindTyConName
+    || name == constraintKindTyConName = do
+    unless (null arg_kis)
+      (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied"))
+    thing <- tcLookup name
+    case thing of
+      AGlobal (ATyCon tc) -> return (mkTyConApp tc [])
+      _                   -> panic "sc_ds_var_app 1"
+
+-- General case
+sc_ds_var_app name arg_kis = do
+  thing <- tcLookup name
+  case thing of
+    AGlobal (ATyCon tc)
+      | isAlgTyCon tc || isTupleTyCon tc -> do
+      poly_kinds <- xoptM Opt_PolyKinds
+      unless poly_kinds $ addErr (polyKindsErr name)
+      let tc_kind = tyConKind tc
+      case isPromotableKind tc_kind of
+        Just n | n == length arg_kis ->
+          return (mkTyConApp (mkPromotedTypeTyCon tc) arg_kis)
+        Just _  -> err tc_kind "is not fully applied"
+        Nothing -> err tc_kind "is not promotable"
+
+    _ -> wrongThingErr "promoted type" thing name
+
+  where err k m = failWithTc (    quotes (ppr name) <+> ptext (sLit "of kind")
+                              <+> quotes (ppr k)    <+> ptext (sLit m))
+
+\end{code}
+
+%************************************************************************
 %*									*
 		Scoped type variables
 %*									*
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 01bffce61d..837f3823ba 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -454,16 +454,15 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
                   badBootDeclErr
 
-        ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
-        ; checkValidInstance poly_ty tyvars theta clas inst_tys
+        ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty
         ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
 
         -- Next, process any associated types.
         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
         ; idx_tycons0 <- tcExtendTyVarEnv tyvars $
-                        mapAndRecoverM (tcAssocDecl clas mini_env) ats
+                         mapAndRecoverM (tcAssocDecl clas mini_env) ats
 
-        -- Check for misssing associated types and build them
+        -- Check for missing associated types and build them
         -- from their defaults (if available)
         ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats
               check_at_instance (fam_tc, defs)
@@ -473,7 +472,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
                 | null defs                                  = return (Just (tyConName fam_tc), [])
                  -- No user instance, have defaults ==> instatiate them
                 | otherwise = do
-                    defs' <- forM defs $ \(ATD tvs pat_tys rhs) -> do
+                    defs' <- forM defs $ \(ATD tvs pat_tys rhs _loc) -> do
                       let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env
                           tvs' = varSetElems (tyVarsOfType rhs')
                           pat_tys' = substTys mini_env_subst pat_tys
@@ -526,6 +525,7 @@ tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM TyCon
 tcFamInstDecl top_lvl decl
   = do { -- type family instances require -XTypeFamilies
          -- and can't (currently) be in an hs-boot file
+       ; traceTc "tcFamInstDecl" (ppr decl)
        ; let fam_tc_lname = tcdLName decl
        ; type_families <- xoptM Opt_TypeFamilies
        ; is_boot <- tcIsHsBoot   -- Are we compiling an hs-boot file?
@@ -551,13 +551,8 @@ tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon
 
   -- "type instance"
 tcFamInstDecl1 fam_tc (decl@TySynonym {})
-  = kcFamTyPats decl $ \k_tvs k_typats resKind ->
-    do { -- kind check the right-hand side of the type equation
-       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
-                  -- ToDo: the ExpKind could be better
-
-         -- (1) do the work of verifying the synonym
-       ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc (decl { tcdTyVars = k_tvs, tcdTyPats = Just k_typats, tcdSynRhs = k_rhs })
+  = do { -- (1) do the work of verifying the synonym
+       ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl
 
          -- (2) check the well-formedness of the instance
        ; checkValidFamInst t_typats t_rhs
@@ -571,59 +566,50 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {})
        }
 
   -- "newtype instance" and "data instance"
-tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data
-                                   , tcdCons = cons})
-  = kcFamTyPats decl $ \k_tvs k_typats resKind ->
-    do { -- check that the family declaration is for the right kind
+tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt
+                                   , tcdTyVars = tvs, tcdTyPats = Just pats
+                                  , tcdCons = cons})
+  = do { -- Check that the family declaration is for the right kind
          checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
-       ; -- (1) kind check the data declaration as usual
-       ; k_decl <- kcDataDecl decl k_tvs
-       ; let k_ctxt = tcdCtxt k_decl
-             k_cons = tcdCons k_decl
-
-         -- result kind must be '*' (otherwise, we have too few patterns)
-       ; resKind' <- zonkTcKindToKind resKind -- Remember: kcFamTyPats supplies unzonked kind!
-       ; checkTc (isLiftedTypeKind resKind') $ tooFewParmsErr (tyConArity fam_tc)
-
-         -- (2) type check indexed data type declaration
-       ; tcTyVarBndrs k_tvs $ \t_tvs -> do   -- turn kinded into proper tyvars
+         -- Kind check type patterns
+       ; tcFamTyPats fam_tc tvs pats (\_always_star -> kcDataDecl decl) $ 
+           \tvs' pats' resultKind -> do
 
-         -- kind check the type indexes and the context
-       { t_typats     <- mapM tcHsKindedType k_typats
-       ; stupid_theta <- tcHsKindedContext k_ctxt
+         -- Check that left-hand side contains no type family applications
+         -- (vanilla synonyms are fine, though, and we checked for
+         -- foralls earlier)
+       { mapM_ checkTyFamFreeness pats'
+         
+         -- Result kind must be '*' (otherwise, we have too few patterns)
+       ; checkTc (isLiftedTypeKind resultKind) $ tooFewParmsErr (tyConArity fam_tc)
 
-         -- (3) Check that
-         --     (a) left-hand side contains no type family applications
-         --         (vanilla synonyms are fine, though, and we checked for
-         --         foralls earlier)
-       ; mapM_ checkTyFamFreeness t_typats
+       ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt
+       ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons
 
-       ; dataDeclChecks (tcdName decl) new_or_data stupid_theta k_cons
-
-         -- (4) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats
+         -- Construct representation tycon
+       ; rep_tc_name <- newFamInstTyConName (tcdLName decl) pats'
        ; let ex_ok = True       -- Existentials ok for type families!
        ; fixM (\ rep_tycon -> do
-             { let orig_res_ty = mkTyConApp fam_tc t_typats
-             ; data_cons <- tcConDecls ex_ok rep_tycon
-                                       (t_tvs, orig_res_ty) k_cons
+             { let orig_res_ty = mkTyConApp fam_tc pats'
+             ; data_cons <- tcConDecls new_or_data ex_ok rep_tycon
+                                       (tvs', orig_res_ty) cons
              ; tc_rhs <-
                  case new_or_data of
                    DataType -> return (mkDataTyConRhs data_cons)
                    NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
-             ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
-                             h98_syntax NoParentTyCon (Just (fam_tc, t_typats))
+             ; buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs Recursive
+                             h98_syntax NoParentTyCon (Just (fam_tc, pats'))
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
                  -- dependency.  (2) They are always valid loop breakers as
                  -- they involve a coercion.
              })
-       }}
-       where
+       } }
+    where
          h98_syntax = case cons of      -- All constructors have same shape
                         L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
                         _ -> True
@@ -644,9 +630,9 @@ tcAssocDecl clas mini_env (L loc decl)
   
        -- Check that the associated type comes from this class
        ; checkTc (Just clas == tyConAssoc_maybe fam_tc)
-                 (badATErr clas (tyConName at_tc))
+                 (badATErr (className clas) (tyConName at_tc))
 
-       -- See Note [Checking consistent instantiation]
+       -- See Note [Checking consistent instantiation] in TcTyClsDecls
        ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys
 
        ; return at_tc }
@@ -914,7 +900,7 @@ tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
   = addErrCtxt (spec_ctxt prag) $
     do  { let name = idName dfun_id
-        ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
+        ; (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
         ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
 
         ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 8258036b95..f0e1a4ddbe 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -440,8 +440,9 @@ trySpontaneousEqOneWay d eqv gw tv xi
   | not (isSigTyVar tv) || isTyVarTy xi 
   = do { let kxi = typeKind xi -- NB: 'xi' is fully rewritten according to the inerts 
                                -- so we have its more specific kind in our hands
-       ; if kxi `isSubKind` tyVarKind tv then
-             solveWithIdentity d eqv gw tv xi
+       ; is_sub_kind <- kxi `isSubKindTcS` tyVarKind tv
+       ; if is_sub_kind then
+             solveWithIdentity eqv gw tv xi
          else return SPCantSolve
        }
   | otherwise -- Still can't solve, sig tyvar and non-variable rhs
@@ -451,17 +452,34 @@ trySpontaneousEqOneWay d eqv gw tv xi
 trySpontaneousEqTwoWay :: SubGoalDepth 
                        -> EqVar -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult
 -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here
-trySpontaneousEqTwoWay d eqv gw tv1 tv2
-  | k1 `isSubKind` k2
-  , nicer_to_update_tv2 = solveWithIdentity d eqv gw tv2 (mkTyVarTy tv1)
-  | k2 `isSubKind` k1 
-  = solveWithIdentity d eqv gw tv1 (mkTyVarTy tv2)
-  | otherwise -- None is a subkind of the other, but they are both touchable! 
-  = return SPCantSolve
+
+trySpontaneousEqTwoWay eqv gw tv1 tv2
+  = do { k1_sub_k2 <- k1 `isSubKindTcS` k2
+       ; if k1_sub_k2 && nicer_to_update_tv2
+         then solveWithIdentity eqv gw tv2 (mkTyVarTy tv1)
+         else do
+       { k2_sub_k1 <- k2 `isSubKindTcS` k1
+       ; MASSERT( k2_sub_k1 )  -- they were unified in TcCanonical
+       ; solveWithIdentity eqv gw tv1 (mkTyVarTy tv2) } }
   where
     k1 = tyVarKind tv1
     k2 = tyVarKind tv2
     nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
+{-
+-- Previous code below (before kind polymorphism and unification):
+  -- | k1 `isSubKind` k2
+  -- , nicer_to_update_tv2 = solveWithIdentity eqv gw tv2 (mkTyVarTy tv1)
+  -- | k2 `isSubKind` k1 
+  -- = solveWithIdentity eqv gw tv1 (mkTyVarTy tv2)
+  -- | otherwise -- None is a subkind of the other, but they are both touchable! 
+  -- = return SPCantSolve
+  --   -- do { addErrorTcS KindError gw (mkTyVarTy tv1) (mkTyVarTy tv2)
+  --   --   ; return SPError }
+  -- where
+  --   k1 = tyVarKind tv1
+  --   k2 = tyVarKind tv2
+  --   nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
+-}
 \end{code}
 
 Note [Kind errors] 
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index dc8347f88a..d3db194d1f 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -24,7 +24,7 @@ module TcMType (
   newFlexiTyVar,
   newFlexiTyVarTy,		-- Kind -> TcM TcType
   newFlexiTyVarTys,		-- Int -> Kind -> TcM [TcType]
-  newKindVar, newKindVars, 
+  newMetaKindVar, newMetaKindVars,
   mkTcTyVarName,
 
   newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
@@ -42,13 +42,15 @@ module TcMType (
   -- Instantiation
   tcInstTyVars, tcInstSigTyVars,
   tcInstType, 
-  tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType,
+  tcInstSkolTyVars, tcInstSuperSkolTyVars,
+  tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX,
+  tcInstSkolTyVar, tcInstSkolType,
   tcSkolDFunType, tcSuperSkolTyVars,
 
   --------------------------------
   -- Checking type validity
   Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
-  SourceTyCtxt(..), checkValidTheta, 
+  checkValidTheta, 
   checkValidInstHead, checkValidInstance, validDerivPred,
   checkInstTermination, checkValidFamInst, checkTyFamFreeness, 
   arityErr, 
@@ -56,20 +58,20 @@ module TcMType (
 
   --------------------------------
   -- Zonking
-  zonkType, mkZonkTcTyVar, zonkTcPredType, 
+  zonkType, zonkKind, zonkTcPredType, 
   zonkTcTypeCarefully, skolemiseUnboundMetaTyVar,
   zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
   zonkQuantifiedTyVar, zonkQuantifiedTyVars,
   zonkTcType, zonkTcTypes, zonkTcThetaType,
-  zonkTcKindToKind, zonkTcKind, 
-  zonkCt, zonkCts,
+
+  zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts,
   zonkImplication, zonkEvVar, zonkWantedEvVar,
+
   zonkWC, zonkWantedEvVars,
   zonkTcTypeAndSubst,
   tcGetGlobalTyVars, 
 
-
-  readKindVar, writeKindVar
+  compatKindTcM, isSubKindTcM
   ) where
 
 #include "HsVersions.h"
@@ -78,6 +80,7 @@ module TcMType (
 import TypeRep
 import TcType
 import Type
+import Kind
 import Class
 import TyCon
 import Var
@@ -103,7 +106,7 @@ import Unique( Unique )
 import Bag
 
 import Control.Monad
-import Data.List        ( (\\) )
+import Data.List        ( (\\), partition, mapAccumL )
 \end{code}
 
 
@@ -114,13 +117,13 @@ import Data.List        ( (\\) )
 %************************************************************************
 
 \begin{code}
-newKindVar :: TcM TcKind
-newKindVar = do	{ uniq <- newUnique
+newMetaKindVar :: TcM TcKind
+newMetaKindVar = do	{ uniq <- newUnique
 		; ref <- newMutVar Flexi
-		; return (mkTyVarTy (mkKindVar uniq ref)) }
+		; return (mkTyVarTy (mkMetaKindVar uniq ref)) }
 
-newKindVars :: Int -> TcM [TcKind]
-newKindVars n = mapM (\ _ -> newKindVar) (nOfThem n ())
+newMetaKindVars :: Int -> TcM [TcKind]
+newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ())
 \end{code}
 
 
@@ -210,31 +213,48 @@ tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty
 tcSuperSkolTyVars :: [TyVar] -> [TcTyVar]
 -- Make skolem constants, but do *not* give them new names, as above
 -- Moreover, make them "super skolems"; see comments with superSkolemTv
-tcSuperSkolTyVars tyvars
-  = [ mkTcTyVar (tyVarName tv) (tyVarKind tv) superSkolemTv
-    | tv <- tyvars ]
+-- see Note [Kind substitution when instantiating]
+-- Precondition: tyvars should be ordered (kind vars first)
+tcSuperSkolTyVars = snd . mapAccumL tcSuperSkolTyVar (mkTopTvSubst [])
+
+tcSuperSkolTyVar :: TvSubst -> TyVar -> (TvSubst, TcTyVar)
+tcSuperSkolTyVar subst tv
+  = (extendTvSubst subst tv (mkTyVarTy new_tv), new_tv)
+  where
+    kind   = substTy subst (tyVarKind tv)
+    new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv
 
-tcInstSkolTyVar :: Bool -> TyVar -> TcM TcTyVar
+tcInstSkolTyVar :: Bool -> TvSubst -> TyVar -> TcM (TvSubst, TcTyVar)
 -- Instantiate the tyvar, using 
---	* the occ-name and kind of the supplied tyvar, 
---	* the unique from the monad,
---	* the location either from the tyvar (skol_info = SigSkol)
+--      * the occ-name and kind of the supplied tyvar, 
+--      * the unique from the monad,
+--      * the location either from the tyvar (skol_info = SigSkol)
 --                     or from the monad (otherwise)
-tcInstSkolTyVar overlappable tyvar
-  = do	{ uniq <- newUnique
-        ; loc <-  getSrcSpanM
-	; let new_name = mkInternalName uniq occ loc
-        ; return (mkTcTyVar new_name kind (SkolemTv overlappable)) }
+tcInstSkolTyVar overlappable subst tyvar
+  = do  { uniq <- newUnique
+        ; loc  <- getSrcSpanM
+        ; let new_name = mkInternalName uniq occ loc
+              new_tv   = mkTcTyVar new_name kind (SkolemTv overlappable)
+        ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
   where
     old_name = tyVarName tyvar
     occ      = nameOccName old_name
-    kind     = tyVarKind tyvar
+    kind     = substTy subst (tyVarKind tyvar)
+
+tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
+-- Precondition: tyvars should be ordered (kind vars first)
+-- see Note [Kind substitution when instantiating]
+tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol)
 
-tcInstSkolTyVars :: [TyVar] -> TcM [TcTyVar]
-tcInstSkolTyVars tyvars = mapM (tcInstSkolTyVar False) tyvars
+-- Wrappers
+tcInstSkolTyVars, tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar]
+tcInstSkolTyVars      = fmap snd . tcInstSkolTyVars' False (mkTopTvSubst [])
+tcInstSuperSkolTyVars = fmap snd . tcInstSkolTyVars' True  (mkTopTvSubst [])
 
-tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar]
-tcInstSuperSkolTyVars tyvars = mapM (tcInstSkolTyVar True) tyvars
+tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX
+  :: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
+tcInstSkolTyVarsX      subst = tcInstSkolTyVars' False subst
+tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True  subst
 
 tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants
@@ -244,19 +264,37 @@ tcInstSkolType ty = tcInstType tcInstSkolTyVars ty
 tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar]
 -- Make meta SigTv type variables for patten-bound scoped type varaibles
 -- We use SigTvs for them, so that they can't unify with arbitrary types
-tcInstSigTyVars = mapM tcInstSigTyVar
-
-tcInstSigTyVar :: TyVar -> TcM TcTyVar
-tcInstSigTyVar tyvar
-  = do	{ uniq <- newMetaUnique
- 	; ref <- newMutVar Flexi
-        ; let name = setNameUnique (tyVarName tyvar) uniq
-   	        -- Use the same OccName so that the tidy-er 
-		-- doesn't rename 'a' to 'a0' etc
-	      kind = tyVarKind tyvar
-	; return (mkTcTyVar name kind (MetaTv SigTv ref)) }
+-- Precondition: tyvars should be ordered (kind vars first)
+-- see Note [Kind substitution when instantiating]
+tcInstSigTyVars = fmap snd . mapAccumLM tcInstSigTyVar (mkTopTvSubst [])
+
+tcInstSigTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar)
+tcInstSigTyVar subst tv
+  = do { uniq <- newMetaUnique
+       ; ref <- newMutVar Flexi
+       ; let name   = setNameUnique (tyVarName tv) uniq
+                      -- Use the same OccName so that the tidy-er
+                      -- doesn't rename 'a' to 'a0' etc
+             kind   = substTy subst (tyVarKind tv)
+             new_tv = mkTcTyVar name kind (MetaTv SigTv ref)
+       ; return (extendTvSubst subst tv (mkTyVarTy new_tv), new_tv) }
 \end{code}
 
+Note [Kind substitution when instantiating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we instantiate a bunch of kind and type variables, first we
+expect them to be sorted (kind variables first, then type variables).
+Then we have to instantiate the kind variables, build a substitution
+from old variables to the new variables, then instantiate the type
+variables substituting the original kind.
+
+Exemple: If we want to instantiate
+  [(k1 :: BOX), (k2 :: BOX), (a :: k1 -> k2), (b :: k1)]
+we want
+  [(?k1 :: BOX), (?k2 :: BOX), (?a :: ?k1 -> ?k2), (?b :: ?k1)]
+instead of the buggous
+  [(?k1 :: BOX), (?k2 :: BOX), (?a :: k1 -> k2), (?b :: k1)]
+
 
 %************************************************************************
 %*									*
@@ -282,6 +320,7 @@ mkTcTyVarName :: Unique -> FastString -> Name
 -- leaving the un-cluttered names free for user names
 mkTcTyVarName uniq str = mkSysTvName uniq str
 
+-- Works for both type and kind variables
 readMetaTyVar :: TyVar -> TcM MetaDetails
 readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
 		      readMutVar (metaTvRef tyvar)
@@ -305,6 +344,7 @@ isFlexiMetaTyVar tv
   | otherwise = return False
 
 --------------------
+-- Works with both type and kind variables
 writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
 -- Write into a currently-empty MetaTyVar
 
@@ -334,20 +374,27 @@ writeMetaTyVarRef tyvar ref ty
        ; writeMutVar ref (Indirect ty) }
 
 -- Everything from here on only happens if DEBUG is on
-  | not (isPredTy tv_kind)   -- Don't check kinds for updates to coercion variables
-  , not (ty_kind `isSubKind` tv_kind)
-  = WARN( True, hang (text "Ill-kinded update to meta tyvar")
-                   2 (ppr tyvar $$ ppr tv_kind $$ ppr ty $$ ppr ty_kind) )
-    return ()
-
   | otherwise
   = do { meta_details <- readMutVar ref; 
+       -- Zonk kinds to allow the error check to work
+       ; zonked_tv_kind <- zonkTcKind tv_kind 
+       ; zonked_ty_kind <- zonkTcKind ty_kind
+
+       -- Check for double updates
        ; ASSERT2( isFlexi meta_details, 
                   hang (text "Double update of meta tyvar")
                    2 (ppr tyvar $$ ppr meta_details) )
 
          traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
-       ; writeMutVar ref (Indirect ty) }
+       ; writeMutVar ref (Indirect ty) 
+       ; when (   not (isPredTy tv_kind) 
+                    -- Don't check kinds for updates to coercion variables
+               && not (zonked_ty_kind `isSubKind` zonked_tv_kind))
+       $ WARN( True, hang (text "Ill-kinded update to meta tyvar")
+                        2 (    ppr tyvar <+> text "::" <+> ppr tv_kind 
+                           <+> text ":=" 
+                           <+> ppr ty    <+> text "::" <+> ppr ty_kind) )
+         (return ()) }
   where
     tv_kind = tyVarKind tyvar
     ty_kind = typeKind ty
@@ -374,23 +421,26 @@ newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
 
 tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst)
 -- Instantiate with META type variables
-tcInstTyVars tyvars
-  = do	{ tc_tvs <- mapM tcInstTyVar tyvars
-	; let tys = mkTyVarTys tc_tvs
-	; return (tc_tvs, tys, zipTopTvSubst tyvars tys) }
-		-- Since the tyvars are freshly made,
-		-- they cannot possibly be captured by
-		-- any existing for-alls.  Hence zipTopTvSubst
-
-tcInstTyVar :: TyVar -> TcM TcTyVar
--- Make a new unification variable tyvar whose Name and Kind 
--- come from an existing TyVar
-tcInstTyVar tyvar
-  = do	{ uniq <- newMetaUnique
- 	; ref <- newMutVar Flexi
-        ; let name = mkSystemName uniq (getOccName tyvar)
-	      kind = tyVarKind tyvar
-	; return (mkTcTyVar name kind (MetaTv TauTv ref)) }
+tcInstTyVars tyvars = tcInstTyVarsX emptyTvSubst tyvars
+    -- emptyTvSubst has an empty in-scope set, but that's fine here
+    -- Since the tyvars are freshly made, they cannot possibly be
+    -- captured by any existing for-alls.
+
+tcInstTyVarsX :: TvSubst -> [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst)
+tcInstTyVarsX subst tyvars =
+  do { (subst', tyvars') <- mapAccumLM tcInstTyVar subst tyvars
+     ; return (tyvars', mkTyVarTys tyvars', subst') }
+
+tcInstTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar)
+-- Make a new unification variable tyvar whose Name and Kind come from
+-- an existing TyVar. We substitute kind variables in the kind.
+tcInstTyVar subst tyvar
+  = do  { uniq <- newMetaUnique
+        ; ref <- newMutVar Flexi
+        ; let name   = mkSystemName uniq (getOccName tyvar)
+              kind   = substTy subst (tyVarKind tyvar)
+              new_tv = mkTcTyVar name kind (MetaTv TauTv ref)
+        ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
 \end{code}
 
 
@@ -475,29 +525,37 @@ zonkTcType ty = zonkType zonkTcTyVar ty
 zonkTcTyVar :: TcTyVar -> TcM TcType
 -- Simply look through all Flexis
 zonkTcTyVar tv
-  = ASSERT2( isTcTyVar tv, ppr tv )
+  = ASSERT2( isTcTyVar tv, ppr tv ) do
     case tcTyVarDetails tv of
-      SkolemTv {}   -> return (TyVarTy tv)
-      RuntimeUnk {} -> return (TyVarTy tv)
+      SkolemTv {}   -> zonk_kind_and_return
+      RuntimeUnk {} -> zonk_kind_and_return
       FlatSkol ty   -> zonkTcType ty
       MetaTv _ ref  -> do { cts <- readMutVar ref
                           ; case cts of
-		               Flexi       -> return (TyVarTy tv)
+		               Flexi       -> zonk_kind_and_return
 			       Indirect ty -> zonkTcType ty }
+  where
+    zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv
+                              ; return (TyVarTy z_tv) }
+
+zonkTyVarKind :: TyVar -> TcM TyVar
+zonkTyVarKind tv = do { kind' <- zonkTcKind (tyVarKind tv)
+                      ; return (setTyVarKind tv kind') }
 
 zonkTcTypeAndSubst :: TvSubst -> TcType -> TcM TcType
 -- Zonk, and simultaneously apply a non-necessarily-idempotent substitution
 zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty
   where
-    zonk_tv tv 
-      = case tcTyVarDetails tv of
-          SkolemTv {}   -> return (TyVarTy tv)
-          RuntimeUnk {} -> return (TyVarTy tv)
-          FlatSkol ty   -> zonkType zonk_tv ty
-          MetaTv _ ref  -> do { cts <- readMutVar ref
-                              ; case cts of
-			           Flexi       -> zonk_flexi tv
-			           Indirect ty -> zonkType zonk_tv ty }
+    zonk_tv tv
+      = do { z_tv <- updateTyVarKindM zonkTcKind tv
+           ; case tcTyVarDetails tv of
+                SkolemTv {}   -> return (TyVarTy z_tv)
+                RuntimeUnk {} -> return (TyVarTy z_tv)
+                FlatSkol ty   -> zonkType zonk_tv ty
+                MetaTv _ ref  -> do { cts <- readMutVar ref
+                                    ; case cts of
+      			           Flexi       -> zonk_flexi z_tv
+      			           Indirect ty -> zonkType zonk_tv ty } }
     zonk_flexi tv
       = case lookupTyVar subst tv of
           Just ty -> zonkType zonk_tv ty
@@ -517,8 +575,32 @@ zonkTcPredType = zonkTcType
 		     are used at the end of type checking
 
 \begin{code}
-zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar]
-zonkQuantifiedTyVars = mapM zonkQuantifiedTyVar
+defaultKindVarToStar :: TcTyVar -> TcM ()
+-- We have a meta-kind: unify it with '*'
+defaultKindVarToStar kv 
+  = ASSERT ( isKiVar kv && isMetaTyVar kv )
+    writeMetaTyVar kv liftedTypeKind
+
+zonkQuantifiedTyVars :: TcTyVarSet -> TcM [TcTyVar]
+-- Precondition: a kind variable occurs before a type
+--               variable mentioning it in its kind
+zonkQuantifiedTyVars tyvars
+  = do { let (kvs, tvs) = partitionKiTyVars (varSetElems tyvars)
+       ; poly_kinds <- xoptM Opt_PolyKinds
+       ; if poly_kinds then
+             mapM zonkQuantifiedTyVar (kvs ++ tvs)
+           -- Because of the order, any kind variables
+           -- mentioned in the kinds of the type variables refer to
+           -- the now-quantified versions
+         else
+             -- In the non-PolyKinds case, default the kind variables
+             -- to *, and zonk the tyvars as usual.  Notice that this
+             -- may make zonkQuantifiedTyVars return a shorter list
+             -- than it was passed, but that's ok
+             do { let (meta_kvs, skolem_kvs) = partition isMetaTyVar kvs
+                ; WARN ( not (null skolem_kvs), ppr skolem_kvs )
+                  mapM_ defaultKindVarToStar meta_kvs
+                ; mapM zonkQuantifiedTyVar (skolem_kvs ++ tvs) } }
 
 zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
 -- The quantified type variables often include meta type variables
@@ -530,11 +612,13 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
 -- the immutable version.
 --
 -- We leave skolem TyVars alone; they are immutable.
+--
+-- This function is called on both kind and type variables,
+-- but kind variables *only* if PolyKinds is on.
 zonkQuantifiedTyVar tv
   = ASSERT2( isTcTyVar tv, ppr tv ) 
     case tcTyVarDetails tv of
-      SkolemTv {} -> WARN( True, ppr tv )  -- Dec10: Can this really happen?
-                     do { kind <- zonkTcType (tyVarKind tv)
+      SkolemTv {} -> do { kind <- zonkTcKind (tyVarKind tv)
                         ; return $ setTyVarKind tv kind }
 	-- It might be a skolem type variable, 
 	-- for example from a user type signature
@@ -562,11 +646,13 @@ skolemiseUnboundMetaTyVar tv details
     do  { span <- getSrcSpanM    -- Get the location from "here"
                                  -- ie where we are generalising
         ; uniq <- newUnique      -- Remove it from TcMetaTyVar unique land
-	; let final_kind = defaultKind (tyVarKind tv)
+        ; kind <- zonkTcKind (tyVarKind tv)
+        ; let final_kind = defaultKind kind
               final_name = mkInternalName uniq (getOccName tv) span
               final_tv   = mkTcTyVar final_name final_kind details
-	; writeMetaTyVar tv (mkTyVarTy final_tv)
-	; return final_tv }
+
+        ; writeMetaTyVar tv (mkTyVarTy final_tv)
+        ; return final_tv }
 \end{code}
 
 \begin{code}
@@ -680,7 +766,7 @@ leads to problems.  Consider this program from the regression test suite:
 
 It leads to the deferral of an equality (wrapped in an implication constraint)
 
-  forall a. (String -> String -> String) ~ a
+  forall a. () => ((String -> String -> String) ~ a)
 
 which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck).
 In the meantime `a' is zonked and quantified to form `evalRHS's signature.
@@ -712,6 +798,9 @@ simplifier knows how to deal with.
 -- For tyvars bound at a for-all, zonkType zonks them to an immutable
 --	type variable and zonks the kind too
 
+zonkKind :: (TcTyVar -> TcM Kind) -> TcKind -> TcM Kind
+zonkKind = zonkType
+
 zonkType :: (TcTyVar -> TcM Type)  -- What to do with TcTyVars
          -> TcType -> TcM Type
 zonkType zonk_tc_tyvar ty
@@ -733,26 +822,13 @@ zonkType zonk_tc_tyvar ty
 
 	-- The two interesting cases!
     go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar
-		       | otherwise	 = return (TyVarTy tyvar)
+		       | otherwise	 = TyVarTy <$> updateTyVarKindM zonkTcKind tyvar
 		-- Ordinary (non Tc) tyvars occur inside quantified types
 
     go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
                              ty' <- go ty
-                             tyvar' <- return tyvar
+                             tyvar' <- updateTyVarKindM zonkTcKind tyvar
                              return (ForAllTy tyvar' ty')
-
-mkZonkTcTyVar :: (TcTyVar -> TcM Type)	-- What to do for an *mutable Flexi* var
- 	      -> TcTyVar -> TcM TcType
-mkZonkTcTyVar unbound_var_fn tyvar 
-  = ASSERT( isTcTyVar tyvar )
-    case tcTyVarDetails tyvar of
-      SkolemTv {}    -> return (TyVarTy tyvar)
-      RuntimeUnk {}  -> return (TyVarTy tyvar)
-      FlatSkol ty    -> zonkType (mkZonkTcTyVar unbound_var_fn) ty
-      MetaTv _ ref   -> do { cts <- readMutVar ref
-			   ; case cts of    
-			       Flexi       -> unbound_var_fn tyvar  
-			       Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty }
 \end{code}
 
 
@@ -764,21 +840,21 @@ mkZonkTcTyVar unbound_var_fn tyvar
 %************************************************************************
 
 \begin{code}
-readKindVar  :: KindVar -> TcM (MetaDetails)
-writeKindVar :: KindVar -> TcKind -> TcM ()
-readKindVar  kv = readMutVar (kindVarRef kv)
-writeKindVar kv val = writeMutVar (kindVarRef kv) (Indirect val)
+compatKindTcM :: Kind -> Kind -> TcM Bool
+compatKindTcM k1 k2
+  = do { k1' <- zonkTcKind k1
+       ; k2' <- zonkTcKind k2
+       ; return $ k1' `isSubKind` k2' || k2' `isSubKind` k1' }
+
+isSubKindTcM :: Kind -> Kind -> TcM Bool
+isSubKindTcM k1 k2
+  = do { k1' <- zonkTcKind k1
+       ; k2' <- zonkTcKind k2
+       ; return $ k1' `isSubKind` k2' }
 
 -------------
 zonkTcKind :: TcKind -> TcM TcKind
 zonkTcKind k = zonkTcType k
-
--------------
-zonkTcKindToKind :: TcKind -> TcM Kind
--- When zonking a TcKind to a kind, we need to instantiate kind variables,
--- Haskell specifies that * is to be used, so we follow that.
-zonkTcKindToKind k 
-  = zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind)) k
 \end{code}
 			
 %************************************************************************
@@ -835,9 +911,6 @@ checkValidType ctxt ty = do
 		 LamPatSigCtxt	-> gen_rank 0
 		 BindPatSigCtxt	-> gen_rank 0
 		 TySynCtxt _    -> gen_rank 0
-		 GenPatCtxt	-> gen_rank 1
-			-- This one is a bit of a hack
-			-- See the forall-wrapping in TcClassDcl.mkGenericInstance		
 
 		 ExprSigCtxt 	-> gen_rank 1
 		 FunSigCtxt _   -> gen_rank 1
@@ -851,8 +924,8 @@ checkValidType ctxt ty = do
 		 SpecInstCtxt   -> gen_rank 1
                  ThBrackCtxt    -> gen_rank 1
 		 GhciCtxt       -> ArbitraryRank
-                 GenSigCtxt     -> panic "checkValidType"
-                                     -- Can't happen; GenSigCtxt not used for *user* sigs
+                 _              -> panic "checkValidType"
+                                     -- Can't happen; not used for *user* sigs
 
 	actual_kind = typeKind ty
 
@@ -860,11 +933,10 @@ checkValidType ctxt ty = do
 			TySynCtxt _  -> True -- Any kind will do
 			ThBrackCtxt  -> True -- ditto
                         GhciCtxt     -> True -- ditto
-			ResSigCtxt   -> isSubOpenTypeKind actual_kind
-			ExprSigCtxt  -> isSubOpenTypeKind actual_kind
-			GenPatCtxt   -> isLiftedTypeKind actual_kind
+			ResSigCtxt   -> tcIsSubOpenTypeKind actual_kind
+			ExprSigCtxt  -> tcIsSubOpenTypeKind actual_kind
 			ForSigCtxt _ -> isLiftedTypeKind actual_kind
-			_            -> isSubArgTypeKind actual_kind
+			_            -> tcIsSubArgTypeKind actual_kind
 	
 	ubx_tup 
          | not unboxed = UT_NotOk
@@ -879,8 +951,9 @@ checkValidType ctxt ty = do
     check_type rank ubx_tup ty
 
 	-- Check that the thing has kind Type, and is lifted if necessary
-	-- Do this second, becuase we can't usefully take the kind of an 
+	-- Do this second, because we can't usefully take the kind of an 
 	-- ill-formed type such as (a~Int)
+    traceTc "checkValidType kind_ok ctxt" (ppr kind_ok $$ pprUserTypeCtxt ctxt)
     checkTc kind_ok (kindErr actual_kind)
 
     traceTc "checkValidType done" (ppr ty)
@@ -912,9 +985,11 @@ data UbxTupFlag = UT_Ok	| UT_NotOk
 	-- The "Ok" version means "ok if UnboxedTuples is on"
 
 ----------------------------------------
-check_mono_type :: Rank -> Type -> TcM ()	-- No foralls anywhere
+check_mono_type :: Rank -> KindOrType -> TcM ()	-- No foralls anywhere
 				      		-- No unlifted types of any kind
 check_mono_type rank ty
+  | isKind ty = return ()  -- IA0_NOTE: Do we need to check kinds?
+  | otherwise
    = do { check_type rank UT_NotOk ty
 	; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
 
@@ -996,7 +1071,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys)
 check_type _ _ ty = pprPanic "check_type" (ppr ty)
 
 ----------------------------------------
-check_arg_type :: Rank -> Type -> TcM ()
+check_arg_type :: Rank -> KindOrType -> TcM ()
 -- The sort of type that can instantiate a type variable,
 -- or be the argument of a type constructor.
 -- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
@@ -1015,7 +1090,9 @@ check_arg_type :: Rank -> Type -> TcM ()
 --     But not in user code.
 -- Anyway, they are dealt with by a special case in check_tau_type
 
-check_arg_type rank ty 
+check_arg_type rank ty
+  | isKind ty = return ()  -- IA0_NOTE: Do we need to check a kind?
+  | otherwise
   = do	{ impred <- xoptM Opt_ImpredicativeTypes
 	; let rank' = case rank of 	    -- Predictive => must be monotype
 	      	        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless
@@ -1085,39 +1162,12 @@ If we do both, we get exponential behaviour!!
 %************************************************************************
 
 \begin{code}
--- Enumerate the contexts in which a "source type", <S>, can occur
---	Eq a 
--- or 	?x::Int
--- or 	r <: {x::Int}
--- or 	(N a) where N is a newtype
-
-data SourceTyCtxt
-  = ClassSCCtxt Name	-- Superclasses of clas
-			-- 	class <S> => C a where ...
-  | SigmaCtxt		-- Theta part of a normal for-all type
-			--	f :: <S> => a -> a
-  | DataTyCtxt Name	-- Theta part of a data decl
-			--	data <S> => T a = MkT a
-  | TypeCtxt 		-- Source type in an ordinary type
-			-- 	f :: N a -> N a
-  | InstThetaCtxt	-- Context of an instance decl
-			--	instance <S> => C [a] where ...
-		
-pprSourceTyCtxt :: SourceTyCtxt -> SDoc
-pprSourceTyCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c)
-pprSourceTyCtxt SigmaCtxt       = ptext (sLit "the context of a polymorphic type")
-pprSourceTyCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc)
-pprSourceTyCtxt InstThetaCtxt   = ptext (sLit "the context of an instance declaration")
-pprSourceTyCtxt TypeCtxt        = ptext (sLit "the context of a type")
-\end{code}
-
-\begin{code}
-checkValidTheta :: SourceTyCtxt -> ThetaType -> TcM ()
+checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
 checkValidTheta ctxt theta 
   = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta)
 
 -------------------------
-check_valid_theta :: SourceTyCtxt -> [PredType] -> TcM ()
+check_valid_theta :: UserTypeCtxt -> [PredType] -> TcM ()
 check_valid_theta _ []
   = return ()
 check_valid_theta ctxt theta = do
@@ -1128,10 +1178,10 @@ check_valid_theta ctxt theta = do
     (_,dups) = removeDups cmpPred theta
 
 -------------------------
-check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM ()
+check_pred_ty :: DynFlags -> UserTypeCtxt -> PredType -> TcM ()
 check_pred_ty dflags ctxt pred = check_pred_ty' dflags ctxt (shallowPredTypePredTree pred)
 
-check_pred_ty' :: DynFlags -> SourceTyCtxt -> PredTree -> TcM ()
+check_pred_ty' :: DynFlags -> UserTypeCtxt -> PredTree -> TcM ()
 check_pred_ty' dflags ctxt (ClassPred cls tys)
   = do {	-- Class predicates are valid in all contexts
        ; checkTc (arity == n_tys) arity_err
@@ -1207,22 +1257,55 @@ check_pred_ty' dflags ctxt (IrredPred pred)
            | xopt Opt_UndecidableInstances dflags -> return ()
            | otherwise -> do
              -- Make sure it is OK to have an irred pred in this context
-             checkTc (case ctxt of ClassSCCtxt _ -> False; InstThetaCtxt -> False; _ -> True)
+             checkTc (case ctxt of ClassSCCtxt _ -> False; InstDeclCtxt -> False; _ -> True)
                      (predIrredBadCtxtErr pred)
 
 -------------------------
-check_class_pred_tys :: DynFlags -> SourceTyCtxt -> [Type] -> Bool
-check_class_pred_tys dflags ctxt tys 
+check_class_pred_tys :: DynFlags -> UserTypeCtxt -> [KindOrType] -> Bool
+check_class_pred_tys dflags ctxt kts
   = case ctxt of
-	TypeCtxt      -> True	-- {-# SPECIALISE instance Eq (T Int) #-} is fine
-	InstThetaCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys
+	SpecInstCtxt -> True	-- {-# SPECIALISE instance Eq (T Int) #-} is fine
+	InstDeclCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys
 				-- Further checks on head and theta in
 				-- checkInstTermination
 	_             -> flexible_contexts || all tyvar_head tys
   where
+    (_, tys) = span isKind kts  -- see Note [Kind polymorphic type classes]
     flexible_contexts = xopt Opt_FlexibleContexts dflags
     undecidable_ok = xopt Opt_UndecidableInstances dflags
 
+{-
+Note [Kind polymorphic type classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+class C f where
+  empty :: f a
+-- C :: forall k. k -> Constraint
+-- empty :: forall (a :: k). f a
+
+MultiParam:
+~~~~~~~~~~~
+
+instance C Maybe where
+  empty = Nothing
+
+The dictionary gets type [C * Maybe] even if it's not a MultiParam
+type class.
+
+Flexible:
+~~~~~~~~~
+
+data D a = D
+-- D :: forall k. k -> *
+
+instance C D where
+  empty = D
+
+The dictionary gets type [C * (D *)]. IA0_TODO it should be
+generalized actually.
+
+-}
+
 -------------------------
 tyvar_head :: Type -> Bool
 tyvar_head ty			-- Haskell 98 allows predicates of form 
@@ -1345,10 +1428,10 @@ so we can take their type variables into account as part of the
 
 
 \begin{code}
-checkThetaCtxt :: SourceTyCtxt -> ThetaType -> SDoc
+checkThetaCtxt :: UserTypeCtxt -> ThetaType -> SDoc
 checkThetaCtxt ctxt theta
   = vcat [ptext (sLit "In the context:") <+> pprTheta theta,
-	  ptext (sLit "While checking") <+> pprSourceTyCtxt ctxt ]
+	  ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ]
 
 eqPredTyErr, predTyVarErr, predTupleErr, predIrredErr, predIrredBadCtxtErr :: PredType -> SDoc
 eqPredTyErr  pred = ptext (sLit "Illegal equational constraint") <+> pprType pred
@@ -1393,20 +1476,23 @@ compiled elsewhere). In these cases, we let them go through anyway.
 We can also have instances for functions: @instance Foo (a -> b) ...@.
 
 \begin{code}
-checkValidInstHead :: Class -> [Type] -> TcM ()
-checkValidInstHead clas tys
+checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
+checkValidInstHead ctxt clas tys
   = do { dflags <- getDOpts
 
-           -- If GlasgowExts then check at least one isn't a type variable
-       ; checkTc (xopt Opt_TypeSynonymInstances dflags ||
-                  all tcInstHeadTyNotSynonym tys)
+           -- Check language restrictions; 
+           -- but not for SPECIALISE isntance pragmas
+       ; unless spec_inst_prag $
+         do { checkTc (xopt Opt_TypeSynonymInstances dflags ||
+                       all tcInstHeadTyNotSynonym tys)
                  (instTypeErr pp_pred head_type_synonym_msg)
-       ; checkTc (xopt Opt_FlexibleInstances dflags ||
-                  all tcInstHeadTyAppAllTyVars tys)
+            ; checkTc (xopt Opt_FlexibleInstances dflags ||
+                       all tcInstHeadTyAppAllTyVars tys)
                  (instTypeErr pp_pred head_type_args_tyvars_msg)
-       ; checkTc (xopt Opt_MultiParamTypeClasses dflags ||
-                  isSingleton tys)
-                 (instTypeErr pp_pred head_one_type_msg)
+            ; checkTc (xopt Opt_MultiParamTypeClasses dflags ||
+                       isSingleton (dropWhile isKind tys))  -- IA0_NOTE: only count type arguments
+                 (instTypeErr pp_pred head_one_type_msg) }
+
          -- May not contain type family applications
        ; mapM_ checkTyFamFreeness tys
 
@@ -1419,6 +1505,8 @@ checkValidInstHead clas tys
        }
 
   where
+    spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
+
     pp_pred = pprClassPred clas tys
     head_type_synonym_msg = parens (
                 text "All instance types must be of the form (T t1 ... tn)" $$
@@ -1471,12 +1559,12 @@ validDerivPred tv_set ty = case getClassPredTys_maybe ty of
 %************************************************************************
 
 \begin{code}
-checkValidInstance :: LHsType Name -> [TyVar] -> ThetaType
+checkValidInstance :: UserTypeCtxt -> LHsType Name -> [TyVar] -> ThetaType
                    -> Class -> [TcType] -> TcM ()
-checkValidInstance hs_type tyvars theta clas inst_tys
+checkValidInstance ctxt hs_type tyvars theta clas inst_tys
   = setSrcSpan (getLoc hs_type) $
-    do  { setSrcSpan head_loc (checkValidInstHead clas inst_tys)
-        ; checkValidTheta InstThetaCtxt theta
+    do  { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys)
+        ; checkValidTheta ctxt theta
 	; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
 
 	-- Check that instance inference will terminate (if we care)
@@ -1648,19 +1736,6 @@ fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty)
 fvTypes :: [Type] -> [TyVar]
 fvTypes tys                = concat (map fvType tys)
 
--------------------
-sizePred :: PredType -> Int
--- Size of a predicate: the number of variables and constructors
--- See Note [Paterson conditions on PredTypes]
-sizePred ty = go (classifyPredType ty)
-  where
-    go (ClassPred _ tys') = sizeTypes tys'
-    go (IPPred {})        = 0
-    go (EqPred {})        = 0
-    go (TuplePred ts)     = maximum (0:map sizePred ts)
-    go (IrredPred ty)     = sizeType ty
-
--------------------
 sizeType :: Type -> Int
 -- Size of a type: the number of variables and constructors
 sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
@@ -1671,7 +1746,24 @@ sizeType (AppTy fun arg)   = sizeType fun + sizeType arg
 sizeType (ForAllTy _ ty)   = sizeType ty
 
 sizeTypes :: [Type] -> Int
-sizeTypes xs               = sum (map sizeType xs)
+-- IA0_NOTE: Avoid kinds.
+sizeTypes xs = sum (map sizeType tys)
+  where tys = filter (not . isKind) xs
+
+-- Size of a predicate
+--
+-- We are considering whether *class* constraints terminate
+-- Once we get into an implicit parameter or equality we
+-- can't get back to a class constraint, so it's safe
+-- to say "size 0".  See Trac #4200.
+sizePred :: PredType -> Int
+sizePred ty = go (predTypePredTree ty)
+  where
+    go (ClassPred _ tys') = sizeTypes tys'
+    go (IPPred {})        = 0
+    go (EqPred {})        = 0
+    go (TuplePred ts)     = sum (map go ts)
+    go (IrredPred ty)     = sizeType ty
 \end{code}
 
 Note [Paterson conditions on PredTypes]
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index e99d2656fc..c9a67aa76d 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -672,15 +672,14 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
 	; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
 
 	; checkExistentials ex_tvs penv 
-        ; ex_tvs' <- tcInstSuperSkolTyVars ex_tvs
+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX
+                               (zipTopTvSubst univ_tvs ctxt_res_tys) ex_tvs
                      -- Get location from monad, not from ex_tvs
 
         ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
 	      -- pat_ty' is type of the actual constructor application
               -- pat_ty' /= pat_ty iff coi /= IdCo
               
-	      tenv     = zipTopTvSubst (univ_tvs     ++ ex_tvs)
-				       (ctxt_res_tys ++ mkTyVarTys ex_tvs')
 	      arg_tys' = substTys tenv arg_tys
 
 	; if null ex_tvs && null eq_spec && null theta
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 76d96cfd3c..5312e681c6 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -335,7 +335,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 	-- any mutually recursive types are done right
 	-- Just discard the auxiliary bindings; they are generated 
 	-- only for Haskell source code, and should already be in Core
-   (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+   tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ;
    dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ;
 
    setGblEnv tcg_env $ do {
@@ -359,7 +359,6 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                 mg_deps      = noDependencies,	-- ??
                                 mg_exports   = my_exports,
                                 mg_tcs       = tcg_tcs tcg_env,
-                                mg_clss      = tcg_clss tcg_env,
                                 mg_insts     = tcg_insts tcg_env,
                                 mg_fam_insts = tcg_fam_insts tcg_env,
                                 mg_inst_env  = tcg_inst_env tcg_env,
@@ -543,8 +542,8 @@ tcRnHsBootDecls decls
 
 		-- Typecheck type/class decls
 	; traceTc "Tc2" empty
-	; (tcg_env, aux_binds) 
-               <- tcTyAndClassDecls emptyModDetails tycl_decls
+	; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls
+        ; let aux_binds = mkRecSelBinds [tc | ATyCon tc <- nameEnvElts (tcg_type_env tcg_env)]
 	; setGblEnv tcg_env    $ do {
 
 		-- Typecheck instance decls
@@ -751,7 +750,8 @@ checkBootTyCon tc1 tc2
          = checkBootTyCon tc1 tc2 &&
            eqListBy eqATDef def_ats1 def_ats2
 
-       eqATDef (ATD tvs1 ty_pats1 ty1) (ATD tvs2 ty_pats2 ty2)
+       -- Ignore the location of the defaults
+       eqATDef (ATD tvs1 ty_pats1 ty1 _loc1) (ATD tvs2 ty_pats2 ty2 _loc2)
          = eqListBy same_kind tvs1 tvs2 &&
            eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
            eqTypeX env ty1 ty2
@@ -892,9 +892,10 @@ tcTopSrcDecls boot_details
 		-- The latter come in via tycl_decls
         traceTc "Tc2" empty ;
 
-	(tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
+	tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
+	let { aux_binds = mkRecSelBinds [tc | tc <- tcg_tcs tcg_env] } ;
 		-- If there are any errors, tcTyAndClassDecls fails here
-	
+
 	setGblEnv tcg_env	$ do {
 
 		-- Source-language instances, including derivings,
@@ -968,6 +969,7 @@ tcTopSrcDecls boot_details
                                  , tcg_vects = tcg_vects tcg_env ++ vects
                                  , tcg_anns  = tcg_anns tcg_env ++ annotations
                                  , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
+
         return (tcg_env', tcl_env)
     }}}}}}
 \end{code}
@@ -1451,7 +1453,7 @@ tcRnType hsc_env ictxt normalise rdr_type
   = initTcPrintErrors hsc_env iNTERACTIVE $ 
     setInteractiveContext hsc_env ictxt $ do {
 
-    rn_type <- rnLHsType doc rdr_type ;
+    rn_type <- rnLHsType GHCiCtx rdr_type ;
     failIfErrsM ;
 
 	-- Now kind-check the type
@@ -1467,8 +1469,6 @@ tcRnType hsc_env ictxt normalise rdr_type
             
     return (ty', typeKind ty)
     }
-  where
-    doc = ptext (sLit "In GHCi input")
 
 \end{code}
 
@@ -1732,10 +1732,8 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
 
 pprModGuts :: ModGuts -> SDoc
 pprModGuts (ModGuts { mg_tcs = tcs
-                    , mg_clss = clss
                     , mg_rules = rules })
-  = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs
-                                    ++ map (ATyCon . classTyCon) clss)),
+  = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)),
 	   ppr_rules rules ]
 
 ppr_types :: [Instance] -> TypeEnv -> SDoc
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index b3b5cd319c..75a80c3222 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -124,7 +124,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_warns          = NoWarnings,
                 tcg_anns           = [],
                 tcg_tcs            = [],
-                tcg_clss           = [],
                 tcg_insts          = [],
                 tcg_fam_insts      = [],
                 tcg_rules          = [],
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index b429d6bb80..1640edc2df 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -302,8 +302,7 @@ data TcGblEnv
         tcg_imp_specs :: [LTcSpecPrag],     -- ...SPECIALISE prags for imported Ids
 	tcg_warns     :: Warnings,	    -- ...Warnings and deprecations
 	tcg_anns      :: [Annotation],      -- ...Annotations
-        tcg_tcs       :: [TyCon],           -- ...TyCons
-        tcg_clss      :: [Class],           -- ...Classes
+        tcg_tcs       :: [TyCon],           -- ...TyCons and Classes
 	tcg_insts     :: [Instance],	    -- ...Instances
         tcg_fam_insts :: [FamInst],         -- ...Family instances
         tcg_rules     :: [LRuleDecl Id],    -- ...Rules
@@ -565,8 +564,32 @@ data TcTyThing
 				-- for error-message purposes; it is the corresponding
 				-- Name in the domain of the envt
 
-  | AThing  TcKind 		-- Used temporarily, during kind checking, for the
-				--	tycons and clases in this recursive group
+  | AThing  TcKind   -- Used temporarily, during kind checking, for the
+		     --	tycons and clases in this recursive group
+                     -- Can be a mono-kind or a poly-kind; in TcTyClsDcls see
+                     -- Note [Type checking recursive type and class declarations]
+
+  | ANothing                    -- see Note [ANothing]
+
+{-
+Note [ANothing]
+~~~~~~~~~~~~~~~
+
+We don't want to allow promotion in a strongly connected component
+when kind checking.
+
+Consider:
+  data T f = K (f (K Any))
+
+When kind checking the `data T' declaration the local env contains the
+mappings:
+  T -> AThing <some initial kind>
+  K -> ANothing
+
+ANothing is only used for DataCons, and only used during type checking
+in tcTyClGroup.
+-}
+
 
 instance Outputable TcTyThing where	-- Debugging only
    ppr (AGlobal g)      = pprTyThing g
@@ -577,12 +600,14 @@ instance Outputable TcTyThing where	-- Debugging only
 				 <+> ppr (tct_level elt))
    ppr (ATyVar tv _)    = text "Type variable" <+> quotes (ppr tv)
    ppr (AThing k)       = text "AThing" <+> ppr k
+   ppr ANothing         = text "ANothing"
 
 pprTcTyThingCategory :: TcTyThing -> SDoc
 pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing
 pprTcTyThingCategory (ATyVar {})     = ptext (sLit "Type variable")
 pprTcTyThingCategory (ATcId {})      = ptext (sLit "Local identifier")
 pprTcTyThingCategory (AThing {})     = ptext (sLit "Kinded thing")
+pprTcTyThingCategory ANothing        = ptext (sLit "Opaque thing")
 \end{code}
 
 Note [Bindings with closed types]
@@ -593,7 +618,7 @@ Consider
         in ...
 
 Can we generalise 'g' under the OutsideIn algorithm?  Yes, 
-becuase all g's free variables are top-level; that is they themselves
+because all g's free variables are top-level; that is they themselves
 have no free type variables, and it is the type variables in the
 environment that makes things tricky for OutsideIn generalisation.
 
diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs
index 9aae216ab5..f4dafcbeee 100644
--- a/compiler/typecheck/TcRules.lhs
+++ b/compiler/typecheck/TcRules.lhs
@@ -25,7 +25,6 @@ import TcExpr
 import TcEnv
 import Id
 import Name
-import VarSet
 import SrcLoc
 import Outputable
 import FastString
@@ -60,7 +59,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
     	-- Note [Typechecking rules]
        ; vars <- tcRuleBndrs hs_bndrs
        ; let (id_bndrs, tv_bndrs) = partition isId vars
-       ; (lhs', lhs_lie, rhs', rhs_lie, rule_ty)
+       ; (lhs', lhs_lie, rhs', rhs_lie, _rule_ty)
             <- tcExtendTyVarEnv tv_bndrs $
                tcExtendIdEnv id_bndrs $
                do { ((lhs', rule_ty), lhs_lie) <- captureConstraints (tcInferRho lhs)
@@ -91,6 +90,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
 	-- during zonking (see TcHsSyn.zonkRule)
 
        ; let tpl_ids    = lhs_dicts ++ id_bndrs
+{-
              forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
 
 	     -- Now figure out what to quantify over
@@ -101,10 +101,13 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
        	     		       `minusVarSet` gbl_tvs
        	     		       `delVarSetList` tv_bndrs
        ; qtvs <- zonkQuantifiedTyVars (varSetElems extra_bound_tvs)
+       ; let all_tvs = tv_bndrs ++ qtvs
+       ; (kvs, _kinds) <- kindGeneralizeKinds $ map tyVarKind all_tvs
+-}
 
        	      -- The tv_bndrs are already skolems, so no need to zonk them
        ; return (HsRule name act
-		    (map (RuleBndr . noLoc) (tv_bndrs ++ qtvs ++ tpl_ids))	-- yuk
+		    (map (RuleBndr . noLoc) (tv_bndrs ++ tpl_ids))
 		    (mkHsDictLet lhs_ev_binds lhs') fv_lhs
 		    (mkHsDictLet rhs_ev_binds rhs') fv_rhs) }
 
@@ -134,7 +137,3 @@ ruleCtxt :: FastString -> SDoc
 ruleCtxt name = ptext (sLit "When checking the transformation rule") <+> 
 		doubleQuotes (ftext name)
 \end{code}
-
-
-
-
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index cd0477297e..7d3ee73f6b 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -74,7 +74,7 @@ module TcSMonad (
     instDFunConstraints,          
     newFlexiTcSTy, instFlexiTcS,
 
-    compatKind,
+    compatKind, compatKindTcS, isSubKindTcS, unifyKindTcS,
 
     TcsUntouchables,
     isTouchableMetaTyVar,
@@ -106,6 +106,7 @@ import qualified TcRnMonad as TcM
 import qualified TcMType as TcM
 import qualified TcEnv as TcM 
        ( checkWellStaged, topIdLvl, tcGetDefaultTys )
+import {-# SOURCE #-} qualified TcUnify as TcM ( unifyKindEq, mkKindErrorCtxt )
 import Kind
 import TcType
 import DynFlags
@@ -148,6 +149,23 @@ import TrieMap
 compatKind :: Kind -> Kind -> Bool
 compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 
 
+compatKindTcS :: Kind -> Kind -> TcS Bool
+-- Because kind unification happens during constraint solving, we have
+-- to make sure that two kinds are zonked before we compare them.
+compatKindTcS k1 k2 = wrapTcS (TcM.compatKindTcM k1 k2)
+
+isSubKindTcS :: Kind -> Kind -> TcS Bool
+isSubKindTcS k1 k2 = wrapTcS (TcM.isSubKindTcM k1 k2)
+
+unifyKindTcS :: Type -> Type     -- Context
+             -> Kind -> Kind     -- Corresponding kinds
+             -> TcS Bool
+unifyKindTcS ty1 ty2 ki1 ki2
+  = wrapTcS $ TcM.addErrCtxtM ctxt $ do
+      (_errs, mb_r) <- TcM.tryTc (TcM.unifyKindEq ki1 ki2)
+      return (maybe False (const True) mb_r)
+  where ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2
+
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index d91432e810..be29e38772 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -28,7 +28,6 @@ import VarSet
 import VarEnv 
 import Coercion
 import TypeRep
-
 import Name
 import NameEnv	( emptyNameEnv )
 import Bag
@@ -211,6 +210,18 @@ Allow constraints which consist only of type variables, with no repeats.
 *                                                                                 *
 ***********************************************************************************
 
+Note [Which variables to quantify]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose the inferred type of a function is
+   T kappa (alpha:kappa) -> Int
+where alpha is a type unification variable and 
+      kappa is a kind unification variable
+Then we want to quantify over *both* alpha and kappa.  But notice that
+kappa appears "at top level" of the type, as well as inside the kind
+of alpha.  So it should be fine to just look for the "top level"
+kind/type variables of the type, without looking transitively into the
+kinds of those type variables.
+
 \begin{code}
 simplifyInfer :: Bool
               -> Bool                  -- Apply monomorphism restriction
@@ -227,8 +238,10 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
   | isEmptyWC wanteds
   = do { gbl_tvs     <- tcGetGlobalTyVars            -- Already zonked
        ; zonked_taus <- zonkTcTypes (map snd name_taus)
-       ; let tvs_to_quantify = get_tau_tvs zonked_taus `minusVarSet` gbl_tvs
-       ; qtvs <- zonkQuantifiedTyVars (varSetElems tvs_to_quantify)
+       ; let tvs_to_quantify = tyVarsOfTypes zonked_taus `minusVarSet` gbl_tvs
+       	     		       -- tvs_to_quantify can contain both kind and type vars
+       	                       -- See Note [Which variables to quantify]
+       ; qtvs <- zonkQuantifiedTyVars tvs_to_quantify
        ; return (qtvs, [], False, emptyTcEvBinds) }
 
   | otherwise
@@ -250,7 +263,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
 	     -- Then split the constraints on the baisis of those tyvars
 	     -- to avoid unnecessarily simplifying a class constraint
 	     -- See Note [Avoid unecessary constraint simplification]
-       ; let zonked_tau_tvs = get_tau_tvs zonked_taus
+       ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus
              proto_qtvs = growWanteds gbl_tvs zonked_wanteds $
                           zonked_tau_tvs `minusVarSet` gbl_tvs
              (perhaps_bound, surely_free)
@@ -313,8 +326,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
                         -- they are also bound in ic_skols and we want them to be
                         -- tidied uniformly
 
-       ; gloc <- getCtLoc skol_info
-       ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs)
+       ; qtvs_to_return <- zonkQuantifiedTyVars qtvs
 
             -- Step 5
             -- Minimize `bound' and emit an implication
@@ -322,6 +334,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
        ; ev_binds_var <- newTcEvBinds
        ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) tc_binds0
        ; lcl_env <- getLclTypeEnv
+       ; gloc <- getCtLoc skol_info
        ; let implic = Implic { ic_untch    = NoUntouchables
                              , ic_env      = lcl_env
                              , ic_skols    = mkVarSet qtvs_to_return
@@ -342,13 +355,6 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
 
        ; return ( qtvs_to_return, minimal_bound_ev_vars
                 , mr_bites,  TcEvBinds ev_binds_var) } }
-  where
-    get_tau_tvs = tyVarsOfTypes	-- I think this stuff is out of date
-{-
-    get_tau_tvs | isTopLevel top_lvl = tyVarsOfTypes
-                | otherwise          = exactTyVarsOfTypes
-     -- See Note [Silly type synonym] in TcType
--}
 \end{code}
 
 
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 5939117565..54bc0cd6e2 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -364,7 +364,7 @@ tcBracket brack res_ty
        ; return (noLoc (HsBracketOut brack pendings)) }
 
 tc_bracket :: ThStage -> HsBracket Name -> TcM TcType
-tc_bracket outer_stage (VarBr name)     -- Note [Quoting names]
+tc_bracket outer_stage br@(VarBr _ name)     -- Note [Quoting names]
   = do  { thing <- tcLookup name
         ; case thing of
             AGlobal _ -> return ()
@@ -373,7 +373,7 @@ tc_bracket outer_stage (VarBr name)     -- Note [Quoting names]
                 -> keepAliveTc id
                 | otherwise
                 -> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
-                                (quotedNameStageErr name) }
+                                (quotedNameStageErr br) }
             _ -> pprPanic "th_bracket" (ppr name)
 
         ; tcMetaTy nameTyConName        -- Result type is Var (not Q-monadic)
@@ -410,9 +410,9 @@ tc_bracket _ (PatBr pat)
 tc_bracket _ (DecBrL _)
   = panic "tc_bracket: Unexpected DecBrL"
 
-quotedNameStageErr :: Name -> SDoc
-quotedNameStageErr v
-  = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
+quotedNameStageErr :: HsBracket Name -> SDoc
+quotedNameStageErr br
+  = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br
         , ptext (sLit "must be used at the same stage at which is is bound")]
 \end{code}
 
@@ -536,8 +536,8 @@ kcSpliceType splice@(HsSplice name hs_expr) fvs
     -- Here (h 4) :: Q Type
     -- but $(h 4) :: a  i.e. any type, of any kind
 
-    ; kind <- newKindVar
-    ; return (HsSpliceTy splice fvs kind, kind)
+    ; kind <- newMetaKindVar
+    ; return (HsSpliceTy splice fvs kind, kind) 
     }}}
 
 kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
@@ -551,11 +551,11 @@ kcTopSpliceType expr
         -- Run the expression
         ; hs_ty2 <- runMetaT zonked_q_expr
         ; showSplice "type" expr (ppr hs_ty2)
-
+  
         -- Rename it, but bale out if there are errors
         -- otherwise the type checker just gives more spurious errors
-        ; addErrCtxt (spliceResultDoc expr) $ do
-        { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
+        ; addErrCtxt (spliceResultDoc expr) $ do 
+        { let doc = SpliceTypeCtx hs_ty2
         ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
         ; (ty4, kind) <- kcLHsType hs_ty3
         ; return (unLoc ty4, kind) }}
@@ -990,7 +990,7 @@ reifyInstances th_nm th_tys
             _ -> bale_out (ppr_th th_nm <+> ptext (sLit "is not a class or type constructor"))
         }
   where
-    doc = ptext (sLit "TcSplice.reifyInstances")
+    doc = ClassInstanceCtx
     bale_out msg = failWithTc msg
 
     tc_types :: TyCon -> [TH.Type] -> TcM [Type]
@@ -1159,6 +1159,7 @@ reifyThing (ATyVar tv ty)
         ; return (TH.TyVarI (reifyName tv) ty2) }
 
 reifyThing (AThing {}) = panic "reifyThing AThing"
+reifyThing ANothing = panic "reifyThing ANothing"
 
 ------------------------------
 reifyAxiom :: CoAxiom -> TcM TH.Info
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 7a56db4020..47c134a198 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -19,7 +19,7 @@ module TcTyClsDecls (
 	-- Functions used by TcInstDcls to check 
 	-- data/type family instance declarations
         kcDataDecl, tcConDecls, dataDeclChecks, checkValidTyCon,
-        tcSynFamInstDecl, kcFamTyPats, 
+        tcSynFamInstDecl, tcFamTyPats, 
         wrongKindOfFamily, badATErr, wrongATArgErr
     ) where
 
@@ -38,6 +38,7 @@ import TcMType
 import TcType
 import TysWiredIn	( unitTy )
 import Type
+import Kind
 import Class
 import TyCon
 import DataCon
@@ -73,80 +74,117 @@ import Data.List
 %*									*
 %************************************************************************
 
+Note [Grouping of type and class declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly
+connected component of mutually dependent types and classes. We kind check and
+type check each group separately to enhance kind polymorphism. Take the
+following example:
+
+  type Id a = a
+  data X = X (Id Int)
+
+If we were to kind check the two declarations together, we would give Id the
+kind * -> *, since we apply it to an Int in the definition of X. But we can do
+better than that, since Id really is kind polymorphic, and should get kind
+forall (k::BOX). k -> k. Since it does not depend on anything else, it can be
+kind-checked by itself, hence getting the most general kind. We then kind check
+X, which works fine because we then know the polymorphic kind of Id, and simply
+instantiate k to *.
+
 \begin{code}
 
-tcTyAndClassDecls :: ModDetails 
-                   -> [[LTyClDecl Name]]    -- Mutually-recursive groups in dependency order
-                   -> TcM (TcGblEnv,   	    -- Input env extended by types and classes 
-                                            -- and their implicit Ids,DataCons
-                           HsValBinds Name) -- Renamed bindings for record selectors
+tcTyAndClassDecls :: ModDetails
+                   -> [TyClGroup Name]       -- Mutually-recursive groups in dependency order
+                   -> TcM (TcGblEnv)         -- Input env extended by types and classes
+                                             -- and their implicit Ids,DataCons
 -- Fails if there are any errors
-
 tcTyAndClassDecls boot_details decls_s
-  = checkNoErrs $ 	-- The code recovers internally, but if anything gave rise to
-			-- an error we'd better stop now, to avoid a cascade
-    do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
-     		  -- Remove family instance decls altogether
-		  -- They are dealt with by TcInstDcls
-	      
-       ; tyclss <- fixM $ \ rec_tyclss ->
-              tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $
-	      	-- We must populate the environment with the loop-tied
-	      	-- T's right away (even before kind checking), because 
-                -- the kind checker may "fault in" some type constructors 
-	      	-- that recursively mention T
-
-              do {    -- Kind-check in dependency order
-                      -- See Note [Kind checking for type and class decls]
-                   kc_decls <- kcTyClDecls tyclds_s
-
-                      -- And now build the TyCons/Classes
-                ; let rec_flags = calcRecFlags boot_details rec_tyclss
-                ; concatMapM (tcTyClDecl rec_flags) kc_decls }
-
-       ; traceTc "tcTyAndCl" (ppr tyclss)
-
+  = checkNoErrs $ do    -- The code recovers internally, but if anything gave rise to
+                        -- an error we'd better stop now, to avoid a cascade
+  { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
+                   -- Remove family instance decls altogether
+                   -- They are dealt with by TcInstDcls
+  ; fold_env tyclds_s }  -- type check each group in dependency order folding the global env
+  where
+    fold_env :: [TyClGroup Name] -> TcM TcGblEnv
+    fold_env [] = getGblEnv
+    fold_env (tyclds:tyclds_s)
+      = do { env <- tcTyClGroup boot_details tyclds
+           ; setGblEnv env $ fold_env tyclds_s }
+             -- remaining groups are typecheck in the extended global env
+
+tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv
+-- Typecheck one strongly-connected component of type and class decls
+tcTyClGroup boot_details tyclds
+  = do {    -- Step 1: kind-check this group and returns the final
+            -- (possibly-polymorphic) kind of each TyCon and Class
+            -- See Note [Kind checking for type and class decls]
+         names_w_poly_kinds <- kcTyClGroup tyclds
+       ; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds)
+
+	    -- Step 2: type-check all groups together, returning 
+	    -- the final TyCons and Classes
+       ; tyclss <- fixM $ \ rec_tyclss -> do
+           { let rec_flags = calcRecFlags boot_details rec_tyclss
+
+                 -- Populate environment with knot-tied ATyCon for TyCons
+                 -- NB: if the decls mention any ill-staged data cons
+                 -- (see Note [ANothing] in typecheck/TcRnTypes.lhs) we
+                 -- will have failed already in kcTyClGroup, so no worries here
+           ; tcExtendRecEnv (zipRecTyClss tyclds rec_tyclss) $
+
+                 -- Also extend the local type envt with bindings giving
+                 -- the (polymorphic) kind of each knot-tied TyCon or Class
+		 -- See Note [Type checking recursive type and class declarations]
+	     tcExtendKindEnv names_w_poly_kinds              $
+
+                 -- Kind and type check declarations for this group
+             concatMapM (tcTyClDecl rec_flags) tyclds }
+
+           -- Step 3: Perform the validity chebck
+           -- We can do this now because we are done with the recursive knot
+           -- Do it before Step 4 (adding implicit things) because the latter
+           -- expects well-formed TyCons
        ; tcExtendGlobalEnv tyclss $ do
-       {  -- Perform the validity check
-          -- We can do this now because we are done with the recursive knot
-          traceTc "ready for validity check" empty
-	; mapM_ (addLocM checkValidTyCl) (concat tyclds_s)
- 	; traceTc "done" empty
-
-	-- Add the implicit things;
-	-- we want them in the environment because
-	-- they may be mentioned in interface files
-	-- NB: All associated types and their implicit things will be added a
-	--     second time here.  This doesn't matter as the definitions are
-	--     the same.
-	; let {	implicit_things = concatMap implicitTyThings tyclss
-	      ; rec_sel_binds   = mkRecSelBinds [tc | ATyCon tc <- tyclss]
-          ; dm_ids          = mkDefaultMethodIds tyclss }
-
-        ; tcg_env <- tcExtendGlobalEnvImplicit implicit_things $
-                     tcExtendGlobalValEnv dm_ids $
-                     getGblEnv
-
-        ; return (tcg_env, rec_sel_binds) } }
-                    
-zipRecTyClss :: [[LTyClDecl Name]]
+       { traceTc "Starting validity check" (ppr tyclss)
+       ; mapM_ (addLocM checkValidTyCl) tyclds
+
+           -- Step 4: Add the implicit things;
+           -- we want them in the environment because
+           -- they may be mentioned in interface files
+       ; let implicit_things = concatMap implicitTyThings tyclss
+             dm_ids          = mkDefaultMethodIds tyclss
+       ; tcExtendGlobalEnvImplicit implicit_things $ 
+         tcExtendGlobalValEnv dm_ids $ 
+         getGblEnv } }
+
+zipRecTyClss :: TyClGroup Name
              -> [TyThing]           -- Knot-tied
              -> [(Name,TyThing)]
 -- Build a name-TyThing mapping for the things bound by decls
 -- being careful not to look at the [TyThing]
 -- The TyThings in the result list must have a visible ATyCon,
 -- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor
-zipRecTyClss decls_s rec_things
-  = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ]
+zipRecTyClss decls rec_things
+  = [ (name, ATyCon (get name))
+    | name <- tyClsBinders decls ]
   where
     rec_type_env :: TypeEnv
     rec_type_env = mkTypeEnv rec_things
 
-    get :: TyClDecl Name -> (Name, TyThing)
-    get decl = (name, ATyCon tc)
-      where
-        name = tcdName decl
-        Just (ATyCon tc) = lookupTypeEnv rec_type_env name
+    get name = case lookupTypeEnv rec_type_env name of
+                 Just (ATyCon tc) -> tc
+                 other            -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)
+
+tyClsBinders :: TyClGroup Name -> [Name]
+-- Just the tycon and class binders of a group (not the data constructors)
+tyClsBinders decls
+  = concatMap get decls
+  where
+    get (L _ (ClassDecl { tcdLName = L _ n, tcdATs = ats })) = n : tyClsBinders ats
+    get (L _ d)                                              = [tcdName d]
 \end{code}
 
 
@@ -206,67 +244,90 @@ The kind of a type family is solely determinded by its kind signature;
 hence, only kind signatures participate in the construction of the initial
 kind environment (as constructed by `getInitialKind').  In fact, we ignore
 instances of families altogether in the following.  However, we need to
-include the kinds of associated families into the construction of the
+include the kinds of *associated* families into the construction of the
 initial kind environment.  (This is handled by `allDecls').
 
 
 \begin{code}
-kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name]
-kcTyClDecls []                = return []
-kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls
-                                   ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s)
-                                   ; return (kc_decls1 ++ kc_decls2) }
-
-kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name])
-kcTyClDecls1 decls
-  = do	{       -- Omit instances of type families; they are handled together
-		-- with the *heads* of class instances
-        ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls
-              alg_at_decls           = flattenATs alg_decls
-
-	; mod <- getModule
-	; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
-
-          -- Kind checking; see Note [Kind checking for type and class decls]
-	; alg_kinds <- mapM getInitialKind alg_at_decls
-	; tcExtendKindEnv alg_kinds $  do
-
-        { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls)
-
+kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)]
+-- Kind check this group, kind generalize, and return the resulting local env
+-- See Note [Kind checking for type and class decls]
+kcTyClGroup decls
+  = do	{ mod <- getModule
+	; traceTc "kcTyClGroup" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
+
+          -- Kind checking; 
+	  --    1. Bind kind variables for non-synonyms
+          --    2. Kind-check synonyms, and bind kinds of those synonyms
+          --    3. Kind-check non-synonyms
+	  --    4. Generalise the inferred kinds
+          -- See Note [Kind checking for type and class decls]
+
+	  -- Step 1: Bind kind variables for non-synonyms
+        ; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls
+	; initial_kinds <- concatMapM getInitialKinds non_syn_decls
+	; tcExtendTcTyThingEnv initial_kinds $  do
+
+	   -- Step 2: kind-check the synonyms, and extend envt
+        { tcl_env <- kcSynDecls (calcSynCycles syn_decls)
         ; setLclEnv tcl_env $  do
-        { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls
-                
-	     -- Kind checking done for this group, so zonk the kind variables
-	     -- See Note [Kind checking for type and class decls]
-        ; mapM_ (zonkTcKindToKind . snd) alg_kinds
 
-	; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } }
+	   -- Step 3: kind-check the synonyms
+        { mapM_ (wrapLocM kcTyClDecl) non_syn_decls
+
+	     -- Step 4: generalisation
+	     -- Kind checking done for this group
+             -- Now we have to kind generalize the flexis
+        ; mapM generalise (tyClsBinders decls) }}}
 
-flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name]
-flattenATs decls = concatMap flatten decls
   where
-    flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
-    flatten decl				  = [decl]
-
-getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
--- Only for data type, class, and indexed type declarations
--- Get as much info as possible from the data, class, or indexed type decl,
--- so as to maximise usefulness of error messages
-getInitialKind (L _ decl)
+    generalise :: Name -> TcM (Name, Kind)
+    generalise name
+      = do { traceTc "Generalise type of" (ppr name)
+           ; thing <- tcLookup name
+           ; let kc_kind = case thing of
+                               AThing k -> k
+                               _ -> pprPanic "kcTyClGroup" (ppr thing)
+           ; (kvs, kc_kind') <- kindGeneralizeKind kc_kind
+           ; return (name, mkForAllTys kvs kc_kind') }
+
+getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)]
+-- Allocate a fresh kind variable for each TyCon and Class
+-- For each tycon, return   (tc, AThing k)
+--                 where k is the kind of tc, derived from the LHS
+--                       of the definition (and probably including
+--                       kind unification variables)
+--      Example: data T a b = ...
+--      return (T, kv1 -> kv2 -> *)
+--
+-- ALSO for each datacon, return (dc, ANothing)
+--      See Note [ANothing] in TcRnTypes
+
+getInitialKinds (L _ decl)
   = do 	{ arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
 	; res_kind  <- mk_res_kind decl
-	; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
+        ; let main_pair = (tcdName decl, AThing (mkArrowKinds arg_kinds res_kind))
+	; inner_pairs <- get_inner_kinds decl
+	; return (main_pair : inner_pairs) }
   where
-    mk_arg_kind (UserTyVar _ _)      = newKindVar
-    mk_arg_kind (KindedTyVar _ kind) = return kind
+    mk_arg_kind (UserTyVar _ _)        = newMetaKindVar
+    mk_arg_kind (KindedTyVar _ kind _) = scDsLHsKind kind
 
-    mk_res_kind (TyFamily { tcdKind    = Just kind }) = return kind
-    mk_res_kind (TyData   { tcdKindSig = Just kind }) = return kind
+    mk_res_kind (TyFamily { tcdKind    = Just kind }) = scDsLHsKind kind
+    mk_res_kind (TyData   { tcdKindSig = Just kind }) = scDsLHsKind kind
 	-- On GADT-style declarations we allow a kind signature
 	--	data T :: *->* where { ... }
     mk_res_kind (ClassDecl {}) = return constraintKind
     mk_res_kind _              = return liftedTypeKind
 
+    get_inner_kinds :: TyClDecl Name -> TcM [(Name,TcTyThing)]
+    get_inner_kinds (TyData { tcdCons = cons })
+       = return [ (unLoc (con_name con), ANothing) | L _ con <- cons ]
+    get_inner_kinds (ClassDecl { tcdATs = ats })
+       = concatMapM getInitialKinds ats
+    get_inner_kinds _
+       = return []
+
 kcLookupKind :: Located Name -> TcM Kind
 kcLookupKind nm = do
     tc_ty_thing <- tcLookupLocated nm
@@ -277,55 +338,58 @@ kcLookupKind nm = do
 
 
 ----------------
-kcSynDecls :: [SCC (LTyClDecl Name)] 
-	   -> TcM ([LTyClDecl Name], 	-- Kind-annotated decls
-		   TcLclEnv)	-- Kind bindings
-kcSynDecls []
-  = do { tcl_env <- getLclEnv; return ([], tcl_env) }
+kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM (TcLclEnv)	-- Kind bindings
+kcSynDecls [] = getLclEnv
 kcSynDecls (group : groups)
-  = do	{ (decl,  nk)      <- kcSynDecl group
-	; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups)
-	; return (decl:decls, tcl_env) }
-			
+  = do	{ nk <- kcSynDecl1 group
+	; tcExtendKindEnv [nk] (kcSynDecls groups) }
+
 ----------------
-kcSynDecl :: SCC (LTyClDecl Name) 
-	   -> TcM (LTyClDecl Name, 	-- Kind-annotated decls
-		   (Name,TcKind))	-- Kind bindings
-kcSynDecl (AcyclicSCC (L loc decl))
-  = tcAddDeclCtxt decl	$
-    kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
-    do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) 
+kcSynDecl1 :: SCC (LTyClDecl Name)
+	   -> TcM (Name,TcKind) -- Kind bindings
+kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl
+kcSynDecl1 (CyclicSCC decls)       = do { recSynErr decls; failM }
+	   	      		     -- Fail here to avoid error cascade
+				     -- of out-of-scope tycons
+
+kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind)
+kcSynDecl decl	      -- Vanilla type synonyoms only, not family instances
+  = tcAddDeclCtxt decl $
+    kcHsTyVars (tcdTyVars decl) $ \ k_tvs ->
+    do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
 			<+> brackets (ppr k_tvs))
-       ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
-       ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
+       ; (_, rhs_kind) <- kcLHsType (tcdSynRhs decl)
+       ; traceTc "kcd2" (ppr (tcdName decl))
        ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
-       ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
-		 (unLoc (tcdLName decl), tc_kind)) })
-
-kcSynDecl (CyclicSCC decls)
-  = do { recSynErr decls; failM }	-- Fail here to avoid error cascade
-					-- of out-of-scope tycons
+       ; return (tcdName decl, tc_kind) }
 
 ------------------------------------------------------------------------
-kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
-	-- Not used for type synonyms (see kcSynDecl)
+kcTyClDecl :: TyClDecl Name -> TcM ()
+-- This function is used solely for its side effect on kind variables
+
+kcTyClDecl (ForeignType {})   
+  = return ()
+kcTyClDecl decl@(TyFamily {}) 
+  = kcFamilyDecl [] decl      -- the empty list signals a toplevel decl
 
 kcTyClDecl decl@(TyData {})
   = ASSERT( not . isFamInstDecl $ decl )   -- must not be a family instance
-    kcTyClDeclBody decl	$
-      kcDataDecl decl
-
-kcTyClDecl decl@(TyFamily {})
-  = kcFamilyDecl [] decl      -- the empty list signals a toplevel decl      
+    kcTyClDeclBody decl	$ \_ -> kcDataDecl decl
 
-kcTyClDecl decl@(ClassDecl {})
-  = kcClassDecl decl
-
-kcTyClDecl decl@(ForeignType {})
-  = return decl
+kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
+  = kcTyClDeclBody decl	$ \ tvs' ->
+    do	{ discardResult (kcHsContext ctxt)
+	; mapM_ (wrapLocM (kcFamilyDecl tvs')) ats
+	; mapM_ (wrapLocM kc_sig) sigs }
+  where
+    kc_sig (TypeSig _ op_ty)    = discardResult (kcHsLiftedSigType op_ty)
+    kc_sig (GenericSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty)
+    kc_sig _                    = return ()
 
-kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym"
+kcTyClDecl (TySynonym {})     -- Type synonyms are never passed to kcTyClDecl
+  = panic "kcTyClDecl TySynonym"
 
+--------------------
 kcTyClDeclBody :: TyClDecl Name
 	       -> ([LHsTyVarBndr Name] -> TcM a)
 	       -> TcM a
@@ -343,104 +407,84 @@ kcTyClDeclBody decl thing_inside
 			   zipWith add_kind hs_tvs kinds
 	; tcExtendKindEnvTvs kinded_tvs thing_inside }
   where
-    add_kind (L loc (UserTyVar n _))   k = L loc (UserTyVar n k)
-    add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
+    add_kind (L loc (UserTyVar n _))       k = L loc (UserTyVar n k)
+    add_kind (L loc (KindedTyVar n hsk _)) k = L loc (KindedTyVar n hsk k)
 
+-------------------
 -- Kind check a data declaration, assuming that we already extended the
 -- kind environment with the type variables of the left-hand side (these
 -- kinded type variables are also passed as the second parameter).
 --
-kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name)
-kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
-	   tvs
-  = do	{ ctxt' <- kcHsContext ctxt	
-	; cons' <- mapM (wrapLocM kc_con_decl) cons
-	; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
-  where
+kcDataDecl :: TyClDecl Name -> TcM ()
+kcDataDecl (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
+  = do	{ _ <- kcHsContext ctxt
+	; _ <- mapM (wrapLocM (kcConDecl new_or_data)) cons
+	; return () }
+kcDataDecl d = pprPanic "kcDataDecl" (ppr d)
+
+-------------------
+kcConDecl :: NewOrData -> ConDecl Name -> TcM (ConDecl Name)
     -- doc comments are typechecked to Nothing here
-    kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
-                                  , con_cxt = ex_ctxt, con_details = details, con_res = res })
-      = addErrCtxt (dataConCtxt name)	$ 
-        kcHsTyVars ex_tvs $ \ex_tvs' -> do
-        do { ex_ctxt' <- kcHsContext ex_ctxt
-           ; details' <- kc_con_details details 
-           ; res'     <- case res of
-                ResTyH98 -> return ResTyH98
-                ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
-           ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
-                              , con_details = details', con_res = res' }) }
-
-    kc_con_details (PrefixCon btys) 
-	= do { btys' <- mapM kc_larg_ty btys 
+kcConDecl new_or_data con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
+                            , con_cxt = ex_ctxt, con_details = details, con_res = res })
+  = addErrCtxt (dataConCtxt name) $
+    kcHsTyVars ex_tvs $ \ex_tvs' ->
+    do { ex_ctxt' <- kcHsContext ex_ctxt
+       ; details' <- kc_con_details details
+       ; res'     <- case res of
+            ResTyH98 -> return ResTyH98
+            ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
+       ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
+                          , con_details = details', con_res = res' }) }
+  where
+    kc_con_details (PrefixCon btys)
+        = do { btys' <- mapM kc_larg_ty btys
              ; return (PrefixCon btys') }
-    kc_con_details (InfixCon bty1 bty2) 
-	= do { bty1' <- kc_larg_ty bty1
+    kc_con_details (InfixCon bty1 bty2)
+        = do { bty1' <- kc_larg_ty bty1
              ; bty2' <- kc_larg_ty bty2
              ; return (InfixCon bty1' bty2') }
-    kc_con_details (RecCon fields) 
-	= do { fields' <- mapM kc_field fields
+    kc_con_details (RecCon fields)
+        = do { fields' <- mapM kc_field fields
              ; return (RecCon fields') }
 
     kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
-					   ; return (ConDeclField fld bty' d) }
+                                           ; return (ConDeclField fld bty' d) }
 
     kc_larg_ty bty = case new_or_data of
-			DataType -> kcHsSigType bty
-			NewType  -> kcHsLiftedSigType bty
-	-- Can't allow an unlifted type for newtypes, because we're effectively
-	-- going to remove the constructor while coercing it to a lifted type.
-	-- And newtypes can't be bang'd
-kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
+                        DataType -> kcHsSigType bty
+                        NewType  -> kcHsLiftedSigType bty
+        -- Can't allow an unlifted type for newtypes, because we're effectively
+        -- going to remove the constructor while coercing it to a lifted type.
+        -- And newtypes can't be bang'd
 
+-------------------
 -- Kind check a family declaration or type family default declaration.
 --
 kcFamilyDecl :: [LHsTyVarBndr Name]  -- tyvars of enclosing class decl if any
-             -> TyClDecl Name -> TcM (TyClDecl Name)
+             -> TyClDecl Name -> TcM ()
 kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
   = kcTyClDeclBody decl $ \tvs' ->
     do { mapM_ unifyClassParmKinds tvs'
-       ; return (decl {tcdTyVars = tvs', 
-		       tcdKind = kind `mplus` Just liftedTypeKind})
-		       -- default result kind is '*'
-       }
+       ; discardResult (scDsLHsMaybeKind kind) }
   where
     unifyClassParmKinds (L _ tv) 
       | (n,k) <- hsTyVarNameKind tv
       , Just classParmKind <- lookup n classTyKinds 
-      = unifyKind k classParmKind
+      = let ctxt = ptext (    sLit "When kind checking family declaration")
+                          <+> ppr (tcdLName decl)
+        in addErrCtxt ctxt $ unifyKind k classParmKind >> return ()
       | otherwise = return ()
     classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
 
-kcFamilyDecl _ decl@(TySynonym {})
-  = return decl
+kcFamilyDecl _ (TySynonym {}) = return ()
    -- We don't have to do anything here for type family defaults:
    -- tcClassATs will use tcAssocDecl to check them
 kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
 
-kcClassDecl :: TyClDecl Name -> TcM (TyClDecl Name)
-kcClassDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats, tcdATDefs = atds})
-  = kcTyClDeclBody decl $ \ tvs' ->
-    do  { ctxt' <- kcHsContext ctxt
-        ; ats'  <- mapM (wrapLocM (kcFamilyDecl tvs')) ats
-        ; atds' <- mapM (\def_ldecl@(L loc def_decl) -> setSrcSpan loc $ tcAddDefaultAssocDeclCtxt def_decl $ wrapLocM kcFamInstDecl def_ldecl) atds
-        ; sigs' <- mapM (wrapLocM kc_sig) sigs
-        ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
-                        tcdATs = ats', tcdATDefs = atds'}) }
-  where
-    kc_sig (TypeSig nm op_ty)    = do { op_ty' <- kcHsLiftedSigType op_ty
-                                      ; return (TypeSig nm op_ty') }
-    kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
-                                      ; return (GenericSig nm op_ty') }
-    kc_sig other_sig             = return other_sig
-
-kcClassDecl d = pprPanic "kcClassDecl" (ppr d)
-
-kcFamInstDecl :: TyClDecl Name -> TcM (TyClDecl Name)
-kcFamInstDecl decl = kcFamTyPats decl $ \k_tvs k_typats resKind -> do
-    -- kind check the right-hand side of the type equation
-    k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
-      -- ToDo: the ExpKind could be better
-    return (decl { tcdTyVars = k_tvs, tcdTyPats = Just k_typats, tcdSynRhs = k_rhs })
+-------------------
+discardResult :: TcM a -> TcM ()
+discardResult a = a >> return ()
 \end{code}
 
 
@@ -450,9 +494,52 @@ kcFamInstDecl decl = kcFamTyPats decl $ \k_tvs k_typats resKind -> do
 %*									*
 %************************************************************************
 
+Note [Type checking recursive type and class declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At this point we have completed *kind-checking* of a mutually
+recursive group of type/class decls (done in kcTyClGroup). However,
+we discarded the kind-checked types (eg RHSs of data type decls); 
+note that kcTyClDecl returns ().  There are two reasons:
+
+  * It's convenient, because we don't have to rebuild a
+    kinded HsDecl (a fairly elaborate type)
+
+  * It's necessary, because after kind-generalisation, the
+    TyCons/Classes may now be kind-polymorphic, and hence need
+    to be given kind arguments.  
+
+Example:
+       data T f a = MkT (f a) (T f a)
+During kind-checking, we give T the kind T :: k1 -> k2 -> *
+and figure out constraints on k1, k2 etc. Then we generalise
+to get   T :: forall k. (k->*) -> k -> *
+So now the (T f a) in the RHS must be elaborated to (T k f a).
+    
+However, during tcTyClDecl of T (above) we will be in a recursive
+"knot". So we aren't allowed to look at the TyCon T itself; we are only
+allowed to put it (lazily) in the returned structures.  But when
+kind-checking the RHS of T's decl, we *do* need to know T's kind (so
+that we can correctly elaboarate (T k f a).  How can we get T's kind
+without looking at T?  Delicate answer: during tcTyClDecl, we extend
+
+  *Global* env with T -> ATyCon (the (not yet built) TyCon for T)
+  *Local*  env with T -> AThing (polymorphic kind of T)
+
+Then:
+
+  * During TcHsType.kcTyVar we look in the *local* env, to get the
+    known kind for T.
+
+  * But in TcHsType.ds_type (and ds_var_app in particular) we look in
+    the *global* env to get the TyCon. But we must be careful not to
+    force the TyCon or we'll get a loop.
+
+This fancy footwork (with two bindings for T) is only necesary for the
+TyCons or Classes of this recursive group.  Earlier, finished groups,
+live in the global env only.
+
 \begin{code}
 tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
-
 tcTyClDecl calc_isrec (L loc decl)
   = setSrcSpan loc $ tcAddDeclCtxt decl $
     traceTc "tcTyAndCl-x" (ppr decl) >>
@@ -460,53 +547,48 @@ tcTyClDecl calc_isrec (L loc decl)
 
   -- "type family" declarations
 tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
-tcTyClDecl1 parent _calc_isrec 
-  (TyFamily {tcdFlavour = TypeFamily, 
-	     tcdLName = L _ tc_name, tcdTyVars = tvs,
-             tcdKind = Just kind}) -- NB: kind at latest added during kind checking
-  = tcTyVarBndrs tvs  $ \ tvs' -> do 
-  { traceTc "type family:" (ppr tc_name) 
+tcTyClDecl1 parent _calc_isrec
+              (TyFamily {tcdFlavour = TypeFamily, tcdLName = L _ tc_name, tcdTyVars = tvs})
+  = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
+  { traceTc "type family:" (ppr tc_name)
   ; checkFamFlag tc_name
   ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
-  ; return [ATyCon tycon]
-  }
+  ; return [ATyCon tycon] }
 
   -- "data family" declaration
-tcTyClDecl1 parent _calc_isrec 
-  (TyFamily {tcdFlavour = DataFamily, 
-	     tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
-  = tcTyVarBndrs tvs  $ \ tvs' -> do 
-  { traceTc "data family:" (ppr tc_name) 
+tcTyClDecl1 parent _calc_isrec
+              (TyFamily {tcdFlavour = DataFamily, tcdLName = L _ tc_name, tcdTyVars = tvs})
+  = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
+  { traceTc "data family:" (ppr tc_name)
   ; checkFamFlag tc_name
-  ; extra_tvs <- tcDataKindSig mb_kind
+  ; extra_tvs <- tcDataKindSig kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
-  ; tycon <- buildAlgTyCon tc_name final_tvs [] 
-               DataFamilyTyCon Recursive True 
-               parent Nothing
-  ; return [ATyCon tycon]
-  }
+  ; tycon <- buildAlgTyCon tc_name final_tvs []
+               DataFamilyTyCon Recursive True parent Nothing
+  ; return [ATyCon tycon] }
 
   -- "type" synonym declaration
 tcTyClDecl1 _parent _calc_isrec
-  (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
+            (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
   = ASSERT( isNoParent _parent )
-    tcTyVarBndrs tvs		$ \ tvs' -> do 
-    { traceTc "tcd1" (ppr tc_name) 
-    ; rhs_ty' <- tcHsKindedType rhs_ty
-    ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') 
-      	       		     (typeKind rhs_ty') NoParentTyCon  Nothing
+    tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
+    { rhs_ty' <- tcCheckHsType rhs_ty kind
+    ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
+      	       		     kind NoParentTyCon Nothing
     ; return [ATyCon tycon] }
 
   -- "newtype" and "data"
   -- NB: not used for newtype/data instances (whether associated or not)
 tcTyClDecl1 _parent calc_isrec
-  (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
-	   tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
+              (TyData { tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs
+	              , tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons })
   = ASSERT( isNoParent _parent )
-    tcTyVarBndrs tvs	$ \ tvs' -> do 
-  { extra_tvs <- tcDataKindSig mb_ksig
+    let is_rec   = calc_isrec tc_name
+        h98_syntax = consUseH98Syntax cons in
+    tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
+  { extra_tvs <- tcDataKindSig kind
   ; let final_tvs = tvs' ++ extra_tvs
-  ; stupid_theta <- tcHsKindedContext ctxt
+  ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt
   ; kind_signatures <- xoptM Opt_KindSignatures
   ; existential_ok <- xoptM Opt_ExistentialQuantification
   ; gadt_ok      <- xoptM Opt_GADTs
@@ -518,9 +600,9 @@ tcTyClDecl1 _parent calc_isrec
 
   ; dataDeclChecks tc_name new_or_data stupid_theta cons
 
-  ; tycon <- fixM (\ tycon -> do 
+  ; tycon <- fixM (\ tycon -> do
 	{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
-	; data_cons <- tcConDecls ex_ok tycon (final_tvs, res_ty) cons
+	; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons
 	; tc_rhs <-
 	    if null cons && is_boot 	      -- In a hs-boot file, empty cons means
 	    then return totallyAbstractTyConRhs  -- "don't know"; hence totally Abstract
@@ -531,34 +613,34 @@ tcTyClDecl1 _parent calc_isrec
 	; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
 	    (not h98_syntax) NoParentTyCon Nothing
 	})
-  ; return [ATyCon tycon]
-  }
-  where
-    is_rec   = calc_isrec tc_name
-    h98_syntax = consUseH98Syntax cons
+  ; return [ATyCon tycon] }
 
-tcTyClDecl1 _parent calc_isrec 
-  (ClassDecl {tcdLName = L _ class_tycon_name, tcdTyVars = tvs, 
-	      tcdCtxt = ctxt, tcdMeths = meths,
-	      tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats, tcdATDefs = at_defs} )
+tcTyClDecl1 _parent calc_isrec
+            (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs
+	      , tcdCtxt = ctxt, tcdMeths = meths
+	      , tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats, tcdATDefs = at_defs })
   = ASSERT( isNoParent _parent )
-    tcTyVarBndrs tvs		$ \ tvs' -> do 
-  { ctxt' <- tcHsKindedContext ctxt
-  ; fds' <- mapM (addLocM tc_fundep) fundeps
-  ; (sig_stuff, gen_dm_env) <- tcClassSigs class_tycon_name sigs meths
+    do 
+  { (tvs', ctxt', fds', sig_stuff, gen_dm_env)
+       <- tcTyClTyVars class_name tvs $ \ tvs' kind -> do
+          { MASSERT( isConstraintKind kind )
+          ; ctxt' <- tcHsKindedContext =<< kcHsContext ctxt
+          ; fds' <- mapM (addLocM tc_fundep) fundeps
+          ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
+          ; return (tvs', ctxt', fds', sig_stuff, gen_dm_env) }
   ; clas <- fixM $ \ clas -> do
 	    { let 	-- This little knot is just so we can get
 			-- hold of the name of the class TyCon, which we
 			-- need to look up its recursiveness
 		    tycon_name = tyConName (classTyCon clas)
 		    tc_isrec = calc_isrec tycon_name
-            
-            ; at_stuff <- tcClassATs clas tvs' ats at_defs
+
+            ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs
             -- NB: 'ats' only contains "type family" and "data family" declarations
             -- and 'at_defs' only contains associated-type defaults
-            
+
             ; buildClass False {- Must include unfoldings for selectors -}
-			 class_tycon_name tvs' ctxt' fds' at_stuff
+			 class_name tvs' ctxt' fds' at_stuff
 			 sig_stuff tc_isrec }
 
   ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
@@ -583,8 +665,6 @@ tcTyClDecl1 _parent calc_isrec
 tcTyClDecl1 _ _
   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
   = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
-
-tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
 \end{code}
 
 %************************************************************************
@@ -594,24 +674,31 @@ tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
 %*									*
 %************************************************************************
 
-Example:     class C a where
+Note [Associated type defaults]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The following is an example of associated type defaults:
+             class C a where
                data D a 
 
                type F a b :: *
                type F a Z = [a]        -- Default
                type F a (S n) = F a n  -- Default
 
-We can get default defns only for type families, not data families
-	
+Note that:
+  - We can have more than one default definition for a single associated type,
+    as long as they do not overlap (same rules as for instances)
+  - We can get default definitions only for type families, not data families
+
 \begin{code}
-tcClassATs :: Class            -- The class
-           -> [TyVar]          -- Class type variables (can't look them up in class b/c its knot-tied)
+tcClassATs :: Name             -- The class name (not knot-tied)
+           -> TyConParent      -- The class parent of this associated type
            -> [LTyClDecl Name] -- Associated types. All FamTyCon
            -> [LTyClDecl Name] -- Associated type defaults. All SynTyCon
            -> TcM [ClassATItem]
-tcClassATs clas clas_tvs ats at_defs
+tcClassATs class_name parent ats at_defs
   = do {  -- Complain about associated type defaults for non associated-types
-         sequence_ [ failWithTc (badATErr clas n)
+         sequence_ [ failWithTc (badATErr class_name n)
                    | n <- map (tcdName . unLoc) at_defs
                    , not (n `elemNameSet` at_names) ]
        ; mapM tc_at ats }
@@ -623,57 +710,41 @@ tcClassATs clas clas_tvs ats at_defs
     at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv (tcdName (unLoc at_def)) [at_def]) 
                         emptyNameEnv at_defs
 
-    tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) at
-                  ; atd <- mapM (tcDefaultAssocDecl fam_tc clas_tvs)
-                                (lookupNameEnv at_defs_map (tyConName fam_tc) `orElse` []) 
+    tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 parent
+                                                           (const Recursive)) at
+                  ; let at_defs = lookupNameEnv at_defs_map (tcdName (unLoc at))
+                                        `orElse` []
+                  ; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs
                   ; return (fam_tc, atd) }
 
 
 -------------------------
 tcDefaultAssocDecl :: TyCon              -- ^ Family TyCon
-                   -> [TyVar]            -- ^ TyVars of associated type's class
                    -> LTyClDecl Name     -- ^ RHS
                    -> TcM ATDefault      -- ^ Type checked RHS and free TyVars
-tcDefaultAssocDecl fam_tc clas_tvs (L loc decl)
+tcDefaultAssocDecl fam_tc (L loc decl)
   = setSrcSpan loc $
-    tcAddDefaultAssocDeclCtxt decl $
+    tcAddDefaultAssocDeclCtxt (tcdName decl) $
     do { traceTc "tcDefaultAssocDecl" (ppr decl)
        ; (at_tvs, at_tys, at_rhs) <- tcSynFamInstDecl fam_tc decl
-       
-       -- See Note [Checking consistent instantiation]
-       -- We only want to check this on the *class* TyVars,
-       -- not the *family* TyVars (there may be more of these)
-       ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys
-
-       ; return (ATD at_tvs at_tys at_rhs) }
-  where
-    check_arg fam_tc_tv at_ty
-      = checkTc (not (fam_tc_tv `elem` clas_tvs) || mkTyVarTy fam_tc_tv `eqType` at_ty) 
-                (wrongATArgErr at_ty (mkTyVarTy fam_tc_tv))
-
+       ; return (ATD at_tvs at_tys at_rhs loc) }
+-- We check for well-formedness and validity later, in checkValidClass
 -------------------------
+
 tcSynFamInstDecl :: TyCon -> TyClDecl Name -> TcM ([TyVar], [Type], Type)
-tcSynFamInstDecl fam_tc (decl@TySynonym {})
-  = do { -- check that the family declaration is for a synonym
-         checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
+tcSynFamInstDecl fam_tc (TySynonym { tcdTyVars = tvs, tcdTyPats = Just pats
+                                   , tcdSynRhs = rhs })
+  = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
-         -- we need the exact same number of type parameters as the family
-         -- declaration
-       ; let famArity = tyConArity fam_tc
-             Just k_typats = tcdTyPats decl
-       ; checkTc (length k_typats == famArity) $
-                 wrongNumberOfParmsErr famArity
+       ; let kc_rhs rhs kind = kcCheckLHsType rhs (EK kind EkUnk) 
 
-         -- type check type equation
-       ; tcTyVarBndrs (tcdTyVars decl) $ \t_tvs -> do   -- turn kinded into proper tyvars
-       { t_typats <- mapM tcHsKindedType k_typats
-       ; t_rhs    <- tcHsKindedType (tcdSynRhs decl)
+       ; tcFamTyPats fam_tc tvs pats (kc_rhs rhs)
+                $ \tvs' pats' res_kind -> do
 
-        -- NB: we don't check well-formedness of the instance here because we call
-        -- this function from within the TcTyClsDecls fixpoint. The callers must do
-        -- the check.
+       { rhs'  <- kc_rhs rhs res_kind
+       ; rhs'' <- tcHsKindedType rhs'
 
-       ; return (t_tvs, t_typats, t_rhs) }}
+       ; return (tvs', pats', rhs'') } }
 
 tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl)
 
@@ -684,33 +755,83 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl)
 --   not check whether there is a pattern for each type index; the latter
 --   check is only required for type synonym instances.
 
-kcFamTyPats :: TyClDecl Name
-            -> ([LHsTyVarBndr Name] -> [LHsType Name] -> TcKind -> TcM a)
-               -- ^^kinded tvs         ^^kinded ty pats  ^^res kind
+-----------------
+tcFamTyPats :: TyCon
+            -> [LHsTyVarBndr Name] -> [LHsType Name]
+            -> (TcKind -> TcM any)      -- Kind checker for RHS
+                                        -- result is ignored
+            -> ([KindVar] -> [TcKind] -> Kind -> TcM a)
             -> TcM a
-kcFamTyPats decl thing_inside
-  = kcHsTyVars (tcdTyVars decl) $ \tvs ->
-    do { fam_tc_kind <- kcLookupKind (tcdLName decl)
-       
-         -- First, check that the shape of the kind implied by the
-         -- instance syntax matches that of the corresponding family
-       ; let hs_typats = fromJust $ tcdTyPats decl
-       ; pat_kinds <- mapM (\_ -> newKindVar) hs_typats
-       ; res_kind <- newKindVar
-       ; checkExpectedKind (tcdLName decl) fam_tc_kind (EK (mkArrowKinds pat_kinds res_kind) EkUnk)
-          -- TODO: better expected kind error?
-
-         -- Next, ensure that the types in given patterns have the right kind
-       ; typats <- zipWithM kcCheckLHsType hs_typats
-                            [ EK kind (EkArg (ppr (tcdLName decl)) n)
-                            | (kind,n) <- pat_kinds `zip` [1..]]
-
-         -- It is the responsibliity of the thing_inside to check that the instance
-         -- RHS has a kind matching that implied by the family
-       ; thing_inside tvs typats res_kind 
+-- Check the type patterns of a type or data family instance
+--     type instance F <pat1> <pat2> = <type>
+-- The 'tyvars' are the free type variables of pats
+-- 
+-- NB: The family instance declaration may be an associated one,
+-- nested inside an instance decl, thus
+--	  instance C [a] where
+--	    type F [a] = ...
+-- In that case, the type variable 'a' will *already be in scope*
+-- (and, if C is poly-kinded, so will its kind parameter).
+
+tcFamTyPats fam_tc tyvars pats kind_checker thing_inside
+  = kcHsTyVars tyvars $ \tvs ->
+    do { let (fam_kvs, body) = splitForAllTys (tyConKind fam_tc)
+
+         -- A family instance must have exactly the same number of type
+         -- parameters as the family declaration.  You can't write
+         --     type family F a :: * -> *
+         --     type instance F Int y = y
+         -- because then the type (F Int) would be like (\y.y)
+       ; let fam_arity = tyConArity fam_tc - length fam_kvs
+       ; checkTc (length pats == fam_arity) $
+                 wrongNumberOfParmsErr fam_arity
+
+         -- Instantiate with meta kind vars
+       ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs
+       ; let body' = substKiWith fam_kvs fam_arg_kinds body
+             (kinds, resKind) = splitKindFunTysN fam_arity body'
+       ; typats <- zipWithM kcCheckLHsType pats
+                            [ EK kind (EkArg (ppr fam_tc) n)
+                            | (kind,n) <- kinds `zip` [1..]]
+
+        -- Kind check the "thing inside"; this just works by 
+        -- side-effecting any kind unification variables
+       ; _ <- kind_checker resKind
+
+         -- Type check indexed data type declaration
+         -- We kind generalize the kind patterns since they contain
+         -- all the meta kind variables
+         -- See Note [Quantifying over family patterns]
+       ; tcTyVarBndrsKindGen tvs $ \tvs' -> do {
+
+       ; (t_kvs, fam_arg_kinds') <- kindGeneralizeKinds fam_arg_kinds
+       ; k_typats <- mapM tcHsKindedType typats
+
+       ; thing_inside (t_kvs ++ tvs') (fam_arg_kinds' ++ k_typats) resKind }
        }
 \end{code}
 
+Note [Quantifying over family patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to quantify over two different lots of kind variables:
+
+First, the ones that come from tcTyVarBndrsKindGen, as usual
+  data family Dist a 
+
+  -- Proxy :: forall k. k -> *
+  data instance Dist (Proxy a) = DP
+  -- Generates  data DistProxy = DP
+  --            ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a
+  -- The 'k' comes from the tcTyVarBndrsKindGen (a::k)
+
+Second, the ones that come from the kind argument of the type family
+which we pick up using kindGeneralizeKinds:
+  -- Any :: forall k. k
+  data instance Dist Any = DA
+  -- Generates  data DistAny k = DA
+  --            ax7 k :: Dist k (Any k) ~ DistAny k 
+  -- The 'k' comes from kindGeneralizeKinds (Any k)
+
 Note [Associated type instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We allow this:
@@ -779,29 +900,36 @@ dataDeclChecks tc_name new_or_data stupid_theta cons
                 (emptyConDeclsErr tc_name) }
     
 -----------------------------------
-tcConDecls :: Bool -> TyCon -> ([TyVar], Type)
+tcConDecls :: NewOrData -> Bool -> TyCon -> ([TyVar], Type)
 	   -> [LConDecl Name] -> TcM [DataCon]
-tcConDecls ex_ok rep_tycon res_tmpl cons
-  = mapM (addLocM (tcConDecl ex_ok rep_tycon res_tmpl)) cons
+tcConDecls new_or_data ex_ok rep_tycon res_tmpl cons
+  = mapM (addLocM (tcConDecl new_or_data ex_ok rep_tycon res_tmpl)) cons
 
-tcConDecl :: Bool		-- True <=> -XExistentialQuantificaton or -XGADTs
+tcConDecl :: NewOrData
+          -> Bool		-- True <=> -XExistentialQuantificaton or -XGADTs
 	  -> TyCon 		-- Representation tycon
 	  -> ([TyVar], Type)	-- Return type template (with its template tyvars)
 	  -> ConDecl Name 
 	  -> TcM DataCon
 
-tcConDecl existential_ok rep_tycon res_tmpl 	-- Data types
-	  con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
-                   , con_details = details, con_res = res_ty })
-  = addErrCtxt (dataConCtxt name)	$ 
-    tcTyVarBndrs tvs			$ \ tvs' -> do 
+tcConDecl new_or_data existential_ok rep_tycon res_tmpl 	-- Data types
+	  con@(ConDecl {con_name = name})
+  = do
+    { ConDecl { con_qvars = tvs, con_cxt = ctxt
+              , con_details = details, con_res = res_ty }
+        <- kcConDecl new_or_data con
+    ; addErrCtxt (dataConCtxt name) $
+    tcTyVarBndrsKindGen tvs $ \ tvs' -> do
     { ctxt' <- tcHsKindedContext ctxt
     ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
 	      (badExistential name)
+    ; traceTc "tcConDecl 1" (ppr con)
     ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
-    ; let 
+    ; let
 	tc_datacon is_infix field_lbls btys
 	  = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys
+	       ; traceTc "tcConDecl 3" (ppr name)
+
     	       ; buildDataCon (unLoc name) is_infix
     		    stricts field_lbls
     		    univ_tvs ex_tvs eq_preds ctxt' arg_tys
@@ -810,6 +938,7 @@ tcConDecl existential_ok rep_tycon res_tmpl 	-- Data types
 		--	constructor type signature into the data constructor;
 		--	that way checkValidDataCon can complain if it's wrong.
 
+    ; traceTc "tcConDecl 2" (ppr name)
     ; case details of
 	PrefixCon btys     -> tc_datacon False [] btys
 	InfixCon bty1 bty2 -> tc_datacon True  [] [bty1,bty2]
@@ -817,7 +946,7 @@ tcConDecl existential_ok rep_tycon res_tmpl 	-- Data types
 			   where
 			      field_names = map (unLoc . cd_fld_name) fields
 			      btys        = map cd_fld_type fields
-    }
+    } }
 
 -- Example
 --   data instance T (b,c) where 
@@ -838,7 +967,7 @@ tcResultType :: ([TyVar], Type)	-- Template for result type; e.g.
 		     [(TyVar,Type)],	-- Equality predicates
 		     Type)		-- Typechecked return type
 	-- We don't check that the TyCon given in the ResTy is
-	-- the same as the parent tycon, becuase we are in the middle
+	-- the same as the parent tycon, because we are in the middle
 	-- of a recursive knot; so it's postponed until checkValidDataCon
 
 tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98
@@ -859,6 +988,11 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
 	-- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)
   = do	{ res_ty' <- tcHsKindedType res_ty
 	; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'
+                -- This 'Just' pattern is sure to match, because if not
+                -- checkValidDataCon will complain first. The 'subst'
+                -- should not be looked at until after checkValidDataCon
+                -- We can't check eagerly because we are in a "knot" in 
+                -- which 'tycon' is not yet fully defined
 
 		-- /Lazily/ figure out the univ_tvs etc
 		-- Each univ_tv is either a dc_tv or a tmpl_tv
@@ -868,7 +1002,9 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
 		= case tcGetTyVar_maybe ty of
 		    Just tv | not (tv `elem` univs)
 			    -> (tv:univs,   eqs)
-		    _other  -> (tmpl:univs, (tmpl,ty):eqs)
+		    _other  -> (new_tmpl:univs, (new_tmpl,ty):eqs)
+                               where  -- see Note [Substitution in template variables kinds]
+                                 new_tmpl = updateTyVarKind (substTy subst) tmpl
 		| otherwise = pprPanic "tcResultType" (ppr res_ty)
 	      ex_tvs = dc_tvs `minusList` univ_tvs
 
@@ -886,6 +1022,44 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
 		 name = tyVarName tv
 		 (env', occ') = tidyOccName env (getOccName name) 
 
+{-
+Note [Substitution in template variables kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+data List a = Nil | Cons a (List a)
+data SList s as where
+  SNil :: SList s Nil
+
+We call tcResultType with
+  tmpl_tvs = [(k :: BOX), (s :: k -> *), (as :: List k)]
+  res_tmpl = SList k s as
+  res_ty = ResTyGADT (SList k1 (s1 :: k1 -> *) (Nil k1))
+
+We get subst:
+  k -> k1
+  s -> s1
+  as -> Nil k1
+
+Now we want to find out the universal variables and the equivalences
+between some of them and types (GADT).
+
+In this example, k and s are mapped to exactly variables which are not
+already present in the universal set, so we just add them without any
+coercion.
+
+But 'as' is mapped to 'Nil k1', so we add 'as' to the universal set,
+and add the equivalence with 'Nil k1' in 'eqs'.
+
+The problem is that with kind polymorphism, as's kind may now contain
+kind variables, and we have to apply the template substitution to it,
+which is why we create new_tmpl.
+
+The template substitution only maps kind variables to kind variables,
+since GADTs are not kind indexed.
+
+-}
+
+
 consUseH98Syntax :: [LConDecl a] -> Bool
 consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
 consUseH98Syntax _                                             = True
@@ -909,7 +1083,9 @@ conRepresentibleWithH98Syntax
 -------------------
 tcConArg :: LHsType Name -> TcM (TcType, HsBang)
 tcConArg bty
-  = do  { arg_ty <- tcHsBangType bty
+  = do  { traceTc "tcConArg 1" (ppr bty)
+        ; arg_ty <- tcHsBangType bty
+        ; traceTc "tcConArg 2" (ppr bty)
         ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty)
 	; return (arg_ty, strict_mark) }
 
@@ -926,6 +1102,7 @@ chooseBoxingStrategy arg_ty bang
 	HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields
                        ; if unbox_strict then return (can_unbox HsStrict arg_ty)
                                          else return HsStrict }
+	HsNoUnpack -> return HsStrict
 	HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas
             -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
 	    -- See Trac #5252: unpacking means we must not conceal the
@@ -1002,10 +1179,15 @@ checkValidTyCl :: TyClDecl Name -> TcM ()
 -- only so that we can add a nice context with tcAddDeclCtxt
 checkValidTyCl decl
   = tcAddDeclCtxt decl $
-    do	{ thing <- tcLookupLocatedGlobal (tcdLName decl)
-	; traceTc "Validity of" (ppr thing)	
+    do	{ traceTc "Validity of 1" (ppr decl)
+        ; env <- getGblEnv
+	; traceTc "Validity of 1a" (ppr (tcg_type_env env))
+	; thing <- tcLookupLocatedGlobal (tcdLName decl)
+	; traceTc "Validity of 2" (ppr decl)
+	; traceTc "Validity of" (ppr thing)
 	; case thing of
 	    ATyCon tc -> do
+                traceTc "  of kind" (ppr (tyConKind tc))
                 checkValidTyCon tc
                 case decl of
                   ClassDecl { tcdATs = ats } -> mapM_ (addLocM checkValidTyCl) ats
@@ -1041,14 +1223,16 @@ checkValidTyCon tc
       SynFamilyTyCon {} -> return ()
       SynonymTyCon ty   -> checkValidType syn_ctxt ty
   | otherwise
-  = do	-- Check the context on the data decl
-    checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
+  = do { -- Check the context on the data decl
+       ; traceTc "cvtc1" (ppr tc)
+       ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
 	
 	-- Check arg types of data constructors
-    mapM_ (checkValidDataCon tc) data_cons
+       ; traceTc "cvtc2" (ppr tc)
+       ; mapM_ (checkValidDataCon tc) data_cons
 
 	-- Check that fields with the same name share a type
-    mapM_ check_fields groups
+       ; mapM_ check_fields groups }
 
   where
     syn_ctxt  = TySynCtxt name
@@ -1117,12 +1301,15 @@ checkValidDataCon tc con
 				res_ty_tmpl
 				actual_res_ty))
 		  (badDataConTyCon con res_ty_tmpl actual_res_ty)
+             -- IA0_TODO: we should also check that kind variables
+             -- are only instantiated with kind variables
 	; checkValidMonoType (dataConOrigResTy con)
 		-- Disallow MkT :: T (forall a. a->a)
 		-- Reason: it's really the argument of an equality constraint
 	; checkValidType ctxt (dataConUserType con)
 	; when (isNewTyCon tc) (checkNewDataCon con)
         ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
+        ; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con))
     }
   where
     ctxt = ConArgCtxt (dataConName con) 
@@ -1170,8 +1357,9 @@ checkValidClass cls
 	-- Check the class operations
 	; mapM_ (check_op constrained_class_methods) op_stuff
 
-        -- Check the associated type defaults are well-formed
-        ; mapM_ check_at at_stuff
+        -- Check the associated type defaults are well-formed and instantiated
+        -- See Note [Checking consistent instantiation]
+        ; mapM_ check_at_defs at_stuff
 
   	-- Check that if the class has generic methods, then the
 	-- class has only one parameter.  We can't do generic
@@ -1180,17 +1368,17 @@ checkValidClass cls
 	}
   where
     (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls
-    unary 	= isSingleton tyvars
+    unary 	= isSingleton (snd (splitKiTyVars tyvars))  -- IA0_NOTE: only count type arguments
     no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
 
     check_op constrained_class_methods (sel_id, dm) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
-	{ checkValidTheta SigmaCtxt (tail theta)
+	{ checkValidTheta ctxt (tail theta)
 		-- The 'tail' removes the initial (C a) from the
 		-- class itself, leaving just the method type
 
 	; traceTc "class op type" (ppr op_ty <+> ppr tau)
-	; checkValidType (FunSigCtxt op_name) tau
+	; checkValidType ctxt tau
 
 		-- Check that the type mentions at least one of
 		-- the class type variables...or at least one reachable
@@ -1208,6 +1396,7 @@ checkValidClass cls
             _                  -> return ()
 	}
 	where
+          ctxt    = FunSigCtxt op_name
 	  op_name = idName sel_id
 	  op_ty   = idType sel_id
 	  (_,theta1,tau1) = tcSplitSigmaTy op_ty
@@ -1221,8 +1410,21 @@ checkValidClass cls
 		-- in the context of a for-all must mention at least one quantified
 		-- type variable.  What a mess!
 
-    check_at (_fam_tc, defs)
-      = mapM_ (\(ATD _tvs pats rhs) -> checkValidFamInst pats rhs) defs
+    check_at_defs (fam_tc, defs)
+      = do mapM_ (\(ATD _tvs pats rhs _loc) -> checkValidFamInst pats rhs) defs
+           tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ 
+             mapM_ (check_loc_at_def fam_tc) defs
+
+    check_loc_at_def fam_tc (ATD _tvs pats _rhs loc)
+      -- Set the location for each of the default declarations
+      = setSrcSpan loc $ zipWithM_ check_arg (tyConTyVars fam_tc) pats
+
+    -- We only want to check this on the *class* TyVars,
+    -- not the *family* TyVars (there may be more of these)
+    check_arg fam_tc_tv at_ty
+      = checkTc (   not (fam_tc_tv `elem` tyvars)
+                 || mkTyVarTy fam_tc_tv `eqType` at_ty) 
+          (wrongATArgErr at_ty (mkTyVarTy fam_tc_tv))
 
 checkFamFlag :: Name -> TcM ()
 -- Check that we don't use families without -XTypeFamilies
@@ -1304,7 +1506,8 @@ mkRecSelBind (tycon, sel_name)
     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)  
     (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
-           | otherwise  = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ 
+           | otherwise  = mkForAllTys (varSetElemsKvsFirst $
+                                       data_tvs `extendVarSetList` field_tvs) $
     	     	          mkPhiTy (dataConStupidTheta con1) $	-- Urgh!
     	     	          mkPhiTy field_theta               $	-- Urgh!
              	          mkFunTy data_ty field_tau
@@ -1446,12 +1649,12 @@ gotten by appying the eq_spec to the univ_tvs of the data con.
 %************************************************************************
 
 \begin{code}
-tcAddDefaultAssocDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
-tcAddDefaultAssocDeclCtxt decl thing_inside
+tcAddDefaultAssocDeclCtxt :: Name -> TcM a -> TcM a
+tcAddDefaultAssocDeclCtxt name thing_inside
   = addErrCtxt ctxt thing_inside
   where
      ctxt = hsep [ptext (sLit "In the type synonym instance default declaration for"),
-                  quotes (ppr (tcdName decl))]
+                  quotes (ppr name)]
 
 resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
 resultTypeMisMatch field_name con1 con2
@@ -1521,7 +1724,7 @@ badDataConTyCon data_con res_ty_tmpl actual_res_ty
 		ptext (sLit "returns type") <+> quotes (ppr actual_res_ty))
        2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl))
 
-badATErr :: Outputable a => a -> Name -> SDoc
+badATErr :: Name -> Name -> SDoc
 badATErr clas op
   = hsep [ptext (sLit "Class"), quotes (ppr clas), 
           ptext (sLit "does not have an associated type"), quotes (ppr op)]
@@ -1583,7 +1786,12 @@ wrongATArgErr ty instTy =
       , ptext (sLit "Found") <+> quotes (ppr ty)
         <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
       ]
-
+{-
+tooManyParmsErr :: Name -> SDoc
+tooManyParmsErr tc_name
+  = ptext (sLit "Family instance has too many parameters:") <+>
+    quotes (ppr tc_name)
+-}
 wrongNumberOfParmsErr :: Arity -> SDoc
 wrongNumberOfParmsErr exp_arity
   = ptext (sLit "Number of parameters must match family declaration; expected")
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index cfbd4447f3..018655b04d 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -87,6 +87,7 @@ module TcType (
   -- * Tidying type related things up for printing
   tidyType,      tidyTypes,
   tidyOpenType,  tidyOpenTypes,
+  tidyOpenKind,
   tidyTyVarBndr, tidyFreeTyVars,
   tidyOpenTyVar, tidyOpenTyVars,
   tidyTopType,
@@ -117,7 +118,7 @@ module TcType (
   openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, 
   isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, 
   isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind,
-  kindVarRef, mkKindVar,  
+  mkMetaKindVar,
 
   --------------------------------
   -- Rexported from Type
@@ -346,16 +347,15 @@ data UserTypeCtxt
   | ExprSigCtxt		-- Expression type signature
   | ConArgCtxt Name	-- Data constructor argument
   | TySynCtxt Name	-- RHS of a type synonym decl
-  | GenPatCtxt		-- Pattern in generic decl
-			-- 	f{| a+b |} (Inl x) = ...
   | LamPatSigCtxt		-- Type sig in lambda pattern
 			-- 	f (x::t) = ...
   | BindPatSigCtxt	-- Type sig in pattern binding pattern
 			--	(x::t, y) = e
   | ResSigCtxt		-- Result type sig
 			-- 	f x :: t = ....
-  | ForSigCtxt Name	-- Foreign inport or export signature
+  | ForSigCtxt Name	-- Foreign import or export signature
   | DefaultDeclCtxt	-- Types in a default declaration
+  | InstDeclCtxt        -- An instance declaration
   | SpecInstCtxt	-- SPECIALISE instance pragma
   | ThBrackCtxt		-- Template Haskell type brackets [t| ... |]
   | GenSigCtxt          -- Higher-rank or impredicative situations
@@ -363,6 +363,14 @@ data UserTypeCtxt
                         -- We might want to elaborate this
   | GhciCtxt            -- GHCi command :kind <type>
 
+  | ClassSCCtxt Name	-- Superclasses of a class
+  | SigmaCtxt		-- Theta part of a normal for-all type
+			--	f :: <S> => a -> a
+  | DataTyCtxt Name	-- Theta part of a data decl
+			--	data <S> => T a = MkT a
+\end{code}
+
+
 -- Notes re TySynCtxt
 -- We allow type synonyms that aren't types; e.g.  type List = []
 --
@@ -375,26 +383,19 @@ data UserTypeCtxt
 
 ---------------------------------
 -- Kind variables:
-
+\begin{code}
 mkKindName :: Unique -> Name
 mkKindName unique = mkSystemName unique kind_var_occ
 
-kindVarRef :: KindVar -> IORef MetaDetails
-kindVarRef tc = 
-  ASSERT ( isTcTyVar tc )
-  case tcTyVarDetails tc of
-    MetaTv TauTv ref -> ref
-    _                -> pprPanic "kindVarRef" (ppr tc)
-
-mkKindVar :: Unique -> IORef MetaDetails -> KindVar
-mkKindVar u r 
+mkMetaKindVar :: Unique -> IORef MetaDetails -> MetaKindVar
+mkMetaKindVar u r
   = mkTcTyVar (mkKindName u)
               tySuperKind  -- not sure this is right,
                             -- do we need kind vars for
                             -- coercions?
               (MetaTv TauTv r)
 
-kind_var_occ :: OccName	-- Just one for all KindVars
+kind_var_occ :: OccName	-- Just one for all MetaKindVars
 			-- They may be jiggled by tidying
 kind_var_occ = mkOccName tvName "k"
 \end{code}
@@ -422,16 +423,19 @@ pprUserTypeCtxt (FunSigCtxt n)    = ptext (sLit "the type signature for") <+> qu
 pprUserTypeCtxt ExprSigCtxt       = ptext (sLit "an expression type signature")
 pprUserTypeCtxt (ConArgCtxt c)    = ptext (sLit "the type of the constructor") <+> quotes (ppr c)
 pprUserTypeCtxt (TySynCtxt c)     = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c)
-pprUserTypeCtxt GenPatCtxt        = ptext (sLit "the type pattern of a generic definition")
 pprUserTypeCtxt ThBrackCtxt       = ptext (sLit "a Template Haskell quotation [t|...|]")
 pprUserTypeCtxt LamPatSigCtxt     = ptext (sLit "a pattern type signature")
 pprUserTypeCtxt BindPatSigCtxt    = ptext (sLit "a pattern type signature")
 pprUserTypeCtxt ResSigCtxt        = ptext (sLit "a result type signature")
 pprUserTypeCtxt (ForSigCtxt n)    = ptext (sLit "the foreign declaration for") <+> quotes (ppr n)
 pprUserTypeCtxt DefaultDeclCtxt   = ptext (sLit "a type in a `default' declaration")
+pprUserTypeCtxt InstDeclCtxt      = ptext (sLit "an instance declaration")
 pprUserTypeCtxt SpecInstCtxt      = ptext (sLit "a SPECIALISE instance pragma")
 pprUserTypeCtxt GenSigCtxt        = ptext (sLit "a type expected by the context")
 pprUserTypeCtxt GhciCtxt          = ptext (sLit "a type in a GHCi command")
+pprUserTypeCtxt (ClassSCCtxt c)   = ptext (sLit "the super-classes of class") <+> quotes (ppr c)
+pprUserTypeCtxt SigmaCtxt         = ptext (sLit "the context of a polymorphic type")
+pprUserTypeCtxt (DataTyCtxt tc)   = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc)
 \end{code}
 
 
@@ -447,13 +451,14 @@ pprUserTypeCtxt GhciCtxt          = ptext (sLit "a type in a GHCi command")
 -- 
 -- It doesn't change the uniques at all, just the print names.
 tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-tidyTyVarBndr (tidy_env, subst) tyvar
-  = case tidyOccName tidy_env occ1 of
+tidyTyVarBndr tidy_env@(occ_env, subst) tyvar
+  = case tidyOccName occ_env occ1 of
       (tidy', occ') -> ((tidy', subst'), tyvar')
 	where
           subst' = extendVarEnv subst tyvar tyvar'
-          tyvar' = setTyVarName tyvar name'
+          tyvar' = setTyVarKind (setTyVarName tyvar name') kind'
           name'  = tidyNameOcc name occ'
+          kind'  = tidyKind tidy_env (tyVarKind tyvar)
   where
     name = tyVarName tyvar
     occ  = getOccName name
@@ -531,8 +536,11 @@ tidyTopType :: Type -> Type
 tidyTopType ty = tidyType emptyTidyEnv ty
 
 ---------------
-tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
-tidyKind env k = tidyOpenType env k
+tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
+tidyOpenKind = tidyOpenType
+
+tidyKind :: TidyEnv -> Kind -> Kind
+tidyKind = tidyType
 \end{code}
 
 %************************************************************************
@@ -973,13 +981,14 @@ tcInstHeadTyNotSynonym ty
 
 tcInstHeadTyAppAllTyVars :: Type -> Bool
 -- Used in Haskell-98 mode, for the argument types of an instance head
--- These must be a constructor applied to type variable arguments
+-- These must be a constructor applied to type variable arguments.
+-- But we allow kind instantiations.
 tcInstHeadTyAppAllTyVars ty
   | Just ty' <- tcView ty       -- Look through synonyms
   = tcInstHeadTyAppAllTyVars ty'
   | otherwise
   = case ty of
-	TyConApp _ tys  -> ok tys
+	TyConApp _ tys  -> ok (filter (not . isKind) tys)  -- avoid kinds
 	FunTy arg res   -> ok [arg, res]
 	_               -> False
   where
@@ -1014,7 +1023,7 @@ shallowPredTypePredTree ev_ty
       () | Just clas <- tyConClass_maybe tc
          -> ClassPred clas tys
       () | tc `hasKey` eqTyConKey
-         , let [ty1, ty2] = tys
+         , let [_, ty1, ty2] = tys
          -> EqPred ty1 ty2
       () | Just ip <- tyConIP_maybe tc
          , let [ty] = tys
@@ -1154,9 +1163,7 @@ deNoteType :: Type -> Type
 -- Remove all *outermost* type synonyms and other notes
 deNoteType ty | Just ty' <- tcView ty = deNoteType ty'
 deNoteType ty = ty
-\end{code}
 
-\begin{code}
 tcTyVarsOfType :: Type -> TcTyVarSet
 -- Just the *TcTyVars* free in the type
 -- (Types.tyVarsOfTypes finds all free TyVars)
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index b73f70447d..67bafaca36 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -14,12 +14,12 @@ Type subsumption and unification
 -- for details
 
 module TcUnify (
-        -- Full-blown subsumption
+  -- Full-blown subsumption
   tcWrapResult, tcSubType, tcGen, 
   checkConstraints, newImplication, sigCtxt,
 
-        -- Various unifications
-  unifyType, unifyTypeList, unifyTheta, unifyKind, 
+  -- Various unifications
+  unifyType, unifyTypeList, unifyTheta, unifyKind, unifyKindEq,
 
   --------------------------------
   -- Holes
@@ -31,7 +31,12 @@ module TcUnify (
   matchExpectedFunTys,
   matchExpectedFunKind,
   wrapFunResCoercion,
-  failWithMisMatch
+  failWithMisMatch,
+
+  --------------------------------
+  -- Errors
+  mkKindErrorCtxt
+
   ) where
 
 #include "HsVersions.h"
@@ -46,17 +51,17 @@ import TcRnMonad
 import TcType
 import Type
 import Coercion
+import Name ( isSystemName )
 import Inst
-import Kind     ( isConstraintKind, isConstraintKindCon )
+import Kind
 import TyCon
 import TysWiredIn
 import Var
 import VarSet
 import VarEnv
-import Name
 import ErrUtils
 import BasicTypes
-import Maybes ( allMaybes )  
+import Maybes ( allMaybes )
 import Util
 import Outputable
 import FastString
@@ -198,10 +203,10 @@ matchExpectedPArrTy exp_ty
        ; return (co, elt_ty) }
 
 ----------------------
-matchExpectedTyConApp :: TyCon                -- T :: k1 -> ... -> kn -> *
+matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *
                       -> TcRhoType 	      -- orig_ty
-                      -> TcM (LCoercion,      -- T a b c ~ orig_ty
-                              [TcSigmaType])  -- Element types, a b c
+                      -> TcM (LCoercion,      -- T k1 k2 k3 a b c ~ orig_ty
+                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c
                               
 -- It's used for wired-in tycons, so we call checkWiredInTyCon
 -- Precondition: never called with FunTyCon
@@ -239,11 +244,14 @@ matchExpectedTyConApp tc orig_ty
 
     ----------
     defer n_req ty tys
-      = do { tau_tys <- mapM newFlexiTyVarTy arg_kinds
-           ; co <- unifyType (mkTyConApp tc tau_tys) ty
-           ; return (co, tau_tys ++ tys) }
+      = do { kappa_tys <- mapM (const newMetaKindVar) kvs
+           ; let arg_kinds' = map (substKiWith kvs kappa_tys) arg_kinds
+           ; tau_tys <- mapM newFlexiTyVarTy arg_kinds'
+           ; co <- unifyType (mkTyConApp tc (kappa_tys ++ tau_tys)) ty
+           ; return (co, kappa_tys ++ tau_tys ++ tys) }
       where
-        (arg_kinds, _) = splitKindFunTysN n_req (tyConKind tc)
+        (kvs, body) = splitForAllTys (tyConKind tc)
+        (arg_kinds, _) = splitKindFunTysN (n_req - length kvs) body
 
 ----------------------
 matchExpectedAppTy :: TcRhoType                         -- orig_ty
@@ -574,10 +582,7 @@ uType_np origin orig_ty1 orig_ty2
     go (TyVarTy tyvar1) ty2 = uVar origin NotSwapped tyvar1 ty2
     go ty1 (TyVarTy tyvar2) = uVar origin IsSwapped  tyvar2 ty1
 
-        -- Expand synonyms: 
-	--      see Note [Unification and synonyms]
-	-- Do this after the variable case so that we tend to unify
-	-- variables with un-expanded type synonym
+        -- See Note [Expanding synonyms during unification]
 	--
 	-- Also NB that we recurse to 'go' so that we don't push a
 	-- new item on the origin stack. As a result if we have
@@ -715,48 +720,19 @@ So either
 Currently we adopt (b) since it seems more robust -- no need to maintain
 a global invariant.
 
-Note [Unification and synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If you are tempted to make a short cut on synonyms, as in this
-pseudocode...
-
-   uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
-     = if (con1 == con2) then
-   -- Good news!  Same synonym constructors, so we can shortcut
-   -- by unifying their arguments and ignoring their expansions.
-   unifyTypepeLists args1 args2
-    else
-   -- Never mind.  Just expand them and try again
-   uTys ty1 ty2
-
-then THINK AGAIN.  Here is the whole story, as detected and reported
-by Chris Okasaki:
-
-Here's a test program that should detect the problem:
-
-        type Bogus a = Int
-        x = (1 :: Bogus Char) :: Bogus Bool
-
-The problem with [the attempted shortcut code] is that
-
-        con1 == con2
-
-is not a sufficient condition to be able to use the shortcut!
-You also need to know that the type synonym actually USES all
-its arguments.  For example, consider the following type synonym
-which does not use all its arguments.
-
-        type Bogus a = Int
-
-If you ever tried unifying, say, (Bogus Char) with )Bogus Bool), the
-unifier would blithely try to unify Char with Bool and would fail,
-even though the expanded forms (both Int) should match. Similarly,
-unifying (Bogus Char) with (Bogus t) would unnecessarily bind t to
-Char.
+Note [Expanding synonyms during unification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We expand synonyms during unification, but:
+ * We expand *after* the variable case so that we tend to unify
+   variables with un-expanded type synonym. This just makes it
+   more likely that the inferred types will mention type synonyms
+   understandable to the user
 
-... You could explicitly test for the problem synonyms and mark them
-somehow as needing expansion, perhaps also issuing a warning to the
-user.
+ * We expand *before* the TyConApp case.  For example, if we have
+      type Phantom a = Int
+   and are unifying
+      Phantom Int ~ Phantom Char
+   it is *wrong* to unify Int and Char.
 
 Note [Deferred Unification]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -857,29 +833,31 @@ uUnfilledVars :: [EqOrigin]
 --           Neither is filled in yet
 
 uUnfilledVars origin swapped tv1 details1 tv2 details2
-  = case (details1, details2) of
-      (MetaTv i1 ref1, MetaTv i2 ref2)
-          | k1_sub_k2 -> if k2_sub_k1 && nicer_to_update_tv1 i1 i2
-                         then updateMeta tv1 ref1 ty2
-                         else updateMeta tv2 ref2 ty1
-          | k2_sub_k1 -> updateMeta tv1 ref1 ty2
-
-      (_, MetaTv _ ref2) | k1_sub_k2 -> updateMeta tv2 ref2 ty1
-      (MetaTv _ ref1, _) | k2_sub_k1 -> updateMeta tv1 ref1 ty2
-
-      (_, _) -> unSwap swapped (uType_defer origin) ty1 ty2
-      	        -- Defer for skolems of all sorts
+  = do { traceTc "uUnfilledVars" (    text "trying to unify" <+> ppr k1
+                                  <+> text "with"            <+> ppr k2)
+       ; let ctxt = mkKindErrorCtxt ty1 ty2 k1 k2
+       ; sub_kind <- addErrCtxtM ctxt $ unifyKind k1 k2
+
+       ; case (sub_kind, details1, details2) of
+           -- k1 <= k2, so update tv2
+           (LT, _, MetaTv _ ref2) -> updateMeta tv2 ref2 ty1
+           -- k2 <= k1, so update tv1
+           (GT, MetaTv _ ref1, _) -> updateMeta tv1 ref1 ty2
+           (EQ, MetaTv i1 ref1, MetaTv i2 ref2)
+                | nicer_to_update_tv1 i1 i2 -> updateMeta tv1 ref1 ty2
+                | otherwise                 -> updateMeta tv2 ref2 ty1
+
+           (_, _, _) -> unSwap swapped (uType_defer origin) ty1 ty2 } 
+                        -- Defer for skolems of all sorts
   where
-    k1 	      = tyVarKind tv1
-    k2 	      = tyVarKind tv2
-    k1_sub_k2 = k1 `isSubKind` k2
-    k2_sub_k1 = k2 `isSubKind` k1
-    ty1       = mkTyVarTy tv1
-    ty2       = mkTyVarTy tv2
+    k1       = tyVarKind tv1
+    k2       = tyVarKind tv2
+    ty1      = mkTyVarTy tv1
+    ty2      = mkTyVarTy tv2
 
     nicer_to_update_tv1 _     SigTv = True
     nicer_to_update_tv1 SigTv _     = False
-    nicer_to_update_tv1 _         _         = isSystemName (Var.varName tv1)
+    nicer_to_update_tv1 _         _ = isSystemName (Var.varName tv1)
         -- Try not to update SigTvs; and try to update sys-y type
         -- variables in preference to ones gotten (say) by
         -- instantiating a polymorphic function with a user-written
@@ -890,7 +868,7 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType)
 --    (checkTauTvUpdate tv ty)
 -- We are about to update the TauTv tv with ty.
 -- Check (a) that tv doesn't occur in ty (occurs check)
---	 (b) that kind(ty) is a sub-kind of kind(tv)
+--       (b) that kind(ty) is a sub-kind of kind(tv)
 --       (c) that ty does not contain any type families, see Note [Type family sharing]
 -- 
 -- We have two possible outcomes:
@@ -910,26 +888,36 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType)
 
 checkTauTvUpdate tv ty
   = do { ty' <- zonkTcType ty
-       ; if typeKind ty' `isSubKind` tyVarKind tv then
-           case ok ty' of 
-             Nothing -> return Nothing 
-             Just ty'' -> return (Just ty'')
-         else return Nothing }
-
-  where ok :: TcType -> Maybe TcType 
-        ok (TyVarTy tv') | not (tv == tv') = Just (TyVarTy tv') 
-        ok this_ty@(TyConApp tc tys) 
-          | not (isSynFamilyTyCon tc), Just tys' <- allMaybes (map ok tys) 
-          = Just (TyConApp tc tys') 
-          | isSynTyCon tc, Just ty_expanded <- tcView this_ty
-          = ok ty_expanded -- See Note [Type synonyms and the occur check] 
-        ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res
-                           = Just (FunTy arg' res') 
-        ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg 
-                           = Just (AppTy fun' arg') 
-        ok (ForAllTy tv1 ty1) | Just ty1' <- ok ty1 = Just (ForAllTy tv1 ty1') 
-        -- Fall-through 
-        ok _ty = Nothing 
+       ; let k2 = typeKind ty'
+       ; k1 <- zonkTcKind (tyVarKind tv)
+       ; let ctxt = mkKindErrorCtxt (mkTyVarTy tv) ty' k1 k2
+       ; sub_k <- addErrCtxtM ctxt $
+                  unifyKind (tyVarKind tv) (typeKind ty')
+
+       ; case sub_k of
+           LT -> return Nothing
+           _  -> return (ok ty') }
+  where 
+    ok :: TcType -> Maybe TcType 
+    -- Checks that tv does not occur in the arg type
+    -- expanding type synonyms where necessary to make this so
+    -- eg type Phantom a = Bool
+    --     ok (tv -> Int)         = Nothing
+    --     ok (x -> Int)          = Just (x -> Int)
+    --     ok (Phantom tv -> Int) = Just (Bool -> Int)
+    ok (TyVarTy tv') | not (tv == tv') = Just (TyVarTy tv') 
+    ok this_ty@(TyConApp tc tys) 
+      | not (isSynFamilyTyCon tc), Just tys' <- allMaybes (map ok tys) 
+      = Just (TyConApp tc tys') 
+      | isSynTyCon tc, Just ty_expanded <- tcView this_ty
+      = ok ty_expanded -- See Note [Type synonyms and the occur check] 
+    ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res
+                       = Just (FunTy arg' res') 
+    ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg 
+                       = Just (AppTy fun' arg') 
+    ok (ForAllTy tv1 ty1) | Just ty1' <- ok ty1 = Just (ForAllTy tv1 ty1') 
+    -- Fall-through 
+    ok _ty = Nothing 
 \end{code}
 
 Note [Avoid deferring]
@@ -1130,115 +1118,144 @@ matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind))
 -- Like unifyFunTy, but does not fail; instead just returns Nothing
 
 matchExpectedFunKind (TyVarTy kvar) = do
-    maybe_kind <- readKindVar kvar
+    maybe_kind <- readMetaTyVar kvar
     case maybe_kind of
       Indirect fun_kind -> matchExpectedFunKind fun_kind
       Flexi ->
-          do { arg_kind <- newKindVar
-             ; res_kind <- newKindVar
-             ; writeKindVar kvar (mkArrowKind arg_kind res_kind)
+          do { arg_kind <- newMetaKindVar
+             ; res_kind <- newMetaKindVar
+             ; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind)
              ; return (Just (arg_kind,res_kind)) }
 
 matchExpectedFunKind (FunTy arg_kind res_kind) = return (Just (arg_kind,res_kind))
 matchExpectedFunKind _                         = return Nothing
 
------------------
-unifyKind :: TcKind                 -- Expected
-          -> TcKind                 -- Actual
-          -> TcM ()
-
-unifyKind (TyConApp kc1 []) (TyConApp kc2 [])
-  | isSubKindCon kc2 kc1
-  , not (isConstraintKindCon kc2) || isConstraintKindCon kc1 = return ()
-   -- For the purposes of the front end ONLY, only allow
-   -- the Constraint kind to unify with itself.
-   --
-   -- This prevents the user from writing constraints types
-   -- on the left or right of an arrow.
-
-unifyKind (FunTy a1 r1) (FunTy a2 r2)
-  = do { unifyKind a2 a1; unifyKind r1 r2 }
-                -- Notice the flip in the argument,
-                -- so that the sub-kinding works right
+-----------------  
+unifyKind :: TcKind           -- k1 (actual)
+          -> TcKind           -- k2 (expected)
+          -> TcM Ordering     -- Returns the relation between the kinds
+                              -- LT <=> k1 is a sub-kind of k2
+
 unifyKind (TyVarTy kv1) k2 = uKVar False kv1 k2
-unifyKind k1 (TyVarTy kv2) = uKVar True kv2 k1
-unifyKind k1 k2 = unifyKindMisMatch k1 k2
+unifyKind k1 (TyVarTy kv2) = uKVar True  kv2 k1
+
+unifyKind k1 k2       -- See Note [Expanding synonyms during unification]
+  | Just k1' <- tcView k1 = unifyKind k1' k2
+  | Just k2' <- tcView k2 = unifyKind k1  k2'
+
+unifyKind k1@(TyConApp kc1 []) k2@(TyConApp kc2 [])
+  | kc1 == kc2               = return EQ
+  | kc1 `tcIsSubKindCon` kc2 = return LT
+  | kc2 `tcIsSubKindCon` kc1 = return GT
+  | otherwise                = unifyKindMisMatch k1 k2
+
+unifyKind k1 k2 = do { unifyKindEq k1 k2; return EQ }
+  -- In all other cases, let unifyKindEq do the work
+
+uKVar :: Bool -> MetaKindVar -> TcKind -> TcM Ordering
+uKVar isFlipped kv1 k2
+  | isMetaTyVar kv1
+  = do  { mb_k1 <- readMetaTyVar kv1
+        ; case mb_k1 of
+            Flexi -> uUnboundKVar kv1 k2 >> return EQ
+            Indirect k1 -> unifyKind k1 k2 }
+  | TyVarTy kv2 <- k2, isMetaTyVar kv2
+  = uKVar (not isFlipped) kv2 (TyVarTy kv1)
+  | TyVarTy kv2 <- k2, kv1 == kv2 = return EQ
+  | otherwise = if isFlipped 
+                then unifyKindMisMatch k2 (TyVarTy kv1)
+                else unifyKindMisMatch (TyVarTy kv1) k2
+
+---------------------------
+unifyKindEq :: TcKind -> TcKind -> TcM ()
+unifyKindEq (TyVarTy kv1) k2 = uKVarEq False kv1 k2
+unifyKindEq k1 (TyVarTy kv2) = uKVarEq True  kv2 k1
+
+unifyKindEq (FunTy a1 r1) (FunTy a2 r2)
+  = do { unifyKindEq a1 a2; unifyKindEq r1 r2 }
+  
+unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s)
+  | kc1 == kc2
+  = ASSERT (length k1s == length k2s)
+       -- Should succeed since the kind constructors are the same, 
+       -- and the kinds are sort-checked, thus fully applied
+    zipWithM_ unifyKindEq k1s k2s
+
+unifyKindEq k1 k2 = unifyKindMisMatch k1 k2
 
 ----------------
-uKVar :: Bool -> KindVar -> TcKind -> TcM ()
-uKVar swapped kv1 k2
-  = do  { mb_k1 <- readKindVar kv1
+-- For better error messages, we record whether we've flipped the kinds
+-- during the process.
+uKVarEq :: Bool -> MetaKindVar -> TcKind -> TcM ()
+uKVarEq isFlipped kv1 k2
+  | isMetaTyVar kv1
+  = do  { mb_k1 <- readMetaTyVar kv1
         ; case mb_k1 of
-            Flexi -> uUnboundKVar swapped kv1 k2
-            Indirect k1 | swapped   -> unifyKind k2 k1
-                        | otherwise -> unifyKind k1 k2 }
+            Flexi -> uUnboundKVar kv1 k2
+            Indirect k1 -> unifyKindEq k1 k2 }
+  | TyVarTy kv2 <- k2, isMetaTyVar kv2
+  = uKVarEq (not isFlipped) kv2 (TyVarTy kv1)
+  | TyVarTy kv2 <- k2, kv1 == kv2 = return ()
+  | otherwise = if isFlipped 
+                then unifyKindMisMatch k2 (TyVarTy kv1)
+                else unifyKindMisMatch (TyVarTy kv1) k2
 
 ----------------
-uUnboundKVar :: Bool -> KindVar -> TcKind -> TcM ()
-uUnboundKVar swapped kv1 k2@(TyVarTy kv2)
+uUnboundKVar :: MetaKindVar -> TcKind -> TcM ()
+uUnboundKVar kv1 k2@(TyVarTy kv2)
   | kv1 == kv2 = return ()
-  | otherwise   -- Distinct kind variables
-  = do  { mb_k2 <- readKindVar kv2
+  | isMetaTyVar kv2   -- Distinct kind variables
+  = do  { mb_k2 <- readMetaTyVar kv2
         ; case mb_k2 of
-            Indirect k2 -> uUnboundKVar swapped kv1 k2
-            Flexi -> writeKindVar kv1 k2 }
+            Indirect k2 -> uUnboundKVar kv1 k2
+            Flexi -> writeMetaTyVar kv1 k2 }
+  | otherwise = writeMetaTyVar kv1 k2
 
-uUnboundKVar swapped kv1 non_var_k2
+uUnboundKVar kv1 non_var_k2
   = do  { k2' <- zonkTcKind non_var_k2
         ; kindOccurCheck kv1 k2'
-        ; k2'' <- kindSimpleKind swapped k2'
-                -- KindVars must be bound only to simple kinds
-                -- Polarities: (kindSimpleKind True ?) succeeds
-                -- returning *, corresponding to unifying
-                --      expected: ?
-                --      actual:   kind-ver
-        ; writeKindVar kv1 k2'' }
+        ; let k2'' = kindSimpleKind k2'
+                -- MetaKindVars must be bound only to simple kinds
+        ; writeMetaTyVar kv1 k2'' }
 
 ----------------
 kindOccurCheck :: TyVar -> Type -> TcM ()
 kindOccurCheck kv1 k2   -- k2 is zonked
-  = checkTc (not_in k2) (kindOccurCheckErr kv1 k2)
-  where
-    not_in (TyVarTy kv2) = kv1 /= kv2
-    not_in (FunTy a2 r2) = not_in a2 && not_in r2
-    not_in _             = True
-
-kindSimpleKind :: Bool -> Kind -> TcM SimpleKind
--- (kindSimpleKind True k) returns a simple kind sk such that sk <: k
--- If the flag is False, it requires k <: sk
--- E.g.         kindSimpleKind False ?? = *
--- What about (kv -> *) ~ ?? -> *
-kindSimpleKind orig_swapped orig_kind
-  = go orig_swapped orig_kind
-  where
-    go sw (FunTy k1 k2) = do { k1' <- go (not sw) k1
-                             ; k2' <- go sw k2
-                             ; return (mkArrowKind k1' k2') }
-    go True k
-     | isOpenTypeKind k = return liftedTypeKind
-     | isArgTypeKind k  = return liftedTypeKind
-    go _ k
-     | isLiftedTypeKind k   = return liftedTypeKind
-     | isUnliftedTypeKind k = return unliftedTypeKind
-     | isConstraintKind k   = return constraintKind
-    go _ k@(TyVarTy _) = return k -- KindVars are always simple
-    go _ _ = failWithTc (ptext (sLit "Unexpected kind unification failure:")
-                                  <+> ppr orig_swapped <+> ppr orig_kind)
-        -- I think this can't actually happen
-
--- T v = MkT v           v must be a type
--- T v w = MkT (v -> w)  v must not be an umboxed tuple
-
-unifyKindMisMatch :: TcKind -- Expected
-                  -> TcKind -- Actual
-                  -> TcM ()
-unifyKindMisMatch ty1 ty2 = do
-    ty1' <- zonkTcKind ty1
-    ty2' <- zonkTcKind ty2
-    failWithTc $ hang (ptext (sLit "Couldn't match kind"))
-                    2 (sep [quotes (ppr ty1'), 
-                            ptext (sLit "against"), 
-                            quotes (ppr ty2')])
+  = if elemVarSet kv1 (tyVarsOfType k2)
+    then failWithTc (kindOccurCheckErr kv1 k2)
+    else return ()
+
+kindSimpleKind :: Kind -> SimpleKind
+-- (kindSimpleKind k) returns a simple kind k' such that k' <= k
+kindSimpleKind k
+  | isOpenTypeKind k = liftedTypeKind
+  | isArgTypeKind  k = liftedTypeKind
+  | otherwise        = k
+
+mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc)
+mkKindErrorCtxt ty1 ty2 k1 k2 env0
+  = let (env1, ty1') = tidyOpenType env0 ty1
+        (env2, ty2') = tidyOpenType env1 ty2
+        (env3, k1' ) = tidyOpenKind env2 k1
+        (env4, k2' ) = tidyOpenKind env3 k2
+    in do ty1 <- zonkTcType ty1'
+          ty2 <- zonkTcType ty2'
+          k1  <- zonkTcKind k1'
+          k2  <- zonkTcKind k2'
+          return (env4, 
+                  vcat [ ptext (sLit "Kind incompatibility when matching types:")
+                       , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
+                                      , ppr ty2 <+> dcolon <+> ppr k2 ]) ])
+
+unifyKindMisMatch :: TcKind -> TcKind -> TcM a
+unifyKindMisMatch ki1 ki2 = do
+    ki1' <- zonkTcKind ki1
+    ki2' <- zonkTcKind ki2
+    let msg = hang (ptext (sLit "Couldn't match kind"))
+              2 (sep [quotes (ppr ki1'),
+                      ptext (sLit "against"),
+                      quotes (ppr ki2')])
+    failWithTc msg
 
 ----------------
 kindOccurCheckErr :: Var -> Type -> SDoc
diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot
index 431bfaabdc..ac4d5ddc78 100644
--- a/compiler/typecheck/TcUnify.lhs-boot
+++ b/compiler/typecheck/TcUnify.lhs-boot
@@ -7,12 +7,16 @@
 -- for details
 
 module TcUnify where
-import TcType	( TcTauType )
-import TcRnTypes( TcM )
-import Coercion (LCoercion)
+import TcType     ( TcTauType, TcKind, Type, Kind )
+import VarEnv     ( TidyEnv )
+import TcRnTypes  ( TcM )
+import Coercion   ( LCoercion )
+import Outputable ( SDoc )
 
 -- This boot file exists only to tie the knot between
---		TcUnify and Inst
+--              TcUnify and Inst
 
 unifyType :: TcTauType -> TcTauType -> TcM LCoercion
+unifyKindEq :: TcKind -> TcKind -> TcM ()
+mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc)
 \end{code}
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 1878237499..cda98de45e 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -39,6 +39,7 @@ import BasicTypes
 import Unique
 import Util
 import Outputable
+import SrcLoc
 import FastString
 
 import Data.Typeable (Typeable)
@@ -56,14 +57,16 @@ A @Class@ corresponds to a Greek kappa in the static semantics:
 \begin{code}
 data Class
   = Class {
-	classTyCon :: TyCon,		-- The data type constructor for
-					-- dictionaries of this class
+	classTyCon :: TyCon,	-- The data type constructor for
+				-- dictionaries of this class
+                                -- See Note [ATyCon for classes] in TypeRep
 
 	className :: Name,              -- Just the cached name of the TyCon
 	classKey  :: Unique,		-- Cached unique of TyCon
 	
-	classTyVars  :: [TyVar],	-- The class type variables;
+	classTyVars  :: [TyVar],	-- The class kind and type variables;
 		     			-- identical to those of the TyCon
+
 	classFunDeps :: [FunDep TyVar],	-- The functional dependencies
 
 	-- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
@@ -97,12 +100,19 @@ type ClassATItem = (TyCon, [ATDefault])
   -- Default associated types from these templates. If the template list is empty,
   -- we assume that there is no default -- not that the default is to generate no
   -- instances (this only makes a difference for warnings).
-
-data ATDefault = ATD [TyVar] [Type] Type
-  -- Each associated type default template is a triple of:
-  --   1. TyVars of the RHS and family arguments (including the class TVs)
-  --   3. The instantiated family arguments
-  --   2. The RHS of the synonym
+  -- We can have more than one default per type; see
+  -- Note [Associated type defaults] in TcTyClsDecls
+
+-- Each associated type default template is a triple of:
+data ATDefault = ATD { -- TyVars of the RHS and family arguments 
+                       -- (including the class TVs)
+                       atDefaultTys     :: [TyVar],
+                       -- The instantiated family arguments
+                       atDefaultPats    :: [Type],
+                       -- The RHS of the synonym
+                       atDefaultRhs     :: Type,
+                       -- The source location of the synonym
+                       atDefaultSrcSpan :: SrcSpan }
 
 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
 --   the `DefMeth` constructor of the `DefMeth`.
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 4437a3e783..228768baf7 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -19,19 +19,7 @@ module Coercion (
         Coercion(..), Var, CoVar,
         LCoercion,
 
-        -- ** Deconstructing Kinds 
-        kindFunResult, kindAppResult, synTyConResKind,
-        splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
-
-        -- ** Predicates on Kinds
-        isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
-        isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, 
-        isSuperKind, 
-	mkArrowKind, mkArrowKinds,
-
-        isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
-        isSubKindCon,
-
+        -- ** Functions over coercions
         coVarKind, coVarKind_maybe,
         coercionType, coercionKind, coercionKinds, isReflCo, liftedCoercionKind,
         mkCoercionType,
@@ -90,7 +78,6 @@ import Unify	( MatchEnv(..), matchList )
 import TypeRep
 import qualified Type
 import Type hiding( substTy, substTyVarBndr, extendTvSubst )
-import Kind
 import TyCon
 import Var
 import VarEnv
@@ -162,21 +149,22 @@ data Coercion
   deriving (Data.Data, Data.Typeable)
 \end{code}
 
+Note [LCoercions]
+~~~~~~~~~~~~~~~~~
+| LCoercions are a hack used by the typechecker. Normally,
+Coercions have free variables of type (a ~# b): we call these
+CoVars. However, the type checker passes around equality evidence
+(boxed up) at type (a ~ b).
+
+An LCoercion is simply a Coercion whose free variables have the
+boxed type (a ~ b). After we are done with typechecking the
+desugarer finds the free variables, unboxes them, and creates a
+resulting real Coercion with kosher free variables.
+
+We can use most of the Coercion "smart constructors" to build LCoercions. However,
+mkCoVarCo will not work! The equivalent is mkEqVarLCo.
+
 \begin{code}
--- Note [LCoercions]
--- ~~~~~~~~~~~~~~~~~
--- | LCoercions are a hack used by the typechecker. Normally,
--- Coercions have free variables of type (a ~# b): we call these
--- CoVars. However, the type checker passes around equality evidence
--- (boxed up) at type (a ~ b).
---
--- An LCoercion is simply a Coercion whose free variables have the
--- boxed type (a ~ b). After we are done with typechecking the
--- desugarer finds the free variables, unboxes them, and creates a
--- resulting real Coercion with kosher free variables.
---
--- We can use most of the Coercion "smart constructors" to build LCoercions. However,
--- mkCoVarCo will not work! The equivalent is mkEqVarLCo.
 type LCoercion = Coercion
 \end{code}
 
@@ -282,6 +270,30 @@ predicates too:
     Nth 1 ((~) [c] g) = g
 See Simplify.simplCoercionF, which generates such selections.
 
+Note [Kind coercions]
+~~~~~~~~~~~~~~~~~~~~~
+Suppose T :: * -> *, and g :: A ~ B
+Then the coercion
+   TyConAppCo T [g]      T g : T A ~ T B
+
+Now suppose S :: forall k. k -> *, and g :: A ~ B
+Then the coercion
+   TyConAppCo S [Refl *, g]   T <*> g : T * A ~ T * B
+
+Notice that the arguments to TyConAppCo are coercions, but the first
+represents a *kind* coercion. Now, we don't allow any non-trivial kind
+coercions, so it's an invariant that any such kind coercions are Refl.
+Lint checks this. 
+
+However it's inconvenient to insist that these kind coercions are always
+*structurally* (Refl k), because the key function exprIsConApp_maybe
+pushes coercions into constructor arguments, so 
+       C k ty e |> g
+may turn into
+       C (Nth 0 g) ....
+Now (Nth 0 g) will optimise to Refl, but perhaps not instantly.
+
+
 %************************************************************************
 %*									*
 \subsection{Coercion variables}
@@ -453,6 +465,7 @@ pprCoAxiom ax
 -- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c]
 decomposeCo :: Arity -> Coercion -> [Coercion]
 decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ]
+                       -- Remember, Nth is zero-indexed
 
 -- | Attempts to obtain the type variable underlying a 'Coercion'
 getCoVar_maybe :: Coercion -> Maybe CoVar
@@ -495,7 +508,7 @@ coVarKind cv = case coVarKind_maybe cv of
 
 coVarKind_maybe :: CoVar -> Maybe (Type,Type) 
 coVarKind_maybe cv = case splitTyConApp_maybe (varType cv) of
-  Just (tc, [ty1, ty2]) | tc `hasKey` eqPrimTyConKey -> Just (ty1, ty2)
+  Just (tc, [_, ty1, ty2]) | tc `hasKey` eqPrimTyConKey -> Just (ty1, ty2)
   _ -> Nothing
 
 -- | Makes a coercion type from two types: the types whose equality 
@@ -932,6 +945,9 @@ ty_co_subst subst ty
 			     -- won't be in the substitution
     go (AppTy ty1 ty2)   = mkAppCo (go ty1) (go ty2)
     go (TyConApp tc tys) = mkTyConAppCo tc (map go tys)
+                           -- IA0_NOTE: Do we need to do anything
+                           -- about kind instantiations? I don't think
+                           -- so.  see Note [Kind coercions]
     go (FunTy ty1 ty2)   = mkFunCo (go ty1) (go ty2)
     go (ForAllTy v ty)   = mkForAllCo v' $! (ty_co_subst subst' ty)
                          where
@@ -1107,6 +1123,7 @@ coercionKinds :: [Coercion] -> Pair [Type]
 coercionKinds tys = sequenceA $ map coercionKind tys
 
 getNth :: Int -> Type -> Type
+-- Executing Nth
 getNth n ty | Just tys <- tyConAppArgs_maybe ty
             = ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n
 getNth n ty = pprPanic "getNth" (ppr n <+> ppr ty)
@@ -1119,3 +1136,9 @@ applyCo ty co | Just ty' <- coreView ty = applyCo ty' co
 applyCo (FunTy _ ty) _ = ty
 applyCo _            _ = panic "applyCo"
 \end{code}
+
+Note [Kind coercions]
+~~~~~~~~~~~~~~~~~~~~~
+Kind coercions are only of the form: Refl kind. They are only used to
+instantiate kind polymorphic type constructors in TyConAppCo. Remember
+that kind instantiation only happens with TyConApp, not AppTy.
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 6e9abe0d3e..236185168b 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -309,58 +309,6 @@ lookupFamInstEnv
    where
      match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys
 
-lookupFamInstEnvConflicts'
-    :: FamInstEnv
-    -> FamInst		-- Putative new instance
-    -> [TyVar]		-- Unique tyvars, matching arity of FamInst
-    -> [FamInstMatch] 	-- Conflicting matches
--- E.g. when we are about to add
---    f : type instance F [a] = a->a
--- we do (lookupFamInstConflicts f [b])
--- to find conflicting matches
--- The skolem tyvars are needed because we don't have a 
--- unique supply to hand
---
--- Precondition: the tycon is saturated (or over-saturated)
-
-lookupFamInstEnvConflicts' env fam_inst skol_tvs
-  = lookup_fam_inst_env' my_unify False env fam tys'
-  where
-    inst_tycon = famInstTyCon fam_inst
-    (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts"
-    	       	            (tyConFamInst_maybe inst_tycon)
-    skol_tys = mkTyVarTys skol_tvs
-    tys'     = substTys (zipTopTvSubst (tyConTyVars inst_tycon) skol_tys) tys
-        -- In example above,   fam tys' = F [b]   
-
-    my_unify old_fam_inst tpl_tvs tpl_tys match_tys
-       = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
-		  (ppr fam <+> ppr tys) $$
-		  (ppr tpl_tvs <+> ppr tpl_tys) )
-		-- Unification will break badly if the variables overlap
-		-- They shouldn't because we allocate separate uniques for them
-         case tcUnifyTys instanceBindFun tpl_tys match_tys of
-	      Just subst | conflicting old_fam_inst subst -> Just subst
-	      _other	   	              	          -> Nothing
-
-      -- - In the case of data family instances, any overlap is fundamentally a
-      --   conflict (as these instances imply injective type mappings).
-      -- - In the case of type family instances, overlap is admitted as long as
-      --   the right-hand sides of the overlapping rules coincide under the
-      --   overlap substitution.  We require that they are syntactically equal;
-      --   anything else would be difficult to test for at this stage.
-    conflicting old_fam_inst subst 
-      | isAlgTyCon fam = True
-      | otherwise      = not (old_rhs `eqType` new_rhs)
-      where
-        old_tycon = famInstTyCon old_fam_inst
-        old_tvs   = tyConTyVars old_tycon
-        old_rhs   = mkTyConApp old_tycon  (substTyVars subst old_tvs)
-        new_rhs   = mkTyConApp inst_tycon (substTyVars subst skol_tvs)
-
-
-
-
 lookupFamInstEnvConflicts
     :: FamInstEnvs
     -> FamInst		-- Putative new instance
@@ -376,18 +324,18 @@ lookupFamInstEnvConflicts
 -- Precondition: the tycon is saturated (or over-saturated)
 
 lookupFamInstEnvConflicts envs fam_inst skol_tvs
-  = lookup_fam_inst_env my_unify False envs fam tys'
+  = lookup_fam_inst_env my_unify False envs fam tys1
   where
     inst_tycon = famInstTyCon fam_inst
     (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts"
     	       	            (tyConFamInst_maybe inst_tycon)
     skol_tys = mkTyVarTys skol_tvs
-    tys'     = substTys (zipTopTvSubst (tyConTyVars inst_tycon) skol_tys) tys
+    tys1     = substTys (zipTopTvSubst (tyConTyVars inst_tycon) skol_tys) tys
         -- In example above,   fam tys' = F [b]   
 
     my_unify old_fam_inst tpl_tvs tpl_tys match_tys
-       = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
-		  (ppr fam <+> ppr tys) $$
+       = ASSERT2( tyVarsOfTypes tys1 `disjointVarSet` tpl_tvs,
+		  (ppr fam <+> ppr tys1) $$
 		  (ppr tpl_tvs <+> ppr tpl_tys) )
 		-- Unification will break badly if the variables overlap
 		-- They shouldn't because we allocate separate uniques for them
@@ -395,12 +343,7 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs
 	      Just subst | conflicting old_fam_inst subst -> Just subst
 	      _other	   	              	          -> Nothing
 
-      -- - In the case of data family instances, any overlap is fundamentally a
-      --   conflict (as these instances imply injective type mappings).
-      -- - In the case of type family instances, overlap is admitted as long as
-      --   the right-hand sides of the overlapping rules coincide under the
-      --   overlap substitution.  We require that they are syntactically equal;
-      --   anything else would be difficult to test for at this stage.
+      -- Note [Family instance overlap conflicts]
     conflicting old_fam_inst subst 
       | isAlgTyCon fam = True
       | otherwise      = not (old_rhs `eqType` new_rhs)
@@ -409,8 +352,29 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs
         old_tvs   = tyConTyVars old_tycon
         old_rhs   = mkTyConApp old_tycon  (substTyVars subst old_tvs)
         new_rhs   = mkTyConApp inst_tycon (substTyVars subst skol_tvs)
+
+-- This variant is called when we want to check if the conflict is only in the
+-- home environment (see FamInst.addLocalFamInst)
+lookupFamInstEnvConflicts' :: FamInstEnv -> FamInst -> [TyVar] -> [FamInstMatch]
+lookupFamInstEnvConflicts' env fam_inst skol_tvs
+  = lookupFamInstEnvConflicts (emptyFamInstEnv, env) fam_inst skol_tvs
 \end{code}
 
+Note [Family instance overlap conflicts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+- In the case of data family instances, any overlap is fundamentally a
+  conflict (as these instances imply injective type mappings).
+
+- In the case of type family instances, overlap is admitted as long as
+  the right-hand sides of the overlapping rules coincide under the
+  overlap substitution.  eg
+       type instance F a Int = a
+       type instance F Int b = b
+  These two overlap on (F Int Int) but then both RHSs are Int, 
+  so all is well. We require that they are syntactically equal;
+  anything else would be difficult to test for at this stage.
+
+
 While @lookupFamInstEnv@ uses a one-way match, the next function
 @lookupFamInstEnvConflicts@ uses two-way matching (ie, unification).  This is
 needed to check for overlapping instances.
diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index e5ef583c99..13585783e0 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -15,13 +15,14 @@ module Kind (
         Kind, typeKind,
 
 	-- Kinds
-	liftedTypeKind, unliftedTypeKind, openTypeKind,
+	anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind, constraintKind,
         mkArrowKind, mkArrowKinds,
 
         -- Kind constructors...
-        liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
-        argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon,
+        anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon,
+        unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon,
+        constraintKindTyCon,
 
         -- Super Kinds
 	tySuperKind, tySuperKindTyCon, 
@@ -34,24 +35,38 @@ module Kind (
 
         -- ** Predicates on Kinds
         isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
-        isUbxTupleKind, isArgTypeKind, isConstraintKind, isKind, isTySuperKind,
-        isSuperKind, 
+        isUbxTupleKind, isArgTypeKind, isConstraintKind, isKind,
+        isSuperKind, noHashInKind,
         isLiftedTypeKindCon, isConstraintKindCon,
+        isAnyKind, isAnyKindCon,
 
-        isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind,
-        isSubKindCon,
+        isSubArgTypeKind, tcIsSubArgTypeKind, 
+        isSubOpenTypeKind, tcIsSubOpenTypeKind,
+        isSubKind, defaultKind,
+        isSubKindCon, tcIsSubKindCon, isSubOpenTypeKindCon,
+
+        -- ** Functions on variables
+        isKiVar, splitKiTyVars, partitionKiTyVars,
+        kiVarsOfKind, kiVarsOfKinds,
+
+        -- ** Promotion related functions
+        promoteType, isPromotableType, isPromotableKind,
 
        ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} Type (typeKind)
+import {-# SOURCE #-} Type      ( typeKind, substKiWith, eqKind )
 
 import TypeRep
 import TysPrim
 import TyCon
+import Var
+import VarSet
 import PrelNames
 import Outputable
+
+import Data.List ( partition )
 \end{code}
 
 %************************************************************************
@@ -61,15 +76,23 @@ import Outputable
 %************************************************************************
 
 \begin{code}
-isTySuperKind :: SuperKind -> Bool
-isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
-isTySuperKind _                = False
-
 -------------------
 -- Lastly we need a few functions on Kinds
 
 isLiftedTypeKindCon :: TyCon -> Bool
 isLiftedTypeKindCon tc    = tc `hasKey` liftedTypeKindTyConKey
+
+-- This checks that its argument does not contain # or (#).
+-- It is used in tcTyVarBndrs.
+noHashInKind :: Kind -> Bool
+noHashInKind (TyVarTy {}) = True
+noHashInKind (FunTy k1 k2) = noHashInKind k1 && noHashInKind k2
+noHashInKind (ForAllTy _ ki) = noHashInKind ki
+noHashInKind (TyConApp kc kis)
+  =  not (kc `hasKey` unliftedTypeKindTyConKey)
+  && not (kc `hasKey` ubxTupleKindTyConKey)
+  && all noHashInKind kis
+noHashInKind _ = panic "noHashInKind"
 \end{code}
 
 %************************************************************************
@@ -79,14 +102,15 @@ isLiftedTypeKindCon tc    = tc `hasKey` liftedTypeKindTyConKey
 %************************************************************************
 
 \begin{code}
--- | Essentially 'funResultTy' on kinds
-kindFunResult :: Kind -> Kind
-kindFunResult (FunTy _ res) = res
-kindFunResult k = pprPanic "kindFunResult" (ppr k)
+-- | Essentially 'funResultTy' on kinds handling pi-types too
+kindFunResult :: Kind -> KindOrType -> Kind
+kindFunResult (FunTy _ res) _ = res
+kindFunResult (ForAllTy kv res) arg = substKiWith [kv] [arg] res
+kindFunResult k _ = pprPanic "kindFunResult" (ppr k)
 
-kindAppResult :: Kind -> [arg] -> Kind
+kindAppResult :: Kind -> [Type] -> Kind
 kindAppResult k []     = k
-kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
+kindAppResult k (a:as) = kindAppResult (kindFunResult k a) as
 
 -- | Essentially 'splitFunTys' on kinds
 splitKindFunTys :: Kind -> ([Kind],Kind)
@@ -110,12 +134,21 @@ splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k)
 -- Actually this function works fine on data types too, 
 -- but they'd always return '*', so we never need to ask
 synTyConResKind :: TyCon -> Kind
-synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
+synTyConResKind tycon = kindAppResult (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon))
 
 -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind, isConstraintKind :: Kind -> Bool
+isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind,
+  isConstraintKind, isAnyKind :: Kind -> Bool
+
 isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
-        isUnliftedTypeKindCon, isSubArgTypeKindCon, isConstraintKindCon      :: TyCon -> Bool
+  isUnliftedTypeKindCon, isSubArgTypeKindCon, tcIsSubArgTypeKindCon,
+  isSubOpenTypeKindCon, tcIsSubOpenTypeKindCon, isConstraintKindCon,
+  isAnyKindCon :: TyCon -> Bool
+
+isAnyKindCon tc     = tyConUnique tc == anyKindTyConKey
+
+isAnyKind (TyConApp tc _) = isAnyKindCon tc
+isAnyKind _               = False
 
 isOpenTypeKindCon tc    = tyConUnique tc == openTypeKindTyConKey
 
@@ -142,16 +175,31 @@ isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey
 isConstraintKind (TyConApp tc _) = isConstraintKindCon tc
 isConstraintKind _               = False
 
-isSubOpenTypeKind :: Kind -> Bool
--- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
-isSubOpenTypeKind (FunTy k1 k2)    = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) 
-                                     ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) 
-                                     False
-isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
-isSubOpenTypeKind other            = ASSERT( isKind other ) False
-         -- This is a conservative answer
-         -- It matters in the call to isSubKind in
-	 -- checkExpectedKind.
+
+-- Subkinding
+-- The tc variants are used during type-checking, where we don't want the
+-- Constraint kind to be a subkind of anything
+-- After type-checking (in core), Constraint is a subkind of argTypeKind
+isSubOpenTypeKind, tcIsSubOpenTypeKind :: Kind -> Bool
+-- ^ True of any sub-kind of OpenTypeKind
+isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc
+isSubOpenTypeKind _                = False
+
+-- ^ True of any sub-kind of OpenTypeKind
+tcIsSubOpenTypeKind (TyConApp kc []) = tcIsSubOpenTypeKindCon kc
+tcIsSubOpenTypeKind _                = False
+
+isSubOpenTypeKindCon kc
+  | isSubArgTypeKindCon kc   = True
+  | isUbxTupleKindCon kc     = True
+  | isOpenTypeKindCon kc     = True
+  | otherwise                = False
+
+tcIsSubOpenTypeKindCon kc
+  | tcIsSubArgTypeKindCon kc = True
+  | isUbxTupleKindCon kc     = True
+  | isOpenTypeKindCon kc     = True
+  | otherwise                = False
 
 isSubArgTypeKindCon kc
   | isUnliftedTypeKindCon kc = True
@@ -160,11 +208,18 @@ isSubArgTypeKindCon kc
   | isConstraintKindCon kc   = True
   | otherwise                = False
 
-isSubArgTypeKind :: Kind -> Bool
+tcIsSubArgTypeKindCon kc
+  | isConstraintKindCon kc   = False
+  | otherwise                = isSubArgTypeKindCon kc
+
+isSubArgTypeKind, tcIsSubArgTypeKind :: Kind -> Bool
 -- ^ True of any sub-kind of ArgTypeKind 
 isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
 isSubArgTypeKind _                = False
 
+tcIsSubArgTypeKind (TyConApp kc []) = tcIsSubArgTypeKindCon kc
+tcIsSubArgTypeKind _                = False
+
 -- | Is this a super-kind (i.e. a type-of-kinds)?
 isSuperKind :: Type -> Bool
 isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
@@ -176,25 +231,44 @@ isKind k = isSuperKind (typeKind k)
 
 isSubKind :: Kind -> Kind -> Bool
 -- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
-isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
-isSubKind (FunTy a1 r1) (FunTy a2 r2)	      = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
-isSubKind _             _                     = False
+
+isSubKind (FunTy a1 r1) (FunTy a2 r2)
+  = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
+
+isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s)
+  | isPromotedTypeTyCon kc1 || isPromotedTypeTyCon kc2
+    -- handles promoted kinds (List *, Nat, etc.)
+    = eqKind k1 k2
+
+  | isSuperKindTyCon kc1 || isSuperKindTyCon kc2
+    -- handles BOX
+    = ASSERT2( isSuperKindTyCon kc2 && null k1s && null k2s, ppr kc1 <+> ppr kc2 )
+      True
+
+  | otherwise = -- handles usual kinds (*, #, (#), etc.)
+                ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 )
+                kc1 `isSubKindCon` kc2
+
+
+isSubKind k1 k2 = eqKind k1 k2
 
 isSubKindCon :: TyCon -> TyCon -> Bool
 -- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
 isSubKindCon kc1 kc2
-  | isLiftedTypeKindCon kc1   && isLiftedTypeKindCon kc2   = True
-  | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
-  | isUbxTupleKindCon kc1     && isUbxTupleKindCon kc2     = True
-  | isConstraintKindCon kc1   && isConstraintKindCon kc2   = True
-  | isOpenTypeKindCon kc2                                  = True 
-                           -- we already know kc1 is not a fun, its a TyCon
-  | isArgTypeKindCon kc2      && isSubArgTypeKindCon kc1   = True
+  | kc1 == kc2                                             = True
+  | isSubArgTypeKindCon  kc1  && isArgTypeKindCon  kc2     = True
+  | isSubOpenTypeKindCon kc1  && isOpenTypeKindCon kc2     = True
   | otherwise                                              = False
 
+tcIsSubKindCon :: TyCon -> TyCon -> Bool
+tcIsSubKindCon kc1 kc2
+  | kc1 == kc2                                         = True
+  | isConstraintKindCon kc1 || isConstraintKindCon kc2 = False
+  | otherwise                                          = isSubKindCon kc1 kc2
+
 defaultKind :: Kind -> Kind
--- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
--- information on what that means
+-- ^ Used when generalising: default kind ? and ?? to *.
+-- See "Type#kind_subtyping" for more information on what that means
 
 -- When we generalise, we make generic type variables whose kind is
 -- simple (* or *->* etc).  So generic type variables (other than
@@ -206,9 +280,78 @@ defaultKind :: Kind -> Kind
 -- 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 k 
+-- and the calling conventions differ.
+-- This defaulting is done in TcMType.zonkTcTyVarBndr.
+defaultKind k
   | isSubOpenTypeKind k = liftedTypeKind
-  | isSubArgTypeKind k  = liftedTypeKind
-  | otherwise        = k
-\end{code}
\ No newline at end of file
+  | otherwise           = k
+
+splitKiTyVars :: [TyVar] -> ([KindVar], [TyVar])
+-- Precondition: kind variables should precede type variables
+-- Postcondition: appending the two result lists gives the input!
+splitKiTyVars = span (isSuperKind . tyVarKind)
+
+partitionKiTyVars :: [TyVar] -> ([KindVar], [TyVar])
+partitionKiTyVars = partition (isSuperKind . tyVarKind)
+
+-- Checks if this "type or kind" variable is a kind variable
+isKiVar :: TyVar -> Bool
+isKiVar v = isSuperKind (varType v)
+
+-- Returns the free kind variables in a kind
+kiVarsOfKind :: Kind -> VarSet
+kiVarsOfKind = tyVarsOfType
+
+kiVarsOfKinds :: [Kind] -> VarSet
+kiVarsOfKinds = tyVarsOfTypes
+
+-- Datatype promotion
+isPromotableType :: Type -> Bool
+isPromotableType = go emptyVarSet
+  where
+    go vars (TyConApp tc tys) = ASSERT( not (isPromotedDataTyCon tc) ) all (go vars) tys
+    go vars (FunTy arg res) = all (go vars) [arg,res]
+    go vars (TyVarTy tvar) = tvar `elemVarSet` vars
+    go vars (ForAllTy tvar ty) = isPromotableTyVar tvar && go (vars `extendVarSet` tvar) ty
+    go _ _ = panic "isPromotableType"  -- argument was not kind-shaped
+
+isPromotableTyVar :: TyVar -> Bool
+isPromotableTyVar = isLiftedTypeKind . varType
+
+-- | Promotes a type to a kind. Assumes the argument is promotable.
+promoteType :: Type -> Kind
+promoteType (TyConApp tc tys) = mkTyConApp (mkPromotedTypeTyCon tc) 
+                                           (map promoteType tys)
+  -- T t1 .. tn  ~~>  'T k1 .. kn  where  ti ~~> ki
+promoteType (FunTy arg res) = mkArrowKind (promoteType arg) (promoteType res)
+  -- t1 -> t2  ~~>  k1 -> k2  where  ti ~~> ki
+promoteType (TyVarTy tvar) = mkTyVarTy (promoteTyVar tvar)
+  -- a :: *  ~~>  a :: BOX
+promoteType (ForAllTy tvar ty) = ForAllTy (promoteTyVar tvar) (promoteType ty)
+  -- forall (a :: *). t  ~~> forall (a :: BOX). k  where  t ~~> k
+promoteType _ = panic "promoteType"  -- argument was not kind-shaped
+
+promoteTyVar :: TyVar -> KindVar
+promoteTyVar tvar = mkKindVar (tyVarName tvar) tySuperKind
+
+-- If kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
+isPromotableKind :: Kind -> Maybe Int
+isPromotableKind kind =
+  let (args, res) = splitKindFunTys kind in
+  if all isLiftedTypeKind (res:args)
+  then Just $ length args
+  else Nothing
+
+{- Note [Promoting a Type to a Kind]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only promote the followings.
+- Type variables: a
+- Fully applied arrow types: tau -> sigma
+- Fully applied type constructors of kind:
+     n >= 0
+  /-----------\
+  * -> ... -> * -> *
+- Polymorphic types over type variables of kind star:
+  forall (a::*). tau
+-}
+\end{code}
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 6db746bc76..f8745e62fb 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -36,7 +36,8 @@ module TyCon(
 	mkSynTyCon,
         mkSuperKindTyCon,
         mkForeignTyCon,
-        mkAnyTyCon,
+	mkPromotedDataTyCon,
+	mkPromotedTypeTyCon,
 
         -- ** Predicates on TyCons
         isAlgTyCon,
@@ -46,7 +47,8 @@ module TyCon(
         isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, 
         isSynTyCon, isClosedSynTyCon,
         isSuperKindTyCon, isDecomposableTyCon,
-        isForeignTyCon, isAnyTyCon, tyConHasKind,
+        isForeignTyCon, tyConHasKind,
+        isPromotedDataTyCon, isPromotedTypeTyCon,
 
 	isInjectiveTyCon,
 	isDataTyCon, isProductTyCon, isEnumerationTyCon, 
@@ -90,7 +92,7 @@ module TyCon(
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TypeRep ( Kind, Type, PredType )
-import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
+import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon, dataConName )
 import {-# SOURCE #-} IParam  ( ipTyConName )
 
 import Var
@@ -341,7 +343,7 @@ data TyCon
 	tc_kind     :: Kind,
 	tyConArity  :: Arity,
 
-	tyConTyVars :: [TyVar],	  -- ^ The type variables used in the type constructor.
+	tyConTyVars :: [TyVar],	  -- ^ The kind and type variables used in the type constructor.
                                   -- Invariant: length tyvars = arity
 	                          -- Precisely, this list scopes over:
 	                          --
@@ -427,19 +429,6 @@ data TyCon
                                            --   holds the name of the imported thing
     }
 
-  -- | Any types.  Like tuples, this is a potentially-infinite family of TyCons
-  --   one for each distinct Kind. They have no values at all.
-  --   Because there are infinitely many of them (like tuples) they are 
-  --   defined in GHC.Prim and have names like "Any(*->*)".  
-  --   Their Unique is derived from the OccName.
-  -- See Note [Any types] in TysPrim
-  | AnyTyCon {
-	tyConUnique  :: Unique,
-	tyConName    :: Name,
-	tc_kind      :: Kind	-- Never = *; that is done via PrimTyCon
-		     		-- See Note [Any types] in TysPrim
-    }
-
   -- | Super-kinds. These are "kinds-of-kinds" and are never seen in
   -- Haskell source programs.  There are only two super-kinds: TY (aka
   -- "box"), which is the super-kind of kinds that construct types
@@ -451,6 +440,23 @@ data TyCon
         tyConUnique :: Unique,
         tyConName   :: Name
     }
+
+  -- | Represents promoted data constructor.
+  | PromotedDataTyCon {	   	-- See Note [Promoted data constructors]
+	tyConUnique :: Unique, -- ^ Same Unique as the data constructor
+	tyConName   :: Name,   -- ^ Same Name as the data constructor
+	tc_kind     :: Kind,   -- ^ Translated type of the data constructor
+        dataCon     :: DataCon -- ^ Corresponding data constructor
+    }
+
+  -- | Represents promoted type constructor.
+  | PromotedTypeTyCon {
+	tyConUnique :: Unique, -- ^ Same Unique as the type constructor
+	tyConName   :: Name,   -- ^ Same Name as the type constructor
+	tyConArity  :: Arity,  -- ^ n if ty_con :: * -> ... -> *  n times
+        ty_con      :: TyCon   -- ^ Corresponding type constructor
+    }
+
   deriving Typeable
 
 -- | Names of the fields in an algebraic record type
@@ -551,6 +557,7 @@ data TyConParent
     NoParentTyCon
 
   -- | Type constructors representing a class dictionary.
+  -- See Note [ATyCon for classes] in TypeRep
   | ClassTyCon
 	Class		-- INVARIANT: the classTyCon of this Class is the current tycon
 
@@ -619,6 +626,34 @@ data SynTyConRhs
    | SynFamilyTyCon
 \end{code}
 
+Note [Promoted data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A data constructor can be promoted to become a type constructor,
+via the PromotedDataTyCon alternative in TyCon.
+
+* Only "vanilla" data constructors are promoted; ones with no GADT
+  stuff, no existentials, etc.  We might generalise this later.
+
+* The TyCon promoted from a DataCon has the *same* Name and Unique as
+  the DataCon.  Eg. If the data constructor Data.Maybe.Just(unique 78,
+  say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78)
+
+* The *kind* of a promoted DataCon may be polymorphic.  Example:
+    type of DataCon           Just :: forall (a:*). a -> Maybe a
+    kind of (promoted) tycon  Just :: forall (a:box). a -> Maybe a
+  The kind is not identical to the type, because of the */box 
+  kind signature on the forall'd variable; so the tc_kind field of
+  PromotedDataTyCon is not identical to the dataConUserType of the 
+  DataCon.  But it's the same modulo changing the variable kinds,
+  done by Kind.promoteType. 
+
+* Small note: We promote the *user* type of the DataCon.  Eg
+     data T = MkT {-# UNPACK #-} !(Bool, Bool)
+  The promoted kind is
+     MkT :: (Bool,Bool) -> T
+  *not* 
+     MkT :: Bool -> Bool -> T
+
 Note [Enumeration types]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 We define datatypes with no constructors to *not* be
@@ -933,12 +968,6 @@ mkSynTyCon name kind tyvars rhs parent
         synTcParent = parent
     }
 
-mkAnyTyCon :: Name -> Kind -> TyCon
-mkAnyTyCon name kind 
-  = AnyTyCon {  tyConName = name,
-		tc_kind = kind,
-        	tyConUnique = nameUnique name }
-
 -- | Create a super-kind 'TyCon'
 mkSuperKindTyCon :: Name -> TyCon -- Super kinds always have arity zero
 mkSuperKindTyCon name
@@ -946,6 +975,27 @@ mkSuperKindTyCon name
         tyConName = name,
         tyConUnique = nameUnique name
   }
+
+-- | Create a promoted data constructor 'TyCon'
+mkPromotedDataTyCon :: DataCon -> Name -> Unique -> Kind -> TyCon
+mkPromotedDataTyCon con name unique kind
+  = PromotedDataTyCon {
+        tyConName = name,
+        tyConUnique = unique,
+        tc_kind = kind,
+        dataCon = con
+  }
+
+-- | Create a promoted type constructor 'TyCon'
+mkPromotedTypeTyCon :: TyCon -> TyCon
+mkPromotedTypeTyCon con
+  = PromotedTypeTyCon {
+        tyConName = getName con,
+        tyConUnique = getUnique con,
+        tyConArity = tyConArity con,
+        ty_con = con
+  }
+
 \end{code}
 
 \begin{code}
@@ -1016,6 +1066,7 @@ isDistinctTyCon (AlgTyCon {algTcRhs = rhs}) = isDistinctAlgRhs rhs
 isDistinctTyCon (FunTyCon {})               = True
 isDistinctTyCon (TupleTyCon {})             = True
 isDistinctTyCon (PrimTyCon {})              = True
+isDistinctTyCon (PromotedDataTyCon {})      = True
 isDistinctTyCon _                           = False
 
 isDistinctAlgRhs :: AlgTyConRhs -> Bool
@@ -1178,10 +1229,15 @@ isSuperKindTyCon :: TyCon -> Bool
 isSuperKindTyCon (SuperKindTyCon {}) = True
 isSuperKindTyCon _                   = False
 
--- | Is this an AnyTyCon?
-isAnyTyCon :: TyCon -> Bool
-isAnyTyCon (AnyTyCon {}) = True
-isAnyTyCon _              = False
+-- | Is this a PromotedDataTyCon?
+isPromotedDataTyCon :: TyCon -> Bool
+isPromotedDataTyCon (PromotedDataTyCon {}) = True
+isPromotedDataTyCon _                      = False
+
+-- | Is this a PromotedTypeTyCon?
+isPromotedTypeTyCon :: TyCon -> Bool
+isPromotedTypeTyCon (PromotedTypeTyCon {}) = True
+isPromotedTypeTyCon _                      = False
 
 -- | Identifies implicit tycons that, in particular, do not go into interface
 -- files (because they are implicitly reconstructed when the interface is
@@ -1249,12 +1305,12 @@ expand tvs rhs tys
 \begin{code}
 
 tyConKind :: TyCon -> Kind
-tyConKind (FunTyCon   { tc_kind = k }) = k
-tyConKind (AlgTyCon   { tc_kind = k }) = k
-tyConKind (TupleTyCon { tc_kind = k }) = k
-tyConKind (SynTyCon   { tc_kind = k }) = k
-tyConKind (PrimTyCon  { tc_kind = k }) = k
-tyConKind (AnyTyCon   { tc_kind = k }) = k
+tyConKind (FunTyCon          { tc_kind = k }) = k
+tyConKind (AlgTyCon          { tc_kind = k }) = k
+tyConKind (TupleTyCon        { tc_kind = k }) = k
+tyConKind (SynTyCon          { tc_kind = k }) = k
+tyConKind (PrimTyCon         { tc_kind = k }) = k
+tyConKind (PromotedDataTyCon { tc_kind = k }) = k
 tyConKind tc = pprPanic "tyConKind" (ppr tc)	-- SuperKindTyCon and CoTyCon
 
 tyConHasKind :: TyCon -> Bool
@@ -1458,7 +1514,8 @@ instance Uniquable TyCon where
     getUnique tc = tyConUnique tc
 
 instance Outputable TyCon where
-    ppr tc  = ppr (getName tc) 
+    ppr (PromotedDataTyCon {dataCon = dc}) = quote (ppr (dataConName dc))
+    ppr tc = ppr (getName tc)
 
 instance NamedThing TyCon where
     getName = tyConName
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 69c31823ab..cb253d82fc 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -21,7 +21,7 @@ module Type (
 	-- $type_classification
 	
         -- $representation_types
-        TyThing(..), Type, PredType, ThetaType,
+        TyThing(..), Type, KindOrType, PredType, ThetaType,
         Var, TyVar, isTyVar, 
 
         -- ** Constructing and deconstructing types
@@ -34,11 +34,12 @@ module Type (
 	splitFunTys, splitFunTysN,
 	funResultTy, funArgTy, zipFunTys, 
 
-	mkTyConApp, mkTyConTy, 
+	mkTyConApp, mkTyConTy,
 	tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, 
 	splitTyConApp_maybe, splitTyConApp, 
 
         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
+        mkForAllArrowKinds,
 	applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
 	
 	-- (Newtypes)
@@ -62,7 +63,7 @@ module Type (
         funTyCon,
 
         -- ** Predicates on types
-        isTyVarTy, isFunTy, isDictTy, isPredTy,
+        isTyVarTy, isFunTy, isDictTy, isPredTy, isKindTy,
 
 	-- (Lifting and boxity)
 	isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
@@ -70,24 +71,25 @@ module Type (
 
 	-- * Main data types representing Kinds
 	-- $kind_subtyping
-        Kind, SimpleKind, KindVar,
+        Kind, SimpleKind, MetaKindVar,
 
         -- ** Finding the kind of a type
         typeKind,
         
         -- ** Common Kinds and SuperKinds
-        liftedTypeKind, unliftedTypeKind, openTypeKind,
+        anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind, constraintKind,
         tySuperKind, 
 
         -- ** Common Kind type constructors
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
         argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon,
+        anyKindTyCon,
 
 	-- * Type free variables
 	tyVarsOfType, tyVarsOfTypes,
 	expandTypeSynonyms, 
-	typeSize,
+	typeSize, varSetElemsKvsFirst, sortQuantVars,
 
 	-- * Type comparison
         eqType, eqTypeX, eqTypes, cmpType, cmpTypes, 
@@ -121,17 +123,16 @@ module Type (
         isInScope, composeTvSubst, zipTyEnv,
         isEmptyTvSubst, unionTvSubst,
 
-	-- ** Performing substitution on types
+	-- ** Performing substitution on types and kinds
 	substTy, substTys, substTyWith, substTysWith, substTheta, 
         substTyVar, substTyVars, substTyVarBndr,
-        cloneTyVarBndr, deShadowTy, lookupTyVar, 
+        cloneTyVarBndr, deShadowTy, lookupTyVar,
+        substKiWith, substKisWith,
 
 	-- * Pretty-printing
 	pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
 	pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, 
-        pprKind, pprParendKind,
-	
-	pprSourceTyCon
+        pprKind, pprParendKind, pprSourceTyCon,
     ) where
 
 #include "HsVersions.h"
@@ -139,7 +140,7 @@ module Type (
 -- We import the representation and primitive functions from TypeRep.
 -- Many things are reexported, but not the representation!
 
-import Kind    ( kindAppResult, kindFunResult, isTySuperKind, isSubOpenTypeKind )
+import Kind
 import TypeRep
 
 -- friends:
@@ -151,7 +152,7 @@ import Class
 import TyCon
 import TysPrim
 import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy )
-import PrelNames	         ( eqTyConKey, eqPrimTyConKey )
+import PrelNames	         ( eqTyConKey )
 
 -- others
 import {-# SOURCE #-} IParam ( ipTyCon )
@@ -674,6 +675,13 @@ mkForAllTy tyvar ty
 mkForAllTys :: [TyVar] -> Type -> Type
 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 
+mkForAllArrowKinds :: [TyVar] -> Kind -> Kind
+-- mkForAllArrowKinds [k1, k2, (a:k1 -> *)] k2
+-- returns forall k1 k2. (k1 -> *) -> k2
+mkForAllArrowKinds ktvs res =
+  mkForAllTys kvs $ mkArrowKinds (map tyVarKind tvs) res
+  where (kvs, tvs) = splitKiTyVars ktvs
+
 isForAllTy :: Type -> Bool
 isForAllTy (ForAllTy _ _) = True
 isForAllTy _              = False
@@ -715,12 +723,12 @@ applyTy, applyTys
 --
 -- We use @applyTys type-of-f [t1,t2]@ to compute the type of the expression.
 -- Panics if no application is possible.
-applyTy :: Type -> Type -> Type
+applyTy :: Type -> KindOrType -> Type
 applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg
 applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty
 applyTy _                _   = panic "applyTy"
 
-applyTys :: Type -> [Type] -> Type
+applyTys :: Type -> [KindOrType] -> Type
 -- ^ This function is interesting because:
 --
 --	1. The function may have more for-alls than there are args
@@ -731,12 +739,12 @@ applyTys :: Type -> [Type] -> Type
 --
 -- > applyTys (forall a.a) [forall b.b, Int]
 --
--- This really can happen, via dressing up polymorphic types with newtype
--- clothing.  Here's an example:
---
--- > newtype R = R (forall a. a->a)
--- > foo = case undefined :: R of
--- >            R f -> f ()
+-- This really can happen, but only (I think) in situations involving
+-- undefined.  For example:
+--       undefined :: forall a. a
+-- Term: undefined @(forall b. b->b) @Int 
+-- This term should have type (Int -> Int), but notice that
+-- there are more type args than foralls in 'undefined's type.
 
 applyTys ty args = applyTysD empty ty args
 
@@ -776,7 +784,12 @@ noParenPred :: PredType -> Bool
 noParenPred p = isClassPred p || isEqPred p
 
 isPredTy :: Type -> Bool
-isPredTy ty = typeKind ty `eqKind` constraintKind
+isPredTy ty
+  | isSuperKind ty = False
+  | otherwise = typeKind ty `eqKind` constraintKind
+
+isKindTy :: Type -> Bool
+isKindTy = isSuperKind . typeKind
 
 isClassPred, isEqPred, isIPPred :: PredType -> Bool
 isClassPred ty = case tyConAppTyCon_maybe ty of
@@ -796,10 +809,16 @@ Make PredTypes
 \begin{code}
 -- | Creates a type equality predicate
 mkEqPred :: (Type, Type) -> PredType
-mkEqPred (ty1, ty2) = TyConApp eqTyCon [ty1, ty2]
+mkEqPred (ty1, ty2)
+  -- IA0_TODO: The caller should give the kind.
+  = TyConApp eqTyCon [k, ty1, ty2]
+  where k = defaultKind (typeKind ty1)
 
 mkPrimEqType :: (Type, Type) -> Type
-mkPrimEqType (ty1, ty2) = TyConApp eqPrimTyCon [ty1, ty2]
+mkPrimEqType (ty1, ty2)
+  -- IA0_TODO: The caller should give the kind.
+  = TyConApp eqPrimTyCon [k, ty1, ty2]
+  where k = defaultKind (typeKind ty1)
 \end{code}
 
 --------------------- Implicit parameters ---------------------------------
@@ -877,7 +896,7 @@ classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of
     Just (tc, tys) | Just clas <- tyConClass_maybe tc
                    -> ClassPred clas tys
     Just (tc, tys) | tc `hasKey` eqTyConKey
-                   , let [ty1, ty2] = tys
+                   , let [_, ty1, ty2] = tys
                    -> EqPred ty1 ty2
     Just (tc, tys) | Just ip <- tyConIP_maybe tc
                    , let [ty] = tys
@@ -905,7 +924,7 @@ getEqPredTys ty = case getEqPredTys_maybe ty of
 
 getEqPredTys_maybe :: PredType -> Maybe (Type, Type)
 getEqPredTys_maybe ty = case splitTyConApp_maybe ty of 
-        Just (tc, [ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2)
+        Just (tc, [_, ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2)
         _ -> Nothing
 
 getIPPredTy_maybe :: PredType -> Maybe (IPName Name, Type)
@@ -927,6 +946,26 @@ typeSize (AppTy t1 t2)   = typeSize t1 + typeSize t2
 typeSize (FunTy t1 t2)   = typeSize t1 + typeSize t2
 typeSize (ForAllTy _ t)  = 1 + typeSize t
 typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts)
+
+varSetElemsKvsFirst :: VarSet -> [TyVar]
+-- {k1,a,k2,b} --> [k1,k2,a,b]
+varSetElemsKvsFirst set = uncurry (++) $ partitionKiTyVars (varSetElems set)
+
+sortQuantVars :: [Var] -> [Var]
+-- Sort the variables so the true kind then type variables come first
+sortQuantVars = sortLe le
+  where
+    v1 `le` v2 = case (is_tv v1, is_tv v2) of
+                   (True, False)  -> True
+                   (False, True)  -> False
+                   (True, True)   ->
+                     case (is_kv v1, is_kv v2) of
+                       (True, False) -> True
+                       (False, True) -> False
+                       _             -> v1 <= v2  -- Same family
+                   (False, False) -> v1 <= v2
+    is_tv v = isTyVar v
+    is_kv v = isSuperKind (tyVarKind v)
 \end{code}
 
 
@@ -1158,6 +1197,29 @@ cmpTypesX _   []        _         = LT
 cmpTypesX _   _         []        = GT
 \end{code}
 
+Note [cmpTypeX]
+~~~~~~~~~~~~~~~
+
+When we compare foralls, we should look at the kinds. But if we do so,
+we get a corelint error like the following (in
+libraries/ghc-prim/GHC/PrimopWrappers.hs):
+
+    Binder's type: forall (o_abY :: *).
+                   o_abY
+                   -> GHC.Prim.State# GHC.Prim.RealWorld
+                   -> GHC.Prim.State# GHC.Prim.RealWorld
+    Rhs type: forall (a_12 :: ?).
+              a_12
+              -> GHC.Prim.State# GHC.Prim.RealWorld
+              -> GHC.Prim.State# GHC.Prim.RealWorld
+
+This is why we don't look at the kind. Maybe we should look if the
+kinds are compatible.
+
+-- cmpTypeX env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)
+--   = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2) `thenCmp`
+--     cmpTypeX (rnBndr2 env tv1 tv2) t1 t2
+
 %************************************************************************
 %*									*
 		Type substitutions
@@ -1308,7 +1370,7 @@ instance Outputable TvSubst where
 
 %************************************************************************
 %*									*
-		Performing type substitutions
+		Performing type or kind substitutions
 %*									*
 %************************************************************************
 
@@ -1319,12 +1381,18 @@ substTyWith :: [TyVar] -> [Type] -> Type -> Type
 substTyWith tvs tys = ASSERT( length tvs == length tys )
 		      substTy (zipOpenTvSubst tvs tys)
 
+substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind
+substKiWith = substTyWith
+
 -- | Type substitution making use of an 'TvSubst' that
 -- is assumed to be open, see 'zipOpenTvSubst'
 substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
 substTysWith tvs tys = ASSERT( length tvs == length tys )
 		       substTys (zipOpenTvSubst tvs tys)
 
+substKisWith :: [KindVar] -> [Kind] -> [Kind] -> [Kind]
+substKisWith = substTysWith
+
 -- | Substitute within a 'Type'
 substTy :: TvSubst -> Type  -> Type
 substTy subst ty | isEmptyTvSubst subst = ty
@@ -1397,7 +1465,9 @@ substTyVarBndr subst@(TvSubst in_scope tenv) old_var
     _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv))
     -- Assertion check that we are not capturing something in the substitution
 
-    no_change = new_var == old_var
+    old_ki = tyVarKind old_var
+    no_kind_change = isEmptyVarSet (tyVarsOfType old_ki) -- verify that kind is closed
+    no_change = no_kind_change && (new_var == old_var)
 	-- no_change means that the new_var is identical in
 	-- all respects to the old_var (same unique, same kind)
 	-- See Note [Extending the TvSubst]
@@ -1408,7 +1478,8 @@ substTyVarBndr subst@(TvSubst in_scope tenv) old_var
 	--	(\x.e) with id_subst = [x |-> e']
 	-- Here we must simply zap the substitution for x
 
-    new_var = uniqAway in_scope old_var
+    new_var | no_kind_change = uniqAway in_scope old_var
+            | otherwise = uniqAway in_scope $ updateTyVarKind (substTy subst) old_var
 	-- The uniqAway part makes sure the new variable is not already in scope
 
 cloneTyVarBndr :: TvSubst -> TyVar -> Unique -> (TvSubst, TyVar)
@@ -1454,9 +1525,9 @@ Kinds
 --
 -- Where in the last example @t :: ??@ (i.e. is not an unboxed tuple)
 
-type KindVar = TyVar  -- invariant: KindVar will always be a 
-                      -- TcTyVar with details MetaTv TauTv ...
--- kind var constructors and functions are in TcType
+type MetaKindVar = TyVar  -- invariant: MetaKindVar will always be a
+                          -- TcTyVar with details MetaTv TauTv ...
+-- meta kind var constructors and functions are in TcType
 
 type SimpleKind = Kind
 \end{code}
@@ -1469,13 +1540,13 @@ type SimpleKind = Kind
 
 \begin{code}
 typeKind :: Type -> Kind
-typeKind ty@(TyConApp tc tys) 
-  = ASSERT2( not (tc `hasKey` eqPrimTyConKey) || length tys == 2, ppr ty )
-             -- Assertion checks for unsaturated application of ~#
-             -- See Note [The ~# TyCon] in TysPrim
-    kindAppResult (tyConKind tc) tys
+typeKind (TyConApp tc tys)
+  | isPromotedTypeTyCon tc
+  = ASSERT( tyConArity tc == length tys ) tySuperKind
+  | otherwise
+  = kindAppResult (tyConKind tc) tys
 
-typeKind (AppTy fun _)        = kindFunResult (typeKind fun)
+typeKind (AppTy fun arg)      = kindAppResult (typeKind fun) [arg]
 typeKind (ForAllTy _ ty)      = typeKind ty
 typeKind (TyVarTy tyvar)      = tyVarKind tyvar
 typeKind (FunTy _arg res)
@@ -1484,8 +1555,8 @@ typeKind (FunTy _arg res)
     -- The only things that can be after a function arrow are
     --   (a) types (of kind openTypeKind or its sub-kinds)
     --   (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
-    | isTySuperKind k         = k
-    | otherwise               = ASSERT( isSubOpenTypeKind k) liftedTypeKind 
+    | isSuperKind k         = k
+    | otherwise             = ASSERT( isSubOpenTypeKind k ) liftedTypeKind
     where
       k = typeKind res
 
diff --git a/compiler/types/Type.lhs-boot b/compiler/types/Type.lhs-boot
index c9378fb214..c2d2dec093 100644
--- a/compiler/types/Type.lhs-boot
+++ b/compiler/types/Type.lhs-boot
@@ -1,9 +1,12 @@
 \begin{code}
 module Type where
 import {-# SOURCE #-} TypeRep( Type, Kind )
+import Var
 
 noParenPred :: Type -> Bool
 isPredTy :: Type -> Bool
 
 typeKind :: Type -> Kind
+substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind
+eqKind :: Kind -> Kind -> Bool
 \end{code}
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 31664dcf5d..ea95c606ae 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -18,7 +18,7 @@
 module TypeRep (
 	TyThing(..),
 	Type(..),
-        Kind, SuperKind,
+        KindOrType, Kind, SuperKind,
         PredType, ThetaType,      -- Synonyms
 
         -- Functions over types
@@ -117,7 +117,7 @@ to cut all loops.  The other members of the loop may be marked 'non-recursive'.
 \begin{code}
 -- | The key representation of types within the compiler
 data Type
-  = TyVarTy TyVar	-- ^ Vanilla type variable (*never* a coercion variable)
+  = TyVarTy Var	-- ^ Vanilla type or kind variable (*never* a coercion variable)
 
   | AppTy
 	Type
@@ -130,7 +130,7 @@ data Type
 
   | TyConApp
 	TyCon
-	[Type]		-- ^ Application of a 'TyCon', including newtypes /and/ synonyms.
+	[KindOrType]	-- ^ Application of a 'TyCon', including newtypes /and/ synonyms.
 	                -- Invariant: saturated appliations of 'FunTyCon' must
 	                -- use 'FunTy' and saturated synonyms must use their own
                         -- constructors. However, /unsaturated/ 'FunTyCon's
@@ -151,11 +151,13 @@ data Type
 			-- See Note [Equality-constrained types]
 
   | ForAllTy
-	TyVar         -- Type variable
+	Var         -- Type or kind variable
 	Type	        -- ^ A polymorphic type
 
   deriving (Data.Data, Data.Typeable)
 
+type KindOrType = Type -- See Note [Arguments to type constructors]
+
 -- | The key type representing kinds in the compiler.
 -- Invariant: a kind is always in one of these forms:
 --
@@ -172,6 +174,30 @@ type Kind = Type
 type SuperKind = Type
 \end{code}
 
+
+Note [Arguments to type constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because of kind polymorphism, in addition to type application we now
+have kind instantiation. We reuse the same notations to do so.
+
+For example:
+
+  Just (* -> *) Maybe
+  Right * Nat Zero
+
+are represented by:
+
+  TyConApp (PromotedDataCon Just) [* -> *, Maybe]
+  TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)]
+
+Important note: Nat is used as a *kind* and not as a type. This can be
+confusing, since type-level Nat and kind-level Nat are identical. We
+use the kind of (PromotedDataCon Right) to know if its arguments are
+kinds or types.
+
+This kind instantiation only happens in TyConApp currently.
+
+
 Note [Equality-constrained types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The type   forall ab. (a ~ [b]) => blah
@@ -266,9 +292,12 @@ isLiftedTypeKind _                = False
 %*									*
 %************************************************************************
 
-\begin{code}
+\begin{code}  
 tyVarsOfType :: Type -> VarSet
 -- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
+-- tyVarsOfType returns only the free *type* variables of a type
+-- For example, tyVarsOfType (a::k) returns {a}, not including the
+-- kind variable {k}
 tyVarsOfType (TyVarTy v)         = unitVarSet v
 tyVarsOfType (TyConApp _ tys)    = tyVarsOfTypes tys
 tyVarsOfType (FunTy arg res)     = tyVarsOfType arg `unionVarSet` tyVarsOfType res
@@ -289,13 +318,22 @@ Despite the fact that DataCon has to be imported via a hi-boot route,
 this module seems the right place for TyThing, because it's needed for
 funTyCon and all the types in TysPrim.
 
+Note [ATyCon for classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Both classes and type constructors are represented in the type environment
+as ATyCon.  You can tell the difference, and get to the class, with
+   isClassTyCon :: TyCon -> Bool
+   tyConClass_maybe :: TyCon -> Maybe Class
+The Class and its associated TyCon have the same Name.
+
 \begin{code}
 -- | A typecheckable-thing, essentially anything that has a name
-data TyThing = AnId     Id
-	     | ADataCon DataCon
-	     | ATyCon   TyCon
-             | ACoAxiom CoAxiom
-        deriving (Eq, Ord)
+data TyThing 
+  = AnId     Id
+  | ADataCon DataCon
+  | ATyCon   TyCon       -- TyCons and classes; see Note [ATyCon for classes]
+  | ACoAxiom CoAxiom
+  deriving (Eq, Ord)
 
 instance Outputable TyThing where 
   ppr = pprTyThing
@@ -343,12 +381,13 @@ instance NamedThing TyThing where	-- Can't put this with the type
 -- 3. The substition is only applied ONCE! This is because
 -- in general such application will not reached a fixed point.
 data TvSubst 		
-  = TvSubst InScopeSet 	-- The in-scope type variables
-	    TvSubstEnv	-- Substitution of types
+  = TvSubst InScopeSet 	-- The in-scope type and kind variables
+	    TvSubstEnv  -- Substitutes both type and kind variables
 	-- See Note [Apply Once]
 	-- and Note [Extending the TvSubstEnv]
 
 -- | A substitition of 'Type's for 'TyVar's
+--                 and 'Kind's for 'KindVar's
 type TvSubstEnv = TyVarEnv Type
 	-- A TvSubstEnv is used both inside a TvSubst (with the apply-once
 	-- invariant discussed in Note [Apply Once]), and also independently
@@ -591,7 +630,7 @@ pprTcApp p pp tc tys
   = tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys)))
   | tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because
                            -- its not a SymOcc so won't get printed infix
-  , [ty1,ty2] <- tys
+  , [_, ty1,ty2] <- tys
   = pprInfixApp p pp (getName tc) ty1 ty2
   | otherwise
   = pprTypeNameApp p pp (getName tc) tys
diff --git a/compiler/types/TypeRep.lhs-boot b/compiler/types/TypeRep.lhs-boot
index 05c9d9b7cd..aef7067ca7 100644
--- a/compiler/types/TypeRep.lhs-boot
+++ b/compiler/types/TypeRep.lhs-boot
@@ -8,6 +8,7 @@ data TyThing
 
 type PredType = Type
 type Kind = Type
+type SuperKind = Type
 
 instance Outputable Type
 \end{code}
diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index 575bcfbeea..9a8cafc9ec 100644
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -41,8 +41,6 @@ import ErrUtils
 import Util
 import Maybes
 import FastString
-
-import Control.Monad (guard)
 \end{code}
 
 
@@ -175,7 +173,7 @@ match menv subst (TyVarTy tv1) ty2
   | tv1' `elemVarSet` me_tmpls menv
   = if any (inRnEnvR rn_env) (varSetElems (tyVarsOfType ty2))
     then Nothing	-- Occurs check
-    else do { subst1 <- match_kind menv subst tv1 ty2
+    else do { subst1 <- match_kind menv subst (tyVarKind tv1) (typeKind ty2)
 			-- Note [Matching kinds]
 	    ; return (extendVarEnv subst1 tv1' ty2) }
 
@@ -188,7 +186,8 @@ match menv subst (TyVarTy tv1) ty2
     tv1' = rnOccL rn_env tv1
 
 match menv subst (ForAllTy tv1 ty1) (ForAllTy tv2 ty2) 
-  = match menv' subst ty1 ty2
+  = do { subst' <- match_kind menv subst (tyVarKind tv1) (tyVarKind tv2)
+       ; match menv' subst' ty1 ty2 }
   where		-- Use the magic of rnBndr2 to go under the binders
     menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 }
 
@@ -207,11 +206,15 @@ match _ _ _ _
   = Nothing
 
 --------------
-match_kind :: MatchEnv -> TvSubstEnv -> TyVar -> Type -> Maybe TvSubstEnv
+match_kind :: MatchEnv -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv
 -- Match the kind of the template tyvar with the kind of Type
 -- Note [Matching kinds]
-match_kind _ subst tv ty
-  = guard (typeKind ty `isSubKind` tyVarKind tv) >> return subst
+match_kind menv subst k1 k2
+  | k2 `isSubKind` k1
+  = return subst
+
+  | otherwise
+  = match menv subst k1 k2
 
 -- Note [Matching kinds]
 -- ~~~~~~~~~~~~~~~~~~~~~
@@ -509,25 +512,29 @@ uUnrefined subst tv1 ty2 (TyVarTy tv2)
   | Just ty' <- lookupVarEnv subst tv2
   = uUnrefined subst tv1 ty' ty'
 
+  | otherwise
   -- So both are unrefined; next, see if the kinds force the direction
-  | eqKind k1 k2	-- Can update either; so check the bind-flags
-  = do	{ b1 <- tvBindFlag tv1
-	; b2 <- tvBindFlag tv2
-	; case (b1,b2) of
-	    (BindMe, _) 	 -> bind tv1 ty2
-	    (Skolem, Skolem)	 -> failWith (misMatch ty1 ty2)
-	    (Skolem, _)		 -> bind tv2 ty1
-	}
-
-  | k1 `isSubKind` k2 = bindTv subst tv2 ty1  -- Must update tv2
-  | k2 `isSubKind` k1 = bindTv subst tv1 ty2  -- Must update tv1
-
-  | otherwise = failWith (kindMisMatch tv1 ty2)
-  where
-    ty1 = TyVarTy tv1
-    k1 = tyVarKind tv1
-    k2 = tyVarKind tv2
-    bind tv ty = return $ extendVarEnv subst tv ty
+  = case (k1_sub_k2, k2_sub_k1) of
+        (True,  True)  -> choose subst
+        (True,  False) -> bindTv subst tv2 ty1
+        (False, True)  -> bindTv subst tv1 ty2
+        (False, False) -> do
+            { subst' <- unify subst k1 k2
+            ; choose subst' }
+  where subst_kind = mkTvSubst (mkInScopeSet (tyVarsOfTypes [k1,k2])) subst
+        k1 = substTy subst_kind (tyVarKind tv1)
+        k2 = substTy subst_kind (tyVarKind tv2)
+        k1_sub_k2 = k1 `isSubKind` k2
+        k2_sub_k1 = k2 `isSubKind` k1
+        ty1 = TyVarTy tv1
+        bind subst tv ty = return $ extendVarEnv subst tv ty
+        choose subst = do
+             { b1 <- tvBindFlag tv1
+             ; b2 <- tvBindFlag tv2
+             ; case (b1, b2) of
+                 (BindMe, _)         -> bind subst tv1 ty2
+                 (Skolem, Skolem)    -> failWith (misMatch ty1 ty2)
+                 (Skolem, _)         -> bind subst tv2 ty1 }
 
 uUnrefined subst tv1 ty2 ty2'	-- ty2 is not a type variable
   | tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2')
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index afbb665b46..bfddf5b322 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -447,20 +447,30 @@ instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
 
 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
     put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
-    get bh          = do a <- get bh
-                         b <- get bh
-                         c <- get bh
-                         d <- get bh
-                         return (a,b,c,d)
+    get bh            = do a <- get bh
+                           b <- get bh
+                           c <- get bh
+                           d <- get bh
+                           return (a,b,c,d)
 
 instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where
     put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;
-    get bh          = do a <- get bh
-                         b <- get bh
-                         c <- get bh
-                         d <- get bh
-                         e <- get bh
-                         return (a,b,c,d,e)
+    get bh               = do a <- get bh
+                              b <- get bh
+                              c <- get bh
+                              d <- get bh
+                              e <- get bh
+                              return (a,b,c,d,e)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
+    put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;
+    get bh                  = do a <- get bh
+                                 b <- get bh
+                                 c <- get bh
+                                 d <- get bh
+                                 e <- get bh
+                                 f <- get bh
+                                 return (a,b,c,d,e,f)
 
 instance Binary a => Binary (Maybe a) where
     put_ bh Nothing  = putByte bh 0
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index d69e8ada63..60fbe5b29a 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -30,7 +30,7 @@ module Outputable (
 	char,
 	text, ftext, ptext,
 	int, integer, float, double, rational,
-	parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
+	parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets,
 	semi, comma, colon, dcolon, space, equals, dot, arrow, darrow,
 	lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
 	blankLine,
@@ -449,11 +449,12 @@ float n     = docToSDoc $ Pretty.float n
 double n    = docToSDoc $ Pretty.double n
 rational n  = docToSDoc $ Pretty.rational n
 
-parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
+parens, braces, brackets, quotes, quote, doubleQuotes, angleBrackets :: SDoc -> SDoc
 
 parens d       = SDoc $ Pretty.parens . runSDoc d
 braces d       = SDoc $ Pretty.braces . runSDoc d
 brackets d     = SDoc $ Pretty.brackets . runSDoc d
+quote d        = SDoc $ Pretty.quote . runSDoc d
 doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
 angleBrackets d = char '<' <> d <> char '>'
 
diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs
index 0493daabee..cc8f235f2c 100644
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -106,7 +106,7 @@ Relative to John's original paper, there are the following new features:
         These new ones do the obvious things:
                 char, semi, comma, colon, space,
                 parens, brackets, braces,
-                quotes, doubleQuotes
+                quotes, quote, doubleQuotes
 
 4.      The "above" combinator, $$, now overlaps its two arguments if the
         last line of the top argument stops before the first line of the second begins.
@@ -165,7 +165,7 @@ module Pretty (
 
         char, text, ftext, ptext, zeroWidthText,
         int, integer, float, double, rational,
-        parens, brackets, braces, quotes, doubleQuotes,
+        parens, brackets, braces, quotes, quote, doubleQuotes,
         semi, comma, colon, space, equals,
         lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen,
 
@@ -233,8 +233,8 @@ char                      :: Char -> Doc
 semi, comma, colon, space, equals              :: Doc
 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
 
-parens, brackets, braces  :: Doc -> Doc
-quotes, doubleQuotes      :: Doc -> Doc
+parens, brackets, braces    :: Doc -> Doc
+quotes, quote, doubleQuotes :: Doc -> Doc
 
 int      :: Int -> Doc
 integer  :: Integer -> Doc
@@ -409,6 +409,7 @@ rational n = text (show (fromRat n :: Double))
 --rational n = text (show (fromRationalX n)) -- _showRational 30 n)
 
 quotes p        = char '`' <> p <> char '\''
+quote p         = char '\'' <> p
 doubleQuotes p  = char '"' <> p <> char '"'
 parens p        = char '(' <> p <> char ')'
 brackets p      = char '[' <> p <> char ']'
diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
index 76f79bcec3..6c26f099d7 100644
--- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
@@ -30,9 +30,7 @@ import Data.Array
 --
 initBuiltins :: DsM Builtins
 initBuiltins
- = do { assertDAPPLoaded      -- complain if 'Data.Array.Parallel.Prim' is not available
-
-          -- 'PArray': desugared array type
+ = do {   -- 'PArray': desugared array type
       ; parrayTyCon <- externalTyCon (fsLit "PArray")
       ; parray_tcs  <- mapM externalTyCon (suffixed "PArray" aLL_DPH_PRIM_TYCONS)
       ; let parray_PrimTyCons = mkNameEnv (zip aLL_DPH_PRIM_TYCONS parray_tcs)
@@ -206,19 +204,19 @@ initBuiltinTyCons bi
 -- Lookup a variable given its name and the module that contains it.
 --
 externalVar :: FastString -> DsM Var
-externalVar fs = lookupDAPPRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
+externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
 
 -- Like `externalVar` but wrap the `Var` in a `CoreExpr`.
 --
 externalFun :: FastString -> DsM CoreExpr
-externalFun fs = liftM Var $ externalVar fs
+externalFun fs = Var <$> externalVar fs
 
 -- Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name.
 --
 externalTyCon :: FastString -> DsM TyCon
-externalTyCon fs = lookupDAPPRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon
+externalTyCon fs = dsLookupDPHRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon
 
--- Lookup some `Type` given its name and the module that contains it.
+-- Lookup some `Type` in 'Data.Array.Parallel.Prim', given its name.
 --
 externalType :: FastString -> DsM Type
 externalType fs
@@ -229,7 +227,7 @@ externalType fs
 --
 externalClass :: FastString -> DsM Class
 externalClass fs 
-  = do { tycon <- lookupDAPPRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon
+  = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon
        ; case tyConClass_maybe tycon of
            Nothing  -> pprPanic "Vectorise.Builtins.Initialise" $ 
                          ptext (sLit "Data.Array.Parallel.Prim.") <> 
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index 2de71a5e3f..0020d67412 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -21,6 +21,7 @@ import InstEnv
 import FamInstEnv
 import CoreSyn
 import Type
+import Class
 import TyCon
 import DataCon
 import VarEnv
@@ -31,15 +32,20 @@ import Name
 import NameEnv
 import FastString
 
+import Data.Maybe
 
--- | Indicates what scope something (a variable) is in.
+
+-- |Indicates what scope something (a variable) is in.
+--
 data Scope a b 
         = Global a 
         | Local  b
 
 
 -- LocalEnv -------------------------------------------------------------------
--- | The local environment.
+
+-- |The local environment.
+--
 data LocalEnv
   = LocalEnv {
         -- Mapping from local variables to their vectorised and lifted versions.
@@ -55,8 +61,8 @@ data LocalEnv
         , local_bind_name :: FastString
         }
 
-
--- | Create an empty local environment.
+-- |Create an empty local environment.
+--
 emptyLocalEnv :: LocalEnv
 emptyLocalEnv = LocalEnv {
                    local_vars     = emptyVarEnv
@@ -188,6 +194,8 @@ setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps }
 -- data constructors referenced in VECTORISE pragmas, even if they are defined in an imported
 -- module.
 --
+-- The variables explicitly include class selectors and dfuns.
+--
 modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo
 modVectInfo env mg_ids mg_tyCons vectDecls info
   = info 
@@ -198,13 +206,17 @@ modVectInfo env mg_ids mg_tyCons vectDecls info
     , vectInfoScalarTyCons = global_scalar_tycons env `minusNameSet` vectInfoScalarTyCons info
     }
   where
-    vectIds        = [id    | Vect     id    _   <- vectDecls]
-    vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls] ++
-                     [tycon | VectClass tycon    <- vectDecls]
-    vectDataCons   = concatMap tyConDataCons vectTypeTyCons
-    ids            = mg_ids ++ vectIds
-    tyCons         = mg_tyCons ++ vectTypeTyCons
-    dataCons       = concatMap tyConDataCons mg_tyCons ++ vectDataCons
+    vectIds         = [id    | Vect     id    _   <- vectDecls] ++
+                      [id    | VectInst _ id      <- vectDecls]
+    vectTypeTyCons  = [tycon | VectType _ tycon _ <- vectDecls] ++
+                      [tycon | VectClass tycon    <- vectDecls]
+    vectDataCons    = concatMap tyConDataCons vectTypeTyCons
+    ids             = mg_ids ++ vectIds ++ selIds
+    tyCons          = mg_tyCons ++ vectTypeTyCons
+    dataCons        = concatMap tyConDataCons mg_tyCons ++ vectDataCons
+    selIds          = concat [ classAllSelIds cls 
+                             | tycon <- tyCons
+                             , cls <- maybeToList . tyConClass_maybe $ tycon]
     
     -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv'
     mk_env decls inspectedEnv
diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index 1a5701cc0f..bf6fe3165e 100644
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -398,16 +398,6 @@ unVectDict ty e
                                        Nothing  -> panic "Vectorise.Exp.unVectDict: no class"
     selIds                         = classAllSelIds cls
 
-{-
-!!!How about 'isClassOpId_maybe'?  Do we need to treat them specially to get the class ops for
-!!!the vectorised instances or do they just work out?? (We may want to make sure that the
-!!!vectorised Ids at least get the right IdDetails...)
-!!!NB: For *locally defined* instances, the selector functions are part of the vectorised bindings,
-!!!    but not so for *imported* instances, where we need to generate the vectorised versions from
-!!!    scratch.
-!!!Also need to take care of the builtin rules for selectors (see mkDictSelId).
- -}
-
 -- | Vectorise a lambda abstraction.
 --
 vectLam :: Bool             -- ^ When the RHS of a binding, whether that binding should be inlined.
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index a7d984cf83..6fbdb4e3ad 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -54,7 +54,7 @@ initV :: HscEnv
       -> IO (Maybe (VectInfo, a))
 initV hsc_env guts info thing_inside
   = do {
-         let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_clss guts) (mg_fam_insts guts)
+         let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
        ; (_, Just res) <- initDs hsc_env (mg_module guts)
                                          (mg_rdr_env guts) type_env go
 
@@ -89,7 +89,6 @@ initV hsc_env guts info thing_inside
                  builtin_prs = initClassDicts instEnvs (prClass builtins)  -- ..'PR' class instances
 
                -- construct the initial global environment
-           ; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside
            ; let genv = extendImportedVarsEnv builtin_vars
                         . extendTyConsEnv     builtin_tycons
                         . setPAFunsEnv        builtin_pas
@@ -97,7 +96,7 @@ initV hsc_env guts info thing_inside
                         $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
  
                -- perform vectorisation
-           ; r <- runVM thing_inside' builtins genv emptyLocalEnv
+           ; r <- runVM thing_inside builtins genv emptyLocalEnv
            ; case r of
                Yes genv _ x -> return $ Just (new_info genv, x)
                No reason    -> do { unqual <- mkPrintUnqualifiedDs
diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs
index adc2d0ca01..ecf0e81306 100644
--- a/compiler/vectorise/Vectorise/Monad/Naming.hs
+++ b/compiler/vectorise/Vectorise/Monad/Naming.hs
@@ -46,8 +46,8 @@ mkLocalisedName mk_occ name =
      ; return new_name
      }
 
--- |Produce the vectorised variant of an `Id` with the given type, while taking care that vectorised
--- dfun ids must be dfuns again.
+-- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that
+-- vectorised dfun ids must be dfuns again.
 --
 -- Force the new name to be a system name and, if the original was an external name, disambiguate
 -- the new name with the module name of the original.
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
index 1a0a434adc..7122cb7664 100644
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ b/compiler/vectorise/Vectorise/Type/Classify.hs
@@ -28,7 +28,9 @@ import Digraph
 
 -- |From a list of type constructors, extract those that can be vectorised, returning them in two
 -- sets, where the first result list /must be/ vectorised and the second result list /need not be/
--- vectroised.
+-- vectorised.  The third result list are those type constructors that we cannot convert (either
+-- because they use language extensions or because they dependent on type constructors for which
+-- no vectorised version is available).
 
 -- The first argument determines the /conversion status/ of external type constructors as follows:
 --
@@ -36,19 +38,19 @@ import Digraph
 -- * tycons which are not changed by vectorisation are mapped to 'False'
 -- * tycons which can't be converted are not elements of the map
 --
-classifyTyCons :: UniqFM Bool             -- ^type constructor conversion status
-               -> [TyCon]                 -- ^type constructors that need to be classified
-               -> ([TyCon], [TyCon])      -- ^tycons to be converted & not to be converted
-classifyTyCons convStatus tcs = classify [] [] convStatus (tyConGroups tcs)
+classifyTyCons :: UniqFM Bool                     -- ^type constructor conversion status
+               -> [TyCon]                         -- ^type constructors that need to be classified
+               -> ([TyCon], [TyCon], [TyCon])     -- ^tycons to be converted & not to be converted
+classifyTyCons convStatus tcs = classify [] [] [] convStatus (tyConGroups tcs)
   where
-    classify conv keep _  [] = (conv, keep)
-    classify conv keep cs ((tcs, ds) : rs)
+    classify conv keep ignored _  [] = (conv, keep, ignored)
+    classify conv keep ignored cs ((tcs, ds) : rs)
       | can_convert && must_convert
-      = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc, True) | tc <- tcs]) rs
+      = classify (tcs ++ conv) keep ignored (cs `addListToUFM` [(tc, True) | tc <- tcs]) rs
       | can_convert
-      = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc, False) | tc <- tcs]) rs
+      = classify conv (tcs ++ keep) ignored (cs `addListToUFM` [(tc, False) | tc <- tcs]) rs
       | otherwise
-      = classify conv keep cs rs
+      = classify conv keep (tcs ++ ignored) cs rs
       where
         refs = ds `delListFromUniqSet` tcs
 
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index a6112c714c..042d127258 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -162,9 +162,10 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
            -- appear in vectorised code.  (We also drop the local type constructors appearing in a
            -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as
            -- these are being handled separately.)
-       ; let maybeVectoriseTyCons   = filter notLocalScalarTyCon tycons ++ impVectTyCons
-             (conv_tcs, keep_tcs)   = classifyTyCons vectTyConFlavour maybeVectoriseTyCons
-             orig_tcs               = keep_tcs ++ conv_tcs
+           -- Furthermore, 'drop_tcs' are those type constructors that we cannot vectorise.
+       ; let maybeVectoriseTyCons           = filter notLocalScalarTyCon tycons ++ impVectTyCons
+             (conv_tcs, keep_tcs, drop_tcs) = classifyTyCons vectTyConFlavour maybeVectoriseTyCons
+             orig_tcs                       = keep_tcs ++ conv_tcs
              
        ; traceVt " VECT SCALAR    : " $ ppr localScalarTyCons
        ; traceVt " VECT [class]   : " $ ppr impVectTyCons
@@ -172,6 +173,13 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
        ; traceVt " -- after classification (local and VECT [class] tycons) --" empty
        ; traceVt " reuse          : " $ ppr keep_tcs
        ; traceVt " convert        : " $ ppr conv_tcs
+       
+           -- warn the user about unvectorised type constructors
+       ; let explanation = ptext (sLit "(They use unsupported language extensions") $$
+                           ptext (sLit "or depend on type constructors that are not vectorised)")
+       ; unless (null drop_tcs) $
+           emitVt "Warning: cannot vectorise these type constructors:" $ 
+             pprQuotedList drop_tcs $$ explanation
 
        ; let defTyConDataCons origTyCon vectTyCon
                = do { defTyCon origTyCon vectTyCon
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 38af2dc846..859056cd1a 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -48,8 +48,12 @@ vectTyConDecl tycon
            -- vectorise superclass constraint (types)
        ; theta' <- mapM vectType (classSCTheta cls)
 
-           -- vectorise method selectors and add them to the vectorisation map
-       ; methods' <- sequence [ vectMethod id meth | (id, meth) <- classOpItems cls]
+           -- vectorise method selectors
+       ; let opItems      = classOpItems cls
+             Just datacon = tyConSingleDataCon_maybe tycon
+             argTys       = dataConRepArgTys datacon                      -- all selector types
+             opTys        = drop (length argTys - length opItems) argTys  -- only method types
+       ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys]
 
            -- keep the original recursiveness flag
        ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
@@ -75,6 +79,11 @@ vectTyConDecl tycon
              Just datacon' = tyConSingleDataCon_maybe tycon'
        ; defDataCon datacon datacon'
 
+           -- the original superclass and methods selectors must map to the vectorised ones
+       ; let selIds  = classAllSelIds cls
+             selIds' = classAllSelIds cls'
+       ; zipWithM_ defGlobalVar selIds selIds'
+
            -- return the type constructor of the vectorised class
        ; return tycon'
        }
@@ -110,25 +119,17 @@ vectTyConDecl tycon
   | otherwise
   = cantVectorise "Can't vectorise exotic type constructor" (ppr tycon)
 
--- |Vectorise a class method.
+-- |Vectorise a class method.  (Don't enter it into the vectorisation map yet.)
 --
-vectMethod :: Id -> DefMeth -> VM (Name, DefMethSpec, Type)
-vectMethod id defMeth
+vectMethod :: Id -> DefMeth -> Type -> VM (Name, DefMethSpec, Type)
+vectMethod id defMeth ty
  = do {   -- Vectorise the method type.
-      ; typ' <- vectType (varType id)
+      ; ty' <- vectType ty
 
           -- Create a name for the vectorised method.
-      ; id' <- mkVectId id typ'
-      ; defGlobalVar id id'
-
-          -- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
-          -- to the types of each method. However, the types we get back from vectType
-          -- above already already have these, so we need to chop them off here otherwise
-          -- we'll get two copies in the final version.
-      ; let (_tyvars, tyBody) = splitForAllTys typ'
-      ; let (_dict,   tyRest) = splitFunTy tyBody
+      ; id' <- mkVectId id ty'
 
-      ; return  (Var.varName id', defMethSpecOfDefMeth defMeth, tyRest)
+      ; return  (Var.varName id', defMethSpecOfDefMeth defMeth, ty')
       }
 
 -- |Vectorise the RHS of an algebraic type.
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 5123e1026c..6d1b293701 100755
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -8575,6 +8575,26 @@ data S = S {-# UNPACK #-} !Int {-# UNPACK #-} !Int
       constructor field.</para>
     </sect2>
 
+    <sect2 id="nounpack-pragma">
+      <title>NOUNPACK pragma</title>
+
+      <indexterm><primary>NOUNPACK</primary></indexterm>
+
+      <para>The <literal>NOUNPACK</literal> pragma indicates to the compiler
+      that it should not unpack the contents of a constructor field.
+      Example:
+      </para>
+<programlisting>
+data T = T {-# NOUNPACK #-} !(Int,Int)
+</programlisting>
+      <para>
+        Even with the flags
+        <option>-funbox-strict-fields</option> and <option>-O</option>,
+        the field of the constructor <function>T</function> is not
+        unpacked.
+      </para>
+    </sect2>
+
     <sect2 id="source-pragma">
       <title>SOURCE pragma</title>
 
diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index eccd6f967e..4cace1ee88 100644
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -1932,7 +1932,12 @@ f "2"    = 2
 	    <para>This option is a bit of a sledgehammer: it might
 	    sometimes make things worse.  Selectively unboxing fields
 	    by using <literal>UNPACK</literal> pragmas might be
-	    better.</para>
+	    better. An alternative is to use
+        <option>-funbox-strict-fields</option> to turn on
+        unboxing by default but disable it for certain constructor
+        fields using the <literal>NOUNPACK</literal> pragma
+        (see <xref linkend="nounpack-pragma"/>).
+        </para>
 	  </listitem>
 	</varlistentry>
 
diff --git a/ghc.mk b/ghc.mk
index 8ae3e04d26..2d8aaf419c 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -313,9 +313,12 @@ endif
 # Packages that are built but not installed
 PKGS_THAT_ARE_INTREE_ONLY := haskeline mtl terminfo utf8-string xhtml
 
-PKGS_THAT_ARE_DPH := dph/dph-base dph/dph-prim-interface dph/dph-prim-seq \
-                dph/dph-common dph/dph-prim-par dph/dph-par dph/dph-seq \
-                vector primitive random
+PKGS_THAT_ARE_DPH := \
+    dph/dph-base \
+    dph/dph-prim-interface dph/dph-prim-seq dph/dph-prim-par \
+    dph/dph-lifted-base \
+    dph/dph-lifted-boxed dph/dph-lifted-copy dph/dph-lifted-vseg \
+    vector primitive random
 
 # Packages that, if present, must be built by the stage2 compiler,
 # because they use TH and/or annotations, or depend on other stage2
@@ -539,8 +542,6 @@ endif
 # these cases, so we just skip checking them.
 # NB. these must come before we include the ghc.mk files below, because
 # they disable the relevant rules.
-CHECKED_libraries/dph/dph-seq = YES
-CHECKED_libraries/dph/dph-par = YES
 # In compiler's case, include-dirs points outside of the source tree
 CHECKED_compiler = YES
 
diff --git a/libffi/package.conf.in b/libffi/package.conf.in
deleted file mode 100644
index fa07e5f8fe..0000000000
--- a/libffi/package.conf.in
+++ /dev/null
@@ -1,35 +0,0 @@
-name:		ffi
-version:	1.0
-id:             builtin_ffi
-license:	BSD3
-maintainer:	glasgow-haskell-users@haskell.org
-exposed:	True
-
-exposed-modules:
-hidden-modules:
-import-dirs:
-
-#ifdef INSTALLING
-library-dirs:		LIB_DIR
-#else /* !INSTALLING */
-library-dirs:		TOP"/libffi/dist-install/build"
-#endif
-
-hs-libraries:   "HSffi"
-
-#ifdef INSTALLING
-include-dirs:		INCLUDE_DIR
-#else /* !INSTALLING */
-include-dirs:		TOP"/libffi/dist-install/build"
-#endif
-
-depends:
-hugs-options:
-cc-options:
-
-framework-dirs:
-frameworks:
-
-haddock-interfaces:
-haddock-html:
-
diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk
index 6afac177a6..0516be8f56 100644
--- a/mk/validate-settings.mk
+++ b/mk/validate-settings.mk
@@ -21,7 +21,7 @@ SRC_HC_OPTS     += -Wall $(WERROR) -H64m -O0
 
 GhcStage1HcOpts += -O -fwarn-tabs
 
-GhcStage2HcOpts += -O -fwarn-tabs
+GhcStage2HcOpts += -O -fwarn-tabs -dcore-lint
 # Using -O (rather than -O0) here bringes my validate down from 22mins to 16 mins.
 # Compiling stage2 takes longer, but we gain a faster haddock, faster
 # running of the tests, and faster building of the utils to be installed
@@ -99,8 +99,7 @@ libraries/dph/dph-base_dist-install_EXTRA_HC_OPTS += -Wwarn
 libraries/dph/dph-prim-interface_dist-install_EXTRA_HC_OPTS += -Wwarn
 libraries/dph/dph-prim-seq_dist-install_EXTRA_HC_OPTS += -Wwarn
 libraries/dph/dph-prim-par_dist-install_EXTRA_HC_OPTS += -Wwarn
-libraries/dph/dph-seq_dist-install_EXTRA_HC_OPTS += -Wwarn
-libraries/dph/dph-par_dist-install_EXTRA_HC_OPTS += -Wwarn
+libraries/dph/dph-lifted-common-install_EXTRA_HC_OPTS += -Wwarn
 
 # We need to turn of deprecated warnings for SafeHaskell transition
 libraries/array_dist-install_EXTRA_HC_OPTS += -fno-warn-warnings-deprecations
diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 9f48f5d8f5..586086ebf3 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -427,7 +427,9 @@ stg_raisezh
      */
     if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) {
         SAVE_THREAD_STATE();
-        foreign "C" fprintCCS_stderr(W_[CCCS] "ptr", CurrentTSO "ptr") [];
+        foreign "C" fprintCCS_stderr(W_[CCCS] "ptr",
+                                     exception "ptr",
+                                     CurrentTSO "ptr") [];
         LOAD_THREAD_STATE();
     }
 #endif
diff --git a/rts/Profiling.c b/rts/Profiling.c
index c75a344c7f..38191ff4bd 100644
--- a/rts/Profiling.c
+++ b/rts/Profiling.c
@@ -17,6 +17,7 @@
 #include "ProfHeap.h"
 #include "Arena.h"
 #include "RetainerProfile.h"
+#include "Printer.h"
 
 #include <string.h>
 
@@ -1001,7 +1002,7 @@ static rtsBool fprintCallStack (CostCentreStack *ccs)
 
 /* For calling from .cmm code, where we can't reliably refer to stderr */
 void
-fprintCCS_stderr (CostCentreStack *ccs, StgTSO *tso)
+fprintCCS_stderr (CostCentreStack *ccs, StgClosure *exception, StgTSO *tso)
 {
     rtsBool is_caf;
     StgPtr frame;
@@ -1010,7 +1011,26 @@ fprintCCS_stderr (CostCentreStack *ccs, StgTSO *tso)
     nat depth = 0;
     const nat MAX_DEPTH = 10; // don't print gigantic chains of stacks
 
-    fprintf(stderr, "*** Exception raised (reporting due to +RTS -xc), stack trace:\n  ");
+    {
+        char *desc;
+        StgInfoTable *info;
+        info = get_itbl(exception);
+        switch (info->type) {
+        case CONSTR:
+        case CONSTR_1_0:
+        case CONSTR_0_1:
+        case CONSTR_2_0:
+        case CONSTR_1_1:
+        case CONSTR_0_2:
+        case CONSTR_STATIC:
+        case CONSTR_NOCAF_STATIC:
+            desc = GET_CON_DESC(itbl_to_con_itbl(info));
+        default:
+            desc = closure_type_names[info->type];
+        }
+        fprintf(stderr, "*** Exception (reporting due to +RTS -xc): (%s), stack trace: \n  ", desc);
+    }
+
     is_caf = fprintCallStack(ccs);
 
     // traverse the stack down to the enclosing update frame to
diff --git a/rts/Profiling.h b/rts/Profiling.h
index 2ee3311c81..8c365220fb 100644
--- a/rts/Profiling.h
+++ b/rts/Profiling.h
@@ -35,7 +35,7 @@ void reportCCSProfiling ( void );
 void PrintNewStackDecls ( void );
 
 void fprintCCS( FILE *f, CostCentreStack *ccs );
-void fprintCCS_stderr (CostCentreStack *ccs, StgTSO *tso);
+void fprintCCS_stderr (CostCentreStack *ccs, StgClosure *exception, StgTSO *tso);
 
 #ifdef DEBUG
 void debugCCS( CostCentreStack *ccs );
diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index acc87b1938..c7b10b856e 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -739,7 +739,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
      */
     if (RtsFlags.ProfFlags.showCCSOnException)
     {
-        fprintCCS_stderr(tso->prof.CCCS,tso);
+        fprintCCS_stderr(tso->prof.CCCS,exception,tso);
     }
 #endif
     // ASSUMES: the thread is not already complete or dead
diff --git a/rts/package.conf.in b/rts/package.conf.in
index e38a38186d..a1161eaa6f 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -92,6 +92,7 @@ ld-options:
          , "-u", "_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure"
          , "-u", "_base_ControlziExceptionziBase_nestedAtomically_closure"
          , "-u", "_base_GHCziWeak_runFinalizzerBatch_closure"
+         , "-u", "_base_GHCziTopHandler_flushStdHandles_closure"
          , "-u", "_base_GHCziTopHandler_runIO_closure"
          , "-u", "_base_GHCziTopHandler_runNonIO_closure"
 	 , "-u", "_base_GHCziConcziIO_ensureIOManagerIsRunning_closure"
@@ -130,6 +131,7 @@ ld-options:
          , "-u", "base_GHCziIOziException_blockedIndefinitelyOnSTM_closure"
          , "-u", "base_ControlziExceptionziBase_nestedAtomically_closure"
          , "-u", "base_GHCziWeak_runFinalizzerBatch_closure"
+         , "-u", "base_GHCziTopHandler_flushStdHandles_closure"
          , "-u", "base_GHCziTopHandler_runIO_closure"
          , "-u", "base_GHCziTopHandler_runNonIO_closure"
 	 , "-u", "base_GHCziConcziIO_ensureIOManagerIsRunning_closure"
diff --git a/rts/win32/Ticker.c b/rts/win32/Ticker.c
index 929e6f4086..1c45482651 100644
--- a/rts/win32/Ticker.c
+++ b/rts/win32/Ticker.c
@@ -153,7 +153,8 @@ exitTicker (rtsBool wait)
 	    if (!GetExitCodeThread(tickThread, &exitCode)) {
 		return;
 	    }
-	    if (exitCode != STILL_ACTIVE) {
+            CloseHandle(tickThread);
+            if (exitCode != STILL_ACTIVE) {
 		tickThread = INVALID_HANDLE_VALUE;
 		if ( hStopEvent != INVALID_HANDLE_VALUE ) {
 		    CloseHandle(hStopEvent);