\begin{code}
module TcTyDecls(
- calcTyConArgVrcs, tyVarVrc,
- calcRecFlags, calcCycleErrs,
- newTyConRhs
+ calcTyConArgVrcs,
+ calcRecFlags,
+ calcClassCycles, calcSynCycles
) 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 )
+ tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
import Class ( classTyCon )
import DataCon ( dataConRepArgTys, dataConOrigArgTys )
import Var ( TyVar )
import NameEnv
import NameSet
import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR )
-import Maybe ( isNothing )
import BasicTypes ( RecFlag(..) )
+import SrcLoc ( Located(..), unLoc )
import Outputable
\end{code}
---------------------------------------- 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}
nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
mk_nt_edges nt -- Invariant: nt is a newtype
- = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt))
+ = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
-- tyConsOfType looks through synonyms
mk_nt_edges1 nt tc
| tc `elem` prod_tycons = [tc] -- Local product
| tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
then []
- else mk_prod_edges1 ptc (newTyConRhs tc)
+ else mk_prod_edges1 ptc (new_tc_rhs tc)
| isHiBootTyCon tc = [ptc] -- Make it self-recursive if
-- it mentions an hi-boot TyCon
-- At this point we know that either it's a local non-product data type,
-- or it's imported. Either way, it can't form part of a cycle
| otherwise = []
+new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
+
getTyCon (ATyCon tc) = tc
getTyCon (AClass cl) = classTyCon cl
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
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
-> 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
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}
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
~~~~~~~~~~~~~~~~
projects / ghc-hetmet.git / blobdiff