Do SCC on instance declarations (fixes Trac #5715)

The trouble here is that given

    {-# LANGUAGE DataKinds, TypeFamilies #-}
    data instance Foo a = Bar (Bar a)

we want to get a sensible message that we can't use the promoted 'Bar'
constructor until after its definition; it's a staging error.  Bud the
staging mechanism that we use for vanilla data declarations don't work
here.

Solution is to perform strongly-connected component analysis on the
instance declarations. But that in turn means that we need to track
free-variable information on more HsSyn declarations, which is why
so many files are touched.  All the changes are boiler-platey except
the ones in TcInstDcls.

16 files changed, 193 insertions, 103 deletions

diff --git a/compiler/basicTypes/NameEnv.lhs b/compiler/basicTypes/NameEnv.lhs
index 8a59e7d220..5b77014b22 100644
--- a/compiler/basicTypes/NameEnv.lhs
+++ b/compiler/basicTypes/NameEnv.lhs
@@ -24,11 +24,15 @@ module NameEnv (
 	foldNameEnv, filterNameEnv,
 	plusNameEnv, plusNameEnv_C, alterNameEnv,
 	lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
-	elemNameEnv, mapNameEnv
+	elemNameEnv, mapNameEnv,
+
+        -- ** Dependency analysis
+        depAnal
     ) where
 
 #include "HsVersions.h"
 
+import Digraph
 import Name
 import Unique
 import UniqFM
@@ -42,6 +46,32 @@ import Maybes
 %************************************************************************
 
 \begin{code}
+depAnal :: (node -> [Name])      -- Defs 
+        -> (node -> [Name])      -- Uses
+        -> [node]
+        -> [SCC node]
+-- Peform dependency analysis on a group of definitions,
+-- where each definition may define more than one Name
+--
+-- The get_defs and get_uses functions are called only once per node
+depAnal get_defs get_uses nodes
+  = stronglyConnCompFromEdgedVertices (map mk_node keyed_nodes)
+  where
+    keyed_nodes = nodes `zip` [(1::Int)..]
+    mk_node (node, key) = (node, key, mapCatMaybes (lookupNameEnv key_map) (get_uses node))
+
+    key_map :: NameEnv Int   -- Maps a Name to the key of the decl that defines it
+    key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]                        
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Name environment}
+%*									*
+%************************************************************************
+
+\begin{code}
 type NameEnv a = UniqFM a	-- Domain is Name
 
 emptyNameEnv   	   :: NameEnv a
diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index bb7c4c363e..1d92234e8b 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -78,7 +78,7 @@ module SrcLoc (
 	-- ** Combining and comparing Located values
 	eqLocated, cmpLocated, combineLocs, addCLoc,
         leftmost_smallest, leftmost_largest, rightmost, 
-        spans, isSubspanOf
+        spans, isSubspanOf, sortLocated
     ) where
 
 #include "Typeable.h"
@@ -181,6 +181,11 @@ instance Ord SrcLoc where
 instance Ord RealSrcLoc where
   compare = cmpRealSrcLoc
 
