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.

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7d70ad8..5da376b 100644 (file)
--- 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) ;
        
        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
                        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 fd6d3bb..8827f3a 100644 (file)
--- 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,
 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],
 
        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),
             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
              ppr_ds deriv_decls,
             ppr_ds foreign_decls]
        where

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index d17f850..3ef4bff 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -60,7 +60,7 @@ module HsUtils(
   collectLStmtBinders, collectStmtBinders,
   collectSigTysFromPats, collectSigTysFromPat,
 
   collectLStmtBinders, collectStmtBinders,
   collectSigTysFromPats, collectSigTysFromPat,
 

-  hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders, 
+  hsTyClDeclBinders, hsTyClDeclsBinders, 

   hsForeignDeclsBinders, hsGroupBinders
   ) where
 
   hsForeignDeclsBinders, hsGroupBinders
   ) where
 

@@ -572,9 +572,10 @@ hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
 hsForeignDeclsBinders foreign_decls
   = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
 
 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
 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.
 
 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 5524e2d..a756c7f 100644 (file)
--- 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)
                                     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
               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 3766e21..2ce2170 100644 (file)
--- 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 HscTypes                ( HscEnv, hsc_dflags )
 import BasicTypes       ( Boxity(..) )
 import ListSetOps       ( findDupsEq )

-
+import Digraph         ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )

 
 import Control.Monad
 
 import Control.Monad

+import Maybes( orElse )

 import Data.Maybe
 \end{code}
 
 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") ;
    -- 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") ;
 
    -- (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
 
 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.
 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}
 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' ->
 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
 
 
 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}
 %*********************************************************
 %*                                                     *
 \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}
 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
 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_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 })
     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
 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
   | 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
 
 -- 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 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"
 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 f84f3d5..1979c8d 100644 (file)
--- 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
        ; 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
              }
              ; 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 893365e..773f307 100644 (file)
--- 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 {
 
 
    setEnvs tc_envs $ do {
 

-   rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
+   (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;

 
        -- Dump trace of renaming part
    rnDump (ppr rn_decls) ;
 
        -- 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
 
 mkFakeGroup :: [LTyClDecl a] -> HsGroup a
 mkFakeGroup decls -- Rather clumsy; lots of unused fields

-  = emptyRdrGroup { hs_tyclds = decls }
+  = emptyRdrGroup { hs_tyclds = [decls] }

 \end{code}
 
 
 \end{code}
 
 

@@ -504,7 +504,7 @@ tcRnHsBootDecls decls
                -- Family instance declarations are rejected here
        ; traceTc "Tc3" empty
        ; (tcg_env, inst_infos, _deriv_binds) 
                -- 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
        ; 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) 
                -- 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. 
        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 ;
 
                -- 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 ;
 
                -- Foreign exports
         traceTc "Tc7" empty ;

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 1658e0b..a433d69 100644 (file)
--- 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}
 \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
                   -> 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
 
 -- 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
   = 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
        ; traceTc "done" empty

-   
+

        -- Add the implicit things;
        -- 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.
        -- 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
        ; 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
   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}
 
 
 \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:
 
 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').
 
 include the kinds of associated families into the construction of the
 initial kind environment.  (This is handled by `allDecls').
 

+

 \begin{code}
 \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
   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
 -- 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) }
   = 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
 ----------------
 kcSynDecls :: [SCC (LTyClDecl Name)] 
           -> TcM ([LTyClDecl Name],    -- Kind-annotated decls

-                  [(Name,TcKind)])     -- Kind bindings
+                  TcLclEnv)    -- Kind bindings

 kcSynDecls []
 kcSynDecls []

-  = return ([], [])
+  = do { tcl_env <- getLclEnv; return ([], tcl_env) }

 kcSynDecls (group : groups)
 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) 
                        
 ----------------
 kcSynDecl :: SCC (LTyClDecl Name) 

@@ -675,31 +596,11 @@ kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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]
 
   -- "type family" declarations
 tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]

@@ -738,12 +639,24 @@ tcTyClDecl1 parent _calc_isrec
   ; return [ATyCon tycon]
   }
 
   ; 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)
   -- "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})
   (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
   { 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) 
                                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]
   }
        })
   ; 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} )
   (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
   { 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}
 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
   | null cls_cycles
   = return ()
   | otherwise

@@ -1058,8 +972,9 @@ checkValidTyCl decl
        ; traceTc "Validity of" (ppr thing)     
        ; case thing of
            ATyCon tc -> checkValidTyCon tc
        ; 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)        
        }
 
        ; traceTc "Done validity of" (ppr thing)        
        }
 

diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 2366731..a9ea11a 100644 (file)
--- 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
 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.
 
 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)
 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)

diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index 118bcac..a25537e 100644 (file)
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -251,7 +251,7 @@ boundValues mod group =
                        , bind <- bagToList binds
                        , x <- boundThings mod bind ]
                _other -> error "boundValues"
                        , bind <- bagToList binds
                        , x <- boundThings mod bind ]
                _other -> error "boundValues"

-      tys = [ n | ns <- map hsTyClDeclBinders (hs_tyclds group)
+      tys = [ n | ns <- map hsTyClDeclBinders (concat (hs_tyclds group))

                 , n <- map found ns ]
       fors = concat $ map forBound (hs_fords group)
              where forBound lford = case unLoc lford of
                 , n <- map found ns ]
       fors = concat $ map forBound (hs_fords group)
              where forBound lford = case unLoc lford of