Do dependency analysis when kind-checking type declarations

This patch fixes Trac #4875.  The main point is to do dependency
analysis on type and class declarations, and kind-check them in
dependency order, so as to improve error messages.

This patch means that a few programs that would typecheck before won't
typecheck any more; but before we were (naughtily) going beyond
Haskell 98 without any language-extension flags, and Trac #4875
convinces me that doing so is a Bad Idea.

Here's an example that won't typecheck any more
       data T a b = MkT (a b)
       type F k = T k Maybe

If you look at T on its own you'd default 'a' to kind *->*;
and then kind-checking would fail on F.

But GHC currently accepts this program beause it looks at
the *occurrences* of T.

9 files changed, 254 insertions, 254 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7d70ad8d6f..5da376b574 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -119,7 +119,7 @@ repTopDs group
 	
 	decls <- addBinds ss (do {
 			val_ds  <- rep_val_binds (hs_valds group) ;
-			tycl_ds <- mapM repTyClD (hs_tyclds group) ;
+			tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
 			inst_ds <- mapM repInstD' (hs_instds group) ;
 			for_ds <- mapM repForD (hs_fords group) ;
 			-- more needed
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index fd6d3bbf45..8827f3ab64 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -126,7 +126,12 @@ data HsDecl id
 data HsGroup id
   = HsGroup {
 	hs_valds  :: HsValBinds id,
-	hs_tyclds :: [LTyClDecl id],
+
+	hs_tyclds :: [[LTyClDecl id]],	
+		-- A list of mutually-recursive groups
+		-- Parser generates a singleton list;
+		-- renamer does dependency analysis
+
 	hs_instds :: [LInstDecl id],
         hs_derivds :: [LDerivDecl id],
 
@@ -228,7 +233,8 @@ instance OutputableBndr name => Outputable (HsGroup name) where
 	     if isEmptyValBinds val_decls 
                 then Nothing 
                 else Just (ppr val_decls),
-	     ppr_ds tycl_decls, ppr_ds inst_decls,
+	     ppr_ds (concat tycl_decls), 
+             ppr_ds inst_decls,
              ppr_ds deriv_decls,
 	     ppr_ds foreign_decls]
 	where
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index d17f85099f..3ef4bff177 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -60,7 +60,7 @@ module HsUtils(
   collectLStmtBinders, collectStmtBinders,
   collectSigTysFromPats, collectSigTysFromPat,
 
-  hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders, 
+  hsTyClDeclBinders, hsTyClDeclsBinders, 
   hsForeignDeclsBinders, hsGroupBinders
   ) where
 
@@ -572,9 +572,10 @@ hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
 hsForeignDeclsBinders foreign_decls
   = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
 
-hsTyClDeclsBinders :: [Located (TyClDecl Name)] -> [Located (InstDecl Name)] -> [Name]
+hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
 hsTyClDeclsBinders tycl_decls inst_decls
-  = [n | d <- instDeclATs inst_decls ++ tycl_decls, L _ n <- hsTyClDeclBinders d]
+  = [n | d <- instDeclATs inst_decls ++ concat tycl_decls
+       , L _ n <- hsTyClDeclBinders d]
 
 hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
 -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 5524e2d388..a756c7f6c9 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -446,7 +446,7 @@ get_local_binders gbl_env (HsGroup {hs_valds  = ValBindsIn _ val_sigs,
                                     hs_fords  = foreign_decls })
   = do  { -- separate out the family instance declarations
           let (tyinst_decls1, tycl_decls_noinsts)
-                           = partition (isFamInstDecl . unLoc) tycl_decls
+                           = partition (isFamInstDecl . unLoc) (concat tycl_decls)
               tyinst_decls = tyinst_decls1 ++ instDeclATs inst_decls
 
           -- process all type/class decls except family instances
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 3766e2148b..2ce2170f9b 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -50,9 +50,10 @@ import DynFlags
 import HscTypes		( HscEnv, hsc_dflags )
 import BasicTypes       ( Boxity(..) )
 import ListSetOps       ( findDupsEq )
-
+import Digraph		( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 
 import Control.Monad
+import Maybes( orElse )
 import Data.Maybe
 \end{code}
 
@@ -146,7 +147,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    -- means we'll only report a declaration as unused if it isn't
    -- mentioned at all.  Ah well.
    traceRn (text "Start rnTyClDecls") ;
-   (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
+   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
 
    -- (F) Rename Value declarations right-hand sides
    traceRn (text "Start rnmono") ;
@@ -218,11 +219,6 @@ inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
 inNewEnv env cont = do e <- env
                        setGblEnv e $ cont e
 
-rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
--- Used for external core
-rnTyClDecls tycl_decls = do  (decls', _fvs) <- rnList rnTyClDecl tycl_decls
-			     return decls'
-
 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
 -- This function could be defined lower down in the module hierarchy, 
 -- but there doesn't seem anywhere very logical to put it.
@@ -681,6 +677,18 @@ and then go over it again to rename the tyvars!
 However, we can also do some scoping checks at the same time.
 
 \begin{code}
+rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars)
+-- Renamed the declarations and do depedency analysis on them
+rnTyClDecls tycl_ds
+  = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
+
+       ; let sccs :: [SCC (LTyClDecl Name)]
+             sccs = depAnalTyClDecls ds_w_fvs
+
+             all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
+
+       ; return (map flattenSCC sccs, all_fvs) }
+
 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
 rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
   = lookupLocatedTopBndrRn name		`thenM` \ name' ->
@@ -832,6 +840,35 @@ to cause programs to break unnecessarily (notably HList).  So if there
 are no data constructors we allow h98_style = True
 
 
+\begin{code}
+depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
+-- See Note [Dependency analysis of type and class decls]
+depAnalTyClDecls ds_w_fvs
+  = stronglyConnCompFromEdgedVertices edges
+  where
+    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 ]
+\end{code}
+
+Note [Dependency analysis of type and class decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to do dependency analysis on type and class declarations
+else we get bad error messages.  Consider
+
+     data T f a = MkT f a
+     data S f a = MkS f (T f a)
+
+This has a kind error, but the error message is better if you
+check T first, (fixing its kind) and *then* S.  If you do kind
+inference together, you might get an error reported in S, which
+is jolly confusing.  See Trac #4875
+
+
 %*********************************************************
 %*							*
 \subsection{Support code for type/data declarations}
@@ -1041,7 +1078,7 @@ badDataCon name
 Get the mapping from constructors to fields for this module.
 It's convenient to do this after the data type decls have been renamed
 \begin{code}
-extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
+extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
 extendRecordFieldEnv tycl_decls inst_decls
   = do	{ tcg_env <- getGblEnv
 	; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
@@ -1059,7 +1096,7 @@ extendRecordFieldEnv tycl_decls inst_decls
     all_data_cons :: [ConDecl RdrName]
     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
     		         , L _ con <- cons ]
-    all_tycl_decls = at_tycl_decls ++ tycl_decls
+    all_tycl_decls = at_tycl_decls ++ concat tycl_decls
     at_tycl_decls = instDeclATs inst_decls  -- Do not forget associated types!
 
     get_con (ConDecl { con_name = con, con_details = RecCon flds })
@@ -1148,9 +1185,9 @@ add gp _ (QuasiQuoteD qq) ds		-- Expand quasiquotes
 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
   | isClassDecl d
   = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
-    addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
+    addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
   | otherwise
-  = addl (gp { hs_tyclds = L l d : ts }) ds
+  = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
 
 -- Signatures: fixity sigs go a different place than all others
 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
@@ -1180,6 +1217,10 @@ add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 add gp l (DocD d) ds
   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 
+add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]]
+add_tycld d []       = [[d]]
+add_tycld d (ds:dss) = (d:ds) : dss
+
 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index f84f3d52d4..1979c8d96b 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -371,7 +371,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        ; let { (local_info,
                 at_tycons_s)   = unzip local_info_tycons
              ; at_idx_tycons   = concat at_tycons_s ++ idx_tycons
-             ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls
+             ; clas_decls      = filter (isClassDecl . unLoc) tycl_decls
              ; implicit_things = concatMap implicitTyThings at_idx_tycons
 	     ; aux_binds       = mkRecSelBinds at_idx_tycons
              }
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 893365e911..773f307053 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -290,7 +290,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
    setEnvs tc_envs $ do {
 
-   rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
+   (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
 
 	-- Dump trace of renaming part
    rnDump (ppr rn_decls) ;
@@ -348,7 +348,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
 mkFakeGroup :: [LTyClDecl a] -> HsGroup a
 mkFakeGroup decls -- Rather clumsy; lots of unused fields
-  = emptyRdrGroup { hs_tyclds = decls }
+  = emptyRdrGroup { hs_tyclds = [decls] }
 \end{code}
 
 
@@ -504,7 +504,7 @@ tcRnHsBootDecls decls
 		-- Family instance declarations are rejected here
 	; traceTc "Tc3" empty
 	; (tcg_env, inst_infos, _deriv_binds) 
-            <- tcInstDecls1 tycl_decls inst_decls deriv_decls
+            <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
 	; setGblEnv tcg_env	$ do {
 
 		-- Typecheck value declarations
@@ -846,7 +846,7 @@ tcTopSrcDecls boot_details
 		-- and import the supporting declarations
         traceTc "Tc3" empty ;
 	(tcg_env, inst_infos, deriv_binds) 
-            <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
+            <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
 	setGblEnv tcg_env	$ do {
 
 	        -- Foreign import declarations next. 
@@ -875,7 +875,7 @@ tcTopSrcDecls boot_details
 
 	     	-- Second pass over class and instance declarations, 
         traceTc "Tc6" empty ;
-	inst_binds <- tcInstDecls2 tycl_decls inst_infos ;
+	inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
 
 		-- Foreign exports
         traceTc "Tc7" empty ;
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 1658e0bee6..a433d697b9 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -60,180 +60,78 @@ import Data.List
 %*									*
 %************************************************************************
 
-Dealing with a group
-~~~~~~~~~~~~~~~~~~~~
-Consider a mutually-recursive group, binding 
-a type constructor T and a class C.
-
-Step 1: 	getInitialKind
-	Construct a KindEnv by binding T and C to a kind variable 
-
-Step 2: 	kcTyClDecl
-	In that environment, do a kind check
-
-Step 3: Zonk the kinds
-
-Step 4: 	buildTyConOrClass
-	Construct an environment binding T to a TyCon and C to a Class.
-	a) Their kinds comes from zonking the relevant kind variable
-	b) Their arity (for synonyms) comes direct from the decl
-	c) The funcional dependencies come from the decl
-	d) The rest comes a knot-tied binding of T and C, returned from Step 4
-	e) The variances of the tycons in the group is calculated from 
-		the knot-tied stuff
-
-Step 5: 	tcTyClDecl1
-	In this environment, walk over the decls, constructing the TyCons and Classes.
-	This uses in a strict way items (a)-(c) above, which is why they must
-	be constructed in Step 4. Feed the results back to Step 4.
-	For this step, pass the is-recursive flag as the wimp-out flag
-	to tcTyClDecl1.
-	
-
-Step 6:		Extend environment
-	We extend the type environment with bindings not only for the TyCons and Classes,
-	but also for their "implicit Ids" like data constructors and class selectors
-
-Step 7:		checkValidTyCl
-	For a recursive group only, check all the decls again, just
-	to check all the side conditions on validity.  We could not
-	do this before because we were in a mutually recursive knot.
-
-Identification of recursive TyCons
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
-@TyThing@s.
-
-Identifying a TyCon as recursive serves two purposes
-
-1.  Avoid infinite types.  Non-recursive newtypes are treated as
-"transparent", like type synonyms, after the type checker.  If we did
-this for all newtypes, we'd get infinite types.  So we figure out for
-each newtype whether it is "recursive", and add a coercion if so.  In
-effect, we are trying to "cut the loops" by identifying a loop-breaker.
-
-2.  Avoid infinite unboxing.  This is nothing to do with newtypes.
-Suppose we have
-        data T = MkT Int T
-        f (MkT x t) = f t
-Well, this function diverges, but we don't want the strictness analyser
-to diverge.  But the strictness analyser will diverge because it looks
-deeper and deeper into the structure of T.   (I believe there are
-examples where the function does something sane, and the strictness
-analyser still diverges, but I can't see one now.)
-
-Now, concerning (1), the FC2 branch currently adds a coercion for ALL
-newtypes.  I did this as an experiment, to try to expose cases in which
-the coercions got in the way of optimisations.  If it turns out that we
-can indeed always use a coercion, then we don't risk recursive types,
-and don't need to figure out what the loop breakers are.
-
-For newtype *families* though, we will always have a coercion, so they
-are always loop breakers!  So you can easily adjust the current
-algorithm by simply treating all newtype families as loop breakers (and
-indeed type families).  I think.
-
 \begin{code}
-tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
+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
 			   [Id])      	     -- Default method ids
-
 -- Fails if there are any errors
 
-tcTyAndClassDecls boot_details allDecls
+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	{       -- Omit instances of type families; they are handled together
-		-- with the *heads* of class instances
-        ; let decls = filter (not . isFamInstDecl . unLoc) allDecls
-
-        	-- First check for cyclic type synonysm or classes
-		-- See notes with checkCycleErrs
-	; checkCycleErrs decls
-	; mod <- getModule
-	; traceTc "tcTyAndCl" (ppr mod)
-	; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) ->
-	  do	{ let {	-- Seperate ordinary synonyms from all other type and
-			-- class declarations and add all associated type
-			-- declarations from type classes.  The latter is
-			-- required so that the temporary environment for the
-			-- knot includes all associated family declarations.
-		      ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc)
-						   decls
-		      ; alg_at_decls           = concatMap addATs alg_decls
-		      }
-			-- Extend the global env with the knot-tied results
-			-- for data types and classes
-			-- 
-			-- We must populate the environment with the loop-tied
-			-- T's right away, because the kind checker may "fault
-			-- in" some type  constructors that recursively
-			-- mention T
-		; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss
-		; tcExtendRecEnv gbl_things $ do
-
-			-- Kind-check the declarations
-		{ (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
-
-		; let {	-- Calculate rec-flag
-		      ; calc_rec  = calcRecFlags boot_details rec_alg_tyclss
-		      ; tc_decl   = addLocM (tcTyClDecl calc_rec) }
-
-			-- Type-check the type synonyms, and extend the envt
-		; syn_tycons <- tcSynDecls kc_syn_decls
-		; tcExtendGlobalEnv syn_tycons $ do
-
-			-- Type-check the data types and classes
-		{ alg_tyclss <- mapM tc_decl kc_alg_decls
-		; return (syn_tycons, concat alg_tyclss)
-	    }}})
-	-- Finished with knot-tying now
-	-- Extend the environment with the finished things
-	; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
-
-	-- Perform the validity check
-	{ traceTc "ready for validity check" empty
-	; mapM_ (addLocM checkValidTyCl) decls
+    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 }
+
+       ; 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 
+	-- 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 alg_tyclss
-	      ; rec_sel_binds   = mkRecSelBinds alg_tyclss
-              ; dm_ids          = mkDefaultMethodIds alg_tyclss }
-	; traceTc "Adding types and classes" $ vcat
-                 [ ppr alg_tyclss 
-		 , text "and" <+> ppr implicit_things ]
+	; let {	implicit_things = concatMap implicitTyThings tyclss
+	      ; rec_sel_binds   = mkRecSelBinds tyclss
+              ; dm_ids          = mkDefaultMethodIds tyclss }
+
   	; env <- tcExtendGlobalEnv implicit_things getGblEnv