+sortLocated :: [Located a] -> [Located a]
+sortLocated things = sortLe le things
+  where
+    le (L l1 _) (L l2 _) = l1 <= l2
+
 cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
 cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
 cmpSrcLoc (UnhelpfulLoc _)  (RealSrcLoc _)    = GT
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 7a15120567..5c847c89e9 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -165,8 +165,7 @@ cvtDec (TySynD tc tvs rhs)
 	; rhs' <- cvtType rhs
 	; returnL $ TyClD (TyDecl { tcdLName = tc' 
                                   , tcdTyVars = tvs' 
-                                  , tcdTyDefn = TySynonym rhs'
-                                  , tcdFVs = placeHolderNames }) }
+                                  , tcdTyDefn = TySynonym rhs' placeHolderNames }) }
 
 cvtDec (DataD ctxt tc tvs constrs derivs)
   = do	{ (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
@@ -175,9 +174,10 @@ cvtDec (DataD ctxt tc tvs constrs derivs)
        ; let defn = TyData { td_ND = DataType, td_cType = Nothing
                            , td_ctxt = ctxt'
                            , td_kindSig = Nothing
-                           , td_cons = cons', td_derivs = derivs' } 
+                           , td_cons = cons', td_derivs = derivs'
+                           , td_fvs = placeHolderNames } 
 	; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
-                                  , tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
+                                  , tcdTyDefn = defn }) }
 
 cvtDec (NewtypeD ctxt tc tvs constr derivs)
   = do	{ (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
@@ -186,9 +186,10 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
         ; let defn = TyData { td_ND = NewType, td_cType = Nothing
                             , td_ctxt = ctxt'
                             , td_kindSig = Nothing
-                            , td_cons = [con'], td_derivs = derivs' } 
+                            , td_cons = [con'], td_derivs = derivs'
+                            , td_fvs = placeHolderNames } 
 	; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs'
-                                  , tcdTyDefn = defn, tcdFVs = placeHolderNames }) }
+                                  , tcdTyDefn = defn }) }
 
 cvtDec (ClassD ctxt cl tvs fds decs)
   = do	{ (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index d573be52d4..e23006279f 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -436,9 +436,8 @@ data TyClDecl name
   | -- | @type/data declaration
     TyDecl { tcdLName  :: Located name            -- ^ Type constructor
            , tcdTyVars :: [LHsTyVarBndr name]
-           , tcdTyDefn :: HsTyDefn name 
-           , tcdFVs    :: NameSet }               -- ^ Free tycons of the decl
-                                                  -- (Used for cycle detection)
+           , tcdTyDefn :: HsTyDefn name
+           , tcdFVs    :: NameSet }
 
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
@@ -450,7 +449,8 @@ data TyClDecl name
                                                         --   only 'TyFamily'
                 tcdATDefs  :: [LFamInstDecl name],      -- ^ Associated type defaults; ie
                                                         --   only 'TySynonym'
-                tcdDocs    :: [LDocDecl]                -- ^ Haddock docs
+                tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
+                tcdFVs     :: NameSet
     }
   deriving (Data, Typeable)
 
@@ -458,7 +458,7 @@ data TyClDecl name
 data HsTyDefn name   -- The payload of a type synonym or data type defn
                      -- Used *both* for vanialla type/data declarations,
                      --       *and* for type/data family instances
-  = TySynonym { td_synRhs :: LHsType name }         -- ^ Synonym expansion
+  = TySynonym { td_synRhs :: LHsType name }   -- ^ Synonym expansion
 
   | -- | Declares a data type or newtype, giving its construcors
     -- @
@@ -645,7 +645,7 @@ pp_ty_defn :: OutputableBndr name
            -> HsTyDefn name
            -> SDoc 
 
-pp_ty_defn pp_hdr (TySynonym rhs)
+pp_ty_defn pp_hdr (TySynonym { td_synRhs = rhs })
   = hang (ptext (sLit "type") <+> pp_hdr [] <+> equals)
        4 (ppr rhs)
 
@@ -776,7 +776,7 @@ pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
   where
     ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2]
-    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc (unLoc con) : map ppr tys)
+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc (unLoc con) : map (pprParendHsType . unLoc) tys)
     ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
 
 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
@@ -820,11 +820,12 @@ data InstDecl name  -- Both class and family instances
                                        -- figures out the quantified type variables for us.
       , cid_binds :: LHsBinds name
       , cid_sigs  :: [LSig name]                -- User-supplied pragmatic info
-      , cid_fam_insts :: [LFamInstDecl name] }  -- Family instances for associated types
+      , cid_fam_insts :: [LFamInstDecl name]    -- Family instances for associated types
+      , lid_fvs       :: NameSet }
 
   | FamInstD              -- type/data family instance
-      (FamInstDecl name)
-
+      { lid_inst :: FamInstDecl name
+      , lid_fvs  :: NameSet }
   deriving (Data, Typeable)
 \end{code}
 
@@ -855,7 +856,8 @@ instance (OutputableBndr name) => Outputable (FamInstDecl name) where
     = pp_ty_defn (pp_fam_inst_head tycon pats) defn
 
 instance (OutputableBndr name) => Outputable (InstDecl name) where
-    ppr (ClsInstD inst_ty binds sigs ats)
+    ppr (ClsInstD { cid_poly_ty = inst_ty, cid_binds = binds
+                  , cid_sigs = sigs, cid_fam_insts = ats })
       | null sigs && null ats && isEmptyBag binds  -- No "where" part
       = top_matter
 
@@ -866,7 +868,7 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where
       where
         top_matter = ptext (sLit "instance") <+> ppr inst_ty
 
