[project @ 2004-01-05 10:41:04 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcTyDecls.lhs

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index e67cabe..586974b 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -12,20 +12,21 @@ files for imported data types.
 
 \begin{code}
 module TcTyDecls(
-        calcTyConArgVrcs, tyVarVrc,
-       calcRecFlags, calcCycleErrs,
+        calcTyConArgVrcs,
+       calcRecFlags, 
+       calcClassCycles, calcSynCycles,
        newTyConRhs
     ) where
 
 #include "HsVersions.h"
 
 import TypeRep          ( Type(..), TyNote(..), PredType(..) )  -- friend
-import HsSyn           ( TyClDecl(..), HsPred(..) )
+import HsSyn           ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
 import RnHsSyn         ( extractHsTyNames )
 import Type            ( predTypeRep )
 import BuildTyCl       ( newTyConRhs )
 import HscTypes                ( TyThing(..) )
-import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars,
+import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
                           getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
                          tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
 import Class           ( classTyCon )
@@ -36,8 +37,8 @@ import Name           ( Name, isTyVarName )
 import NameEnv
 import NameSet
 import Digraph                 ( SCC(..), stronglyConnComp, stronglyConnCompR )
-import Maybe           ( isNothing )
 import BasicTypes      ( RecFlag(..) )
+import SrcLoc          ( Located(..), unLoc )
 import Outputable
 \end{code}
 
@@ -107,18 +108,27 @@ synTyConsOfType ty
 ---------------------------------------- END NOTE ]
 
 \begin{code}
-calcCycleErrs :: [TyClDecl Name] -> ([[Name]], -- Recursive type synonym groups
-                                    [[Name]])  -- Ditto classes
-calcCycleErrs decls
-  = (findCyclics syn_edges, findCyclics cls_edges)
+calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
+calcSynCycles decls
+  = stronglyConnComp syn_edges
   where
-       --------------- Type synonyms ----------------------
-    syn_edges       = [ (name, mk_syn_edges rhs) | TySynonym { tcdName = name, tcdSynRhs = rhs } <- decls ]
-    mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), not (isTyVarName tc) ]
+    syn_edges = [ (ldecl, unLoc (tcdLName decl), 
+                         mk_syn_edges (tcdSynRhs decl))
+               | ldecl@(L _ decl) <- decls ]
 
-       --------------- Classes ----------------------
-    cls_edges = [ (name, mk_cls_edges ctxt) | ClassDecl { tcdName = name, tcdCtxt = ctxt } <- decls ]
-    mk_cls_edges ctxt = [ cls | HsClassP cls _ <- ctxt ]
+    mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), 
+                             not (isTyVarName tc) ]
+
+
+calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
+calcClassCycles decls
+  = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
+  where
+    cls_edges = [ (ldecl, unLoc (tcdLName decl),       
+                         mk_cls_edges (unLoc (tcdCtxt decl)))
+               | ldecl@(L _ decl) <- decls, isClassDecl decl ]
+
+    mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
 \end{code}
 
 
@@ -255,12 +265,6 @@ findLoopBreakers deps
     go edges = [ name
               | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
                 name <- tyConName tc : go edges']
-
-findCyclics :: [(Name,[Name])] -> [[Name]]
-findCyclics deps
-  = [names | CyclicSCC names <- stronglyConnComp edges]
-  where
-    edges = [(name,name,ds) | (name,ds) <- deps]
 \end{code}
 
 These two functions know about type representations, so they could be
@@ -333,11 +337,7 @@ calcTyConArgVrcs tyclss
     initial_oi :: NameEnv (TyCon, ArgVrcs)
     initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc))
                           | tc <- tycons]
-    initial tc = if isAlgTyCon tc && isNothing (tyConDataCons_maybe tc) then
-                         -- make pessimistic assumption (and warn)
-                         abstractVrcs tc
-                       else
-                         replicate (tyConArity tc) (False,False)
+    initial tc = replicate (tyConArity tc) (False,False)
 
     tcaoFix :: NameEnv (TyCon, ArgVrcs)   -- initial ArgVrcs per tycon
            -> NameEnv (TyCon, ArgVrcs)   -- fixpointed ArgVrcs per tycon
@@ -358,10 +358,7 @@ calcTyConArgVrcs tyclss
             -> ArgVrcs                   -- new ArgVrcs for tycon
 
     tcaoIter oi tc | isAlgTyCon tc
-      = if null data_cons then
-           abstractVrcs tc             -- Data types with no constructors
-       else
-            map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
+      = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
       where
                data_cons = tyConDataCons tc
                vs        = tyConTyVars tc
@@ -376,20 +373,6 @@ calcTyConArgVrcs tyclss
                        Just (_, pms) -> pms
                        Nothing       -> tyConArgVrcs tc
         -- We use the already-computed result for tycons not in this SCC
-
-
-abstractVrcs :: TyCon -> ArgVrcs
-abstractVrcs tc = 
-#ifdef DEBUG
-                  pprTrace "Vrc: abstract tycon:" (ppr tc) $
-#endif
-                  warn_abstract_vrcs `seq` replicate (tyConArity tc) (True,True)
-
-warn_abstract_vrcs
--- we pull the message out as a CAF so the warning only appears *once*
-  = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n"
-        ++ "         Use -fno-prune-tydecls to fix.") $
-                ()
 \end{code}
 
 
@@ -448,18 +431,6 @@ vrcInTy fao v (NewTcApp tc tys)         = let pms1 = map (vrcInTy fao v) tys
 vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
 \end{code}
 
-
-External entry point: assumes tyconargvrcs already computed.
-
-\begin{code}
-tyVarVrc :: TyVar               -- tyvar to check Vrc of
-         -> Type                -- type to check for occ in
-         -> (Bool,Bool)         -- (occurs positively, occurs negatively)
-
-tyVarVrc = vrcInTy tyConArgVrcs
-\end{code}
-
-
 Variance algebra
 ~~~~~~~~~~~~~~~~