-	; return (env, rec_sel_binds, dm_ids) }
-    }
-  where
-    -- Pull associated types out of class declarations, to tie them into the
-    -- knot above.  
-    -- NB: We put them in the same place in the list as `tcTyClDecl' will
-    --	   eventually put the matching `TyThing's.  That's crucial; otherwise,
-    --	   the two argument lists of `mkGlobalThings' don't match up.
-    addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
-    addATs decl				         = [decl]
-
-mkGlobalThings :: [LTyClDecl Name] 	-- The decls
-	       -> [TyThing]		-- Knot-tied, in 1-1 correspondence with the decls
-	       -> [(Name,TyThing)]
--- Driven by the Decls, and treating the TyThings lazily
--- make a TypeEnv for the new things
-mkGlobalThings decls things
-  = map mk_thing (decls `zipLazy` things)
+	; return (env, rec_sel_binds, dm_ids) } }
+                    
+zipRecTyClss :: [[LTyClDecl 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/AClass,
+-- 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 ]
   where
-    mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
-	 = (name, AClass cl)
-    mk_thing (L _ decl, ~(ATyCon tc))
-         = (tcdName decl, ATyCon tc)
+    rec_type_env :: TypeEnv
+    rec_type_env = mkTypeEnv rec_things
+
+    get :: TyClDecl Name -> (Name, TyThing)
+    get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl)
+      where
+        Just (AClass cl) = lookupTypeEnv rec_type_env name
+    get decl = (name, ATyCon tc)
+      where
+        name = tcdName decl
+        Just (ATyCon tc) = lookupTypeEnv rec_type_env name
 \end{code}
 
 
@@ -425,6 +323,25 @@ kcIdxTyPats decl thing_inside
 %*									*
 %************************************************************************
 
+Note [Kind checking for type and class decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Kind checking is done thus:
+
+   1. Make up a kind variable for each parameter of the *data* type, 
+      and class, decls, and extend the kind environment (which is in
+      the TcLclEnv)
+
+   2. Dependency-analyse the type *synonyms* (which must be non-recursive),
+      and kind-check them in dependency order.  Extend the kind envt.
+
+   3. Kind check the data type and class decls
+
+Synonyms are treated differently to data type and classes,
+because a type synonym can be an unboxed type
+	type Foo = Int#
+and a kind variable can't unify with UnboxedTypeKind
+So we infer their kinds in dependency order
+
 We need to kind check all types in the mutually recursive group
 before we know the kind of the type variables.  For example:
 
@@ -459,48 +376,52 @@ instances of families altogether in the following.  However, we need to
 include the kinds of associated families into the construction of the
 initial kind environment.  (This is handled by `allDecls').
 