-    ppr (FamInstD decl) = ppr decl
+    ppr (FamInstD { lid_inst = decl }) = ppr decl
 
 -- Extract the declarations of associated types from an instance
 
@@ -874,8 +876,8 @@ instDeclFamInsts :: [LInstDecl name] -> [FamInstDecl name]
 instDeclFamInsts inst_decls 
   = concatMap do_one inst_decls
   where
-    do_one (L _ (ClsInstD _ _ _ fam_insts)) = map unLoc fam_insts
-    do_one (L _ (FamInstD fam_inst))        = [fam_inst]
+    do_one (L _ (ClsInstD { cid_fam_insts = fam_insts })) = map unLoc fam_insts
+    do_one (L _ (FamInstD { lid_inst = fam_inst }))       = [fam_inst]
 \end{code}
 
 %************************************************************************
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 293cc4a9a2..9a6679a68e 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -578,7 +578,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
   = maybeParen ctxt_prec pREC_FUN $
     sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
 
-ppr_mono_ty _    (HsBangTy b ty)     = ppr b <> ppr ty
+ppr_mono_ty _    (HsBangTy b ty)     = ppr b <> ppr_mono_lty pREC_CON ty
 ppr_mono_ty _    (HsQuasiQuoteTy qq) = ppr qq
 ppr_mono_ty _    (HsRecTy flds)      = pprConDeclFields flds
 ppr_mono_ty _    (HsTyVar name)      = ppr name
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 688d1ac5f7..cf54de467d 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -653,7 +653,7 @@ hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn })
 -------------------
 hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
 hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis
-hsInstDeclBinders (FamInstD fi) = hsFamInstBinders fi
+hsInstDeclBinders (FamInstD { lid_inst = fi }) = hsFamInstBinders fi
 
 -------------------
 hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name]
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index ea3739a88e..79eb8f54cb 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -133,9 +133,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
                (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
     class_info _ = (0,0)
 
-    inst_info (FamInstD d) = case countATDecl d of
-                                  (tyd, dtd) -> (0,0,0,tyd,dtd)
-    inst_info (ClsInstD _ inst_meths inst_sigs ats)
+    inst_info (FamInstD { lid_inst = d }) 
+        = case countATDecl d of
+           (tyd, dtd) -> (0,0,0,tyd,dtd)
+    inst_info (ClsInstD { cid_binds = inst_meths, cid_sigs = inst_sigs, cid_fam_insts = ats })
         = case count_sigs (map unLoc inst_sigs) of
             (_,_,ss,is,_) ->
               case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index dd842849e7..34f9de5579 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -651,20 +651,22 @@ ty_decl :: { LTyClDecl RdrName }
 inst_decl :: { LInstDecl RdrName }
         : 'instance' inst_type where_inst
                  { let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3)
-                   in L (comb3 $1 $2 $3) (ClsInstD $2 binds sigs ats) }
+                   in L (comb3 $1 $2 $3) (ClsInstD { cid_poly_ty = $2, cid_binds = binds
+                                                   , cid_sigs = sigs, cid_fam_insts = ats
+                                                   , lid_fvs = placeHolderNames }) }
 
            -- type instance declarations
         | 'type' 'instance' type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
                 {% do { L loc d <- mkFamInstSynonym (comb2 $1 $5) $3 $5
-                      ; return (L loc (FamInstD d)) } }
+                      ; return (L loc (FamInstD { lid_inst = d, lid_fvs = placeHolderNames })) } }
 
           -- data/newtype instance declaration
         | data_or_newtype 'instance' tycl_hdr constrs deriving
                 {% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3
                                       Nothing (reverse (unLoc $4)) (unLoc $5)
-                      ; return (L loc (FamInstD d)) } }
+                      ; return (L loc (FamInstD { lid_inst = d, lid_fvs = placeHolderNames })) } }
 
           -- GADT instance declaration
         | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
@@ -672,7 +674,7 @@ inst_decl :: { LInstDecl RdrName }
                  deriving
                 {% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3
                                             (unLoc $4) (unLoc $5) (unLoc $6)
-                      ; return (L loc (FamInstD d)) } }
+                      ; return (L loc (FamInstD { lid_inst = d, lid_fvs = placeHolderNames })) } }
         
 -- Associated type family declarations
 --
@@ -700,7 +702,7 @@ at_decl_cls :: { LHsDecl RdrName }
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
                 {% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4
-                      ; return (L loc (InstD (FamInstD fid))) } }
+                      ; return (L loc (InstD (FamInstD { lid_inst = fid, lid_fvs = placeHolderNames }))) } }
 
 -- Associated type instances
 --
