import BasicTypes
import SrcLoc
import Outputable
+import Util ( isSingleton )
+import Data.List
\end{code}
\begin{code}
calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
calcSynCycles decls
- = stronglyConnComp syn_edges
+ = stronglyConnCompFromEdgedVertices syn_edges
where
syn_edges = [ (ldecl, unLoc (tcdLName decl),
mk_syn_edges (tcdSynRhs decl))
calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
calcClassCycles decls
- = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
+ = [decls | CyclicSCC decls <- stronglyConnCompFromEdgedVertices cls_edges]
where
cls_edges = [ (ldecl, unLoc (tcdLName decl),
mk_cls_edges (unLoc (tcdCtxt decl)))
-- loop. We could program round this, but it'd make the code
-- rather less nice, so I'm not going to do that yet.
+ single_con_tycons = filter (isSingleton . tyConDataCons) all_tycons
+ -- Both newtypes and data types, with exactly one data constructor
+ (new_tycons, prod_tycons) = partition isNewTyCon single_con_tycons
+ -- NB: we do *not* call isProductTyCon because that checks
+ -- for vanilla-ness of data constructors; and that depends
+ -- on empty existential type variables; and that is figured
+ -- out by tcResultType; which uses tcMatchTy; which uses
+ -- coreView; which calls coreExpandTyCon_maybe; which uses
+ -- the recursiveness of the TyCon. Result... a black hole.
+ -- YUK YUK YUK
+
--------------- Newtypes ----------------------
- new_tycons = filter isNewTyConAndNotOpen all_tycons
- isNewTyConAndNotOpen tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
-- is_rec_nt is a locally-used helper function
| otherwise = []
--------------- Product types ----------------------
- -- The "prod_tycons" are the non-newtype products
- prod_tycons = [tc | tc <- all_tycons,
- not (isNewTyCon tc), isProductTyCon tc]
prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
= go [(tc,tc,ds) | (tc,ds) <- deps]
where
go edges = [ name
- | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
+ | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompFromEdgedVerticesR edges,
name <- tyConName tc : go edges']
\end{code}