+
 \begin{code}
-kcTyClDecls :: [LTyClDecl Name] -> [Located (TyClDecl Name)]
-            -> TcM ([LTyClDecl Name], [Located (TyClDecl Name)])
-kcTyClDecls syn_decls alg_decls
-  = do	{ 	-- First extend the kind env with each data type, class, and
-		-- indexed type, mapping them to a type variable
-          let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls]
-	; alg_kinds <- mapM getInitialKind initialKindDecls
-	; tcExtendKindEnv alg_kinds $ do
-
-		-- Now kind-check the type synonyms, in dependency order
-		-- We do these differently to data type and classes,
-		-- because a type synonym can be an unboxed type
-		--	type Foo = Int#
-		-- and a kind variable can't unify with UnboxedTypeKind
-		-- So we infer their kinds in dependency order
-	{ (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
-	; tcExtendKindEnv syn_kinds $  do
-
-		-- Now kind-check the data type, class, and kind signatures,
-		-- returning kind-annotated decls; we don't kind-check
-		-- instances of indexed types yet, but leave this to
-		-- `tcInstDecls1'
-	{ kc_alg_decls <- mapM (wrapLocM kcTyClDecl)
-			    (filter (not . isFamInstDecl . unLoc) alg_decls)
-
-	; return (kc_syn_decls, kc_alg_decls) }}}
+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))
+
+        	-- First check for cyclic classes
+	; checkClassCycleErrs alg_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)
+        ; 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) } } }
+
+flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name]
+flattenATs decls = concatMap flatten decls
   where
-    -- get all declarations relevant for determining the initial kind
-    -- environment
-    allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at 
-						      | L _ at <- ats
-						      , isFamilyDecl at]
-    allDecls decl | isFamInstDecl decl = []
-		  | otherwise	       = [decl]
+    flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
+    flatten decl				  = [decl]
 
-------------------------------------------------------------------------
-getInitialKind :: TyClDecl Name -> TcM (Name, TcKind)
+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 decl
+getInitialKind (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) }
@@ -518,13 +439,13 @@ getInitialKind decl
 ----------------
 kcSynDecls :: [SCC (LTyClDecl Name)] 
 	   -> TcM ([LTyClDecl Name], 	-- Kind-annotated decls
-		   [(Name,TcKind)])	-- Kind bindings
+		   TcLclEnv)	-- Kind bindings
 kcSynDecls []
-  = return ([], [])
+  = do { tcl_env <- getLclEnv; return ([], tcl_env) }
 kcSynDecls (group : groups)
-  = do	{ (decl,  nk)  <- kcSynDecl group
-	; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
-	; return (decl:decls, nk:nks) }
+  = do	{ (decl,  nk)      <- kcSynDecl group
+	; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups)
+	; return (decl:decls, tcl_env) }
 			
 ----------------
 kcSynDecl :: SCC (LTyClDecl Name) 
@@ -675,31 +596,11 @@ kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
 %************************************************************************
 
 \begin{code}
-tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing]
-tcSynDecls [] = return []
-tcSynDecls (decl : decls) 
-  = do { syn_tc <- addLocM tcSynDecl decl
-       ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
-       ; return (syn_tc : syn_tcs) }
+tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
 
-  -- "type"
-tcSynDecl :: TyClDecl Name -> TcM TyThing
-tcSynDecl
-  (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
-  = 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
-    ; return (ATyCon tycon) 
-    }
-tcSynDecl d = pprPanic "tcSynDecl" (ppr d)
-
---------------------
-tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
-
-tcTyClDecl calc_isrec decl
-  = tcAddDeclCtxt decl (tcTyClDecl1 NoParentTyCon calc_isrec decl)
+tcTyClDecl calc_isrec (L loc decl)
+  = setSrcSpan loc $ tcAddDeclCtxt decl $
+    tcTyClDecl1 NoParentTyCon calc_isrec decl
 
   -- "type family" declarations
 tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
@@ -738,12 +639,24 @@ tcTyClDecl1 parent _calc_isrec
   ; return [ATyCon tycon]
   }
 
+  -- "type"
+tcTyClDecl1 _parent _calc_isrec
+  (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
+    ; return [ATyCon tycon] }
+
   -- "newtype" and "data"
   -- NB: not used for newtype/data instances (whether associated or not)
-tcTyClDecl1 parent calc_isrec
+tcTyClDecl1 _parent calc_isrec
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
 	   tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
-  = tcTyVarBndrs tvs	$ \ tvs' -> do 
+  = ASSERT( isNoParent _parent )
+    tcTyVarBndrs tvs	$ \ tvs' -> do 
   { extra_tvs <- tcDataKindSig mb_ksig
   ; let final_tvs = tvs' ++ extra_tvs
   ; stupid_theta <- tcHsKindedContext ctxt
@@ -790,7 +703,7 @@ tcTyClDecl1 parent calc_isrec
                                mkNewTyConRhs tc_name tycon (head data_cons)
 	; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
 	    (want_generic && canDoGenerics data_cons) (not h98_syntax) 
-            parent Nothing
+            NoParentTyCon Nothing
 	})
   ; return [ATyCon tycon]
   }
@@ -802,7 +715,8 @@ tcTyClDecl1 _parent calc_isrec
   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
 	      tcdCtxt = ctxt, tcdMeths = meths,
 	      tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
-  = tcTyVarBndrs tvs		$ \ tvs' -> do 
+  = ASSERT( isNoParent _parent )
+    tcTyVarBndrs tvs		$ \ tvs' -> do 
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mapM (addLocM tc_fundep) fundeps
   ; sig_stuff <- tcClassSigs class_name sigs meths
@@ -1038,8 +952,8 @@ Validity checking is done once the mutually-recursive knot has been
 tied, so we can look at things freely.
 
 \begin{code}
-checkCycleErrs :: [LTyClDecl Name] -> TcM ()
-checkCycleErrs tyclss
+checkClassCycleErrs :: [LTyClDecl Name] -> TcM ()
+checkClassCycleErrs tyclss
   | null cls_cycles
   = return ()
   | otherwise
@@ -1058,8 +972,9 @@ checkValidTyCl decl
 	; traceTc "Validity of" (ppr thing)	
 	; case thing of
 	    ATyCon tc -> checkValidTyCon tc
-	    AClass cl -> checkValidClass cl 
-            _ -> panic "checkValidTyCl"
+	    AClass cl -> do { checkValidClass cl 
+                            ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
+            _         -> panic "checkValidTyCl"
 	; traceTc "Done validity of" (ppr thing)	
 	}
 
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 2366731632..a9ea11aefa 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -132,6 +132,42 @@ calcClassCycles decls
 %*                                                                      *
 %************************************************************************
 
+Identification of recursive TyCons
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
+@TyThing@s.
+
+Identifying a TyCon as recursive serves two purposes
+
+1.  Avoid infinite types.  Non-recursive newtypes are treated as
+"transparent", like type synonyms, after the type checker.  If we did
+this for all newtypes, we'd get infinite types.  So we figure out for
+each newtype whether it is "recursive", and add a coercion if so.  In
+effect, we are trying to "cut the loops" by identifying a loop-breaker.
+
+2.  Avoid infinite unboxing.  This is nothing to do with newtypes.
+Suppose we have
+        data T = MkT Int T
+        f (MkT x t) = f t
+Well, this function diverges, but we don't want the strictness analyser
+to diverge.  But the strictness analyser will diverge because it looks
+deeper and deeper into the structure of T.   (I believe there are
+examples where the function does something sane, and the strictness
+analyser still diverges, but I can't see one now.)
+
+Now, concerning (1), the FC2 branch currently adds a coercion for ALL
+newtypes.  I did this as an experiment, to try to expose cases in which
+the coercions got in the way of optimisations.  If it turns out that we
+can indeed always use a coercion, then we don't risk recursive types,
+and don't need to figure out what the loop breakers are.
+
+For newtype *families* though, we will always have a coercion, so they
+are always loop breakers!  So you can easily adjust the current
+algorithm by simply treating all newtype families as loop breakers (and
+indeed type families).  I think.
+
+
+
 For newtypes, we label some as "recursive" such that
 
     INVARIANT: there is no cycle of non-recursive newtypes
@@ -160,6 +196,7 @@ T's source module is compiled.  We don't want T's recursiveness to change.
 The "recursive" flag for algebraic data types is irrelevant (never consulted)
 for types with more than one constructor.
 
+
 An algebraic data type M.T is "recursive" iff
         it has just one constructor, and
         (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)