@@ -791,7 +793,7 @@ where_cls :: { Located (OrdList (LHsDecl RdrName)) }    -- Reversed
 -- Declarations in instance bodies
 --
 decl_inst  :: { Located (OrdList (LHsDecl RdrName)) }
-decl_inst  : at_decl_inst               { LL (unitOL (L1 (InstD (FamInstD (unLoc $1))))) }
+decl_inst  : at_decl_inst               { LL (unitOL (L1 (InstD (FamInstD { lid_inst = unLoc $1, lid_fvs = placeHolderNames })))) }
            | decl                       { $1 }
 
 decls_inst :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 099acd7388..5050599945 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -115,7 +115,8 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
        ; tyvars <- checkTyVars tycl_hdr tparams      -- Only type vars allowed
        ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
                                     tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
-                                    tcdATs   = ats, tcdATDefs = at_defs, tcdDocs  = docs })) }
+                                    tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs,
+                                    tcdFVs = placeHolderNames })) }
 
 mkTyData :: SrcSpan
          -> NewOrData
@@ -130,7 +131,8 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
        ; tyvars <- checkTyVars tycl_hdr tparams
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars,
-                                 tcdTyDefn = defn, tcdFVs = placeHolderNames })) }
+                                 tcdTyDefn = defn,
+                                 tcdFVs = placeHolderNames })) }
 
 mkFamInstData :: SrcSpan
          -> NewOrData
@@ -170,7 +172,8 @@ mkTySynonym loc lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; tyvars <- checkTyVars lhs tparams
        ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars,
-                                 tcdTyDefn = TySynonym rhs, tcdFVs = placeHolderNames })) }
+                                 tcdTyDefn = TySynonym { td_synRhs = rhs },
+                                 tcdFVs = placeHolderNames })) }
 
 mkFamInstSynonym :: SrcSpan
             -> LHsType RdrName  -- LHS
@@ -179,7 +182,7 @@ mkFamInstSynonym :: SrcSpan
 mkFamInstSynonym loc lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
-                                    , fid_defn = TySynonym rhs })) }
+                                    , fid_defn = TySynonym { td_synRhs = rhs }})) }
 
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
@@ -262,7 +265,7 @@ cvBindsAndSigs  fb = go (fromOL fb)
                                  (bs, ss, ts, fis, docs) = go ds'
     go (L l (TyClD t@(TyFamily {})) : ds) = (bs, ss, L l t : ts, fis, docs)
                            where (bs, ss, ts, fis, docs) = go ds
-    go (L l (InstD (FamInstD fi)) : ds) = (bs, ss, ts, L l fi : fis, docs)
+    go (L l (InstD (FamInstD { lid_inst = fi })) : ds) = (bs, ss, ts, L l fi : fis, docs)
                            where (bs, ss, ts, fis, docs) = go ds
     go (L l (DocD d) : ds) =  (bs, ss, ts, fis, (L l d) : docs)
                            where (bs, ss, ts, fis, docs) = go ds
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 6a7bfbea9a..a8f882a48d 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -46,7 +46,7 @@ import RdrName          ( RdrName, rdrNameOcc )
 import SrcLoc
 import ListSetOps	( findDupsEq )
 import BasicTypes	( RecFlag(..) )
-import Digraph		( SCC(..), stronglyConnCompFromEdgedVertices )
+import Digraph		( SCC(..) )
 import Bag
 import Outputable
 import FastString
@@ -506,17 +506,9 @@ depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
 depAnalBinds binds_w_dus
   = (map get_binds sccs, map get_du sccs)
   where
-    sccs = stronglyConnCompFromEdgedVertices edges
-
-    keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..]
-
-    edges = [ (node, key, [key | n <- nameSetToList uses,
-			         Just key <- [lookupNameEnv key_map n] ])
-	    | (node@(_,_,uses), key) <- keyd_nodes ]
-
-    key_map :: NameEnv Int	-- Which binding it comes from
-    key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes
-				     , bndr <- bndrs ]
+    sccs = depAnal (\(_, defs, _) -> defs)
+                   (\(_, _, uses) -> nameSetToList uses)
+                   (bagToList binds_w_dus)
 
     get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
     get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
@@ -527,7 +519,6 @@ depAnalBinds binds_w_dus
 	  defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
 	  uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus]
 
-
 ---------------------
 -- Bind the top-level forall'd type variables in the sigs.
 -- E.g 	f :: a -> a
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 8741b9ab84..75f7ea2245 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -530,7 +530,7 @@ getLocalNonValBinders fixity_env
              ; return (AvailTC main_name names) }
 
     new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
-    new_assoc (L _ (FamInstD d)) 
+    new_assoc (L _ (FamInstD { lid_inst = d })) 
       = do { avail <- new_ti Nothing d
            ; return [avail] }
     new_assoc (L _ (ClsInstD { cid_poly_ty = inst_ty, cid_fam_insts = ats }))
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 1bbd957b3a..57a2ad8199 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -422,9 +422,9 @@ patchCCallTarget packageId callTarget
 
 \begin{code}
 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
-rnSrcInstDecl (FamInstD fi) 
+rnSrcInstDecl (FamInstD { lid_inst = fi }) 
   = do { (fi', fvs) <- rnFamInstDecl Nothing fi
-       ; return (FamInstD fi', fvs) }
+       ; return (FamInstD { lid_inst = fi', lid_fvs = fvs }, fvs) }
 
 rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
                         , cid_sigs = uprags, cid_fam_insts = ats })
@@ -432,7 +432,8 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
   = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
        ; case splitLHsInstDeclTy_maybe inst_ty' of {
            Nothing -> return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
-                                       , cid_sigs = [], cid_fam_insts = [] }, inst_fvs) ;
+                                       , cid_sigs = [], cid_fam_insts = []
+                                       , lid_fvs = inst_fvs }, inst_fvs) ;
            Just (inst_tyvars, _, L _ cls,_) ->
 
     do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
@@ -466,11 +467,13 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
 	     <- renameSigs (InstDeclCtxt cls) spec_inst_prags
 
        ; let uprags' = spec_inst_prags' ++ other_sigs'
-       ; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds'
-                          , cid_sigs = uprags', cid_fam_insts = ats' },
-	         meth_fvs `plusFV` more_fvs
+             all_fvs = meth_fvs `plusFV` more_fvs
                           `plusFV` spec_inst_fvs
-		      	  `plusFV` inst_fvs) } } }
+		      	  `plusFV` inst_fvs
+       ; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds'
+                          , cid_sigs = uprags', cid_fam_insts = ats'
+                          , lid_fvs = all_fvs },
+	         all_fvs) } } }
              -- We return the renamed associated data type declarations so
              -- that they can be entered into the list of type declarations
              -- for the binding group, but we also keep a copy in the instance.
@@ -908,11 +911,12 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
   -- Haddock docs 
 	; docs' <- mapM (wrapLocM rnDocDecl) docs
 
+        ; let all_fvs = meth_fvs `plusFV` stuff_fvs
 	; return (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) }
+                              tcdDocs = docs', tcdFVs = all_fvs },
+	     	  all_fvs ) }
   where
     cls_doc  = ClassDeclCtx lcls
 
@@ -939,11 +943,12 @@ rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
            -- No need to check for duplicate constructor decls
 	   -- since that is done by RnNames.extendGlobalRdrEnvRn
 
+        ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
+                        con_fvs `plusFV` sig_fvs
 	; return ( TyData { td_ND = new_or_data, td_cType = cType
                           , td_ctxt = context', td_kindSig = sig'
-			  , td_cons = condecls', td_derivs = derivs'} 
-                 , fvs1 `plusFV` fvs3 `plusFV`
-	     	   con_fvs `plusFV` sig_fvs )
+			  , td_cons = condecls', td_derivs = derivs' }
+                 , all_fvs )
         }
   where
     h98_style = case condecls of	 -- Note [Stupid theta]
@@ -959,7 +964,8 @@ rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType
 -- "type" and "type instance" declarations
 rnTyDefn tycon (TySynonym { td_synRhs = ty })
   = do { (ty', rhs_fvs) <- rnLHsType syn_doc ty
-       ; return (TySynonym { td_synRhs = ty' }, rhs_fvs) }
+       ; return ( TySynonym { td_synRhs = ty' }
+                , rhs_fvs) }
   where
     syn_doc = TySynCtx tycon
 
@@ -999,9 +1005,9 @@ depAnalTyClDecls ds_w_fvs
       (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)
+                  , tcdATs = ats } 
+          -> do L _ assoc_decl <- ats
+                return (tcdName assoc_decl, cls_name)
         TyDecl { tcdLName = L _ data_name
                , tcdTyDefn = TyData { td_cons = cons } } 
           -> do L _ dc <- cons
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index ac498ba7d2..b864a13872 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -477,7 +477,7 @@ deriveTyDecl _ = return []
 
 ------------------------------------------------------------------
 deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
-deriveInstDecl (L _ (FamInstD fam_inst))
+deriveInstDecl (L _ (FamInstD { lid_inst = fam_inst }))
   = deriveFamInst fam_inst
 deriveInstDecl (L _ (ClsInstD { cid_fam_insts = fam_insts }))
   = concatMapM (deriveFamInst . unLoc) fam_insts
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index b7c953d2f7..c577f56830 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -56,8 +56,10 @@ import Id
 import MkId
 import Name
 import NameSet
+import NameEnv
 import Outputable
 import SrcLoc
+import Digraph( SCC(..) )
 import Util
 
 import Control.Monad
@@ -370,25 +372,16 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
             -- (they recover, so that we get more than one error each
             -- round)
 
-            -- (1) Do class and family instance declarations
-       ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls
+            -- Do class and family instance declarations
+       ; (gbl_env, local_infos) <- tcLocalInstDecls (calcInstDeclCycles inst_decls)
+       ; setGblEnv gbl_env $
 
-       ; let { (local_infos_s, fam_insts_s) = unzip inst_decl_stuff
-             ; all_fam_insts = concat fam_insts_s
-             ; local_infos   = concat local_infos_s }
-
-            -- (2) Next, construct the instance environment so far, consisting of
-            --   (a) local instance decls
-            --   (b) local family instance decls
-       ; addClsInsts local_infos     $
-         addFamInsts all_fam_insts   $ do
-
-            -- (3) Compute instances from "deriving" clauses;
+    do {    -- Compute instances from "deriving" clauses;
             -- This stuff computes a context for the derived instance
             -- decl, so it needs to know about all the instances possible
             -- NB: class instance declarations can contain derivings as
             --     part of associated data type declarations
-       { failIfErrsM    -- If the addInsts stuff gave any errors, don't
+         failIfErrsM    -- If the addInsts stuff gave any errors, don't
                         -- try the deriving stuff, because that may give
                         -- more errors still
 
@@ -417,6 +410,20 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
                               ++ " Haskell! Can only derive them"
 
+tcLocalInstDecls :: [SCC (LInstDecl Name)] -> TcM (TcGblEnv, [InstInfo Name])
+tcLocalInstDecls [] 
+ = do { gbl_env <- getGblEnv
+      ; return (gbl_env, []) }
+tcLocalInstDecls (AcyclicSCC inst_decl : sccs)
+ = do { (inst_infos, fam_insts) <- recoverM (return ([], [])) $
+                                   tcLocalInstDecl inst_decl
+      ; (gbl_env, more_infos) <- addClsInsts inst_infos  $
+                                 addFamInsts fam_insts   $ 
+                                 tcLocalInstDecls sccs
+      ; return (gbl_env, inst_infos ++ more_infos) }
+tcLocalInstDecls (CyclicSCC inst_decls : _)
+  = do { cyclicDeclErr inst_decls; failM }
+
 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
 addClsInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
@@ -436,21 +443,72 @@ addFamInsts fam_insts thing_inside
     things = map ATyCon tycons ++ map ACoAxiom axioms 
 \end{code}
 
+Note [Instance declaration cycles]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With -XDataKinds we can get this
+   data instance Foo [a] = MkFoo (MkFoo a)
+where the constructor MkFoo is used in a type before it is
+defined.  Here is a more complicated situation, involving an 
+associated type and mutual recursion
+
+   data instance T [a] = MkT (MkS a)
+
+   instance C [a] where
+     data S [a] = MkS (MkT a)
+
+When type checking ordinary data type decls we detect this staging
+problem in the kind-inference phase, but there *is* no kind inference
+phase here.
+
+So intead we extract the strongly connected components and look for
+cycles.
+
+
+\begin{code}
+calcInstDeclCycles :: [LInstDecl Name] -> [SCC (LInstDecl Name)]
+-- see Note [Instance declaration cycles]
+calcInstDeclCycles decls
+  = depAnal get_defs get_uses decls
+  where
+    -- get_defs extracts the *constructor* bindings of the declaration
+    get_defs :: LInstDecl Name -> [Name]
+    get_defs (L _ (FamInstD { lid_inst = fid }))       = get_fi_defs fid
+    get_defs (L _ (ClsInstD { cid_fam_insts = fids })) = concatMap (get_fi_defs . unLoc) fids
+
+    get_fi_defs :: FamInstDecl Name -> [Name]
+    get_fi_defs (FamInstDecl { fid_defn = TyData { td_cons = cons } }) 
+      = map (unLoc . con_name . unLoc) cons
+    get_fi_defs (FamInstDecl {}) = []
+
+    -- get_uses extracts the *tycon or constructor* uses of the declaration
+    get_uses :: LInstDecl Name -> [Name]
+    get_uses decl = nameSetToList (lid_fvs (unLoc decl))
+
+cyclicDeclErr :: Outputable d => [Located d] -> TcRn ()
+cyclicDeclErr inst_decls
+  = setSrcSpan (getLoc (head sorted_decls)) $
+    addErr (sep [ptext (sLit "Cycle in type declarations: data constructor used (in a type) before it is defined"),
+		 nest 2 (vcat (map ppr_decl sorted_decls))])
+  where
+    sorted_decls = sortLocated inst_decls
+    ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
+\end{code}
+
 \begin{code}
-tcLocalInstDecl1 :: LInstDecl Name
-                 -> TcM ([InstInfo Name], [FamInst])
+tcLocalInstDecl :: LInstDecl Name
+                -> TcM ([InstInfo Name], [FamInst])
         -- A source-file instance declaration
         -- Type-check all the stuff before the "where"
         --
         -- We check for respectable instance type, and context
-tcLocalInstDecl1 (L loc (FamInstD decl))
+tcLocalInstDecl (L loc (FamInstD { lid_inst = decl }))
   = setSrcSpan loc      $
     tcAddFamInstCtxt decl  $
     do { fam_inst <- tcFamInstDecl TopLevel decl
        ; return ([], [fam_inst]) }
 
-tcLocalInstDecl1 (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
-                                  , cid_sigs = uprags, cid_fam_insts = ats }))
+tcLocalInstDecl (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
+                                 , cid_sigs = uprags, cid_fam_insts = ats }))
   = setSrcSpan loc                      $
     addErrCtxt (instDeclCtxt1 poly_ty)  $
 
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 4433267141..6807fc8827 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -700,7 +700,8 @@ tcDefaultAssocDecl fam_tc (L loc decl)
 tcSynFamInstDecl :: TyCon -> FamInstDecl Name -> TcM ([TyVar], [Type], Type)
 -- Placed here because type family instances appear as 
 -- default decls in class declarations 
-tcSynFamInstDecl fam_tc (FamInstDecl { fid_pats = pats, fid_defn = defn@(TySynonym hs_ty) })
+tcSynFamInstDecl fam_tc 
+    (FamInstDecl { fid_pats = pats, fid_defn = defn@(TySynonym { td_synRhs = hs_ty }) })
   = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
        ; tcFamTyPats fam_tc pats (kcTyDefn defn) $ \tvs' pats' res_kind -> 
@@ -1720,11 +1721,6 @@ recClsErr cycles
   = addErr (sep [ptext (sLit "Cycle in class declaration (via superclasses):"),
                  nest 2 (hsep (intersperse (text "->") (map ppr cycles)))])
 
-sortLocated :: [Located a] -> [Located a]
-sortLocated things = sortLe le things
-  where
-    le (L l1 _) (L l2 _) = l1 <= l2
-
 badDataConTyCon :: DataCon -> Type -> Type -> SDoc
 badDataConTyCon data_con res_ty_tmpl actual_res_ty
   = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+>
@@ -1793,12 +1789,7 @@ 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/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index e7acc3a9a2..00fce7267e 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -109,9 +109,9 @@ synTyConsOfType ty
 
 \begin{code}
 mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])]
-mkSynEdges syn_decls = [ (ldecl, unLoc (tcdLName decl),
-                                 nameSetToList (tcdFVs decl))
-                       | ldecl@(L _ decl) <- syn_decls ]
+mkSynEdges syn_decls = [ (ldecl, name, nameSetToList fvs)
+                       | ldecl@(L _ (TyDecl { tcdLName = L _ name
+                                            , tcdFVs = fvs })) <- syn_decls ]
 
 calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
 calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges