Commit 1831aed1 authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

Replace Digraph's Node type synonym with a data type

This refactoring makes it more obvious when we are constructing
a Node for the digraph rather than a less useful 3-tuple.

Reviewers: austin, goldfire, bgamari, simonmar, dfeuer

Reviewed By: dfeuer

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3414
parent 53152236
......@@ -69,7 +69,8 @@ depAnal get_defs get_uses nodes
= stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes)
where
keyed_nodes = nodes `zip` [(1::Int)..]
mk_node (node, key) = (node, key, mapMaybe (lookupNameEnv key_map) (get_uses node))
mk_node (node, key) =
DigraphNode node key (mapMaybe (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]
......
......@@ -278,7 +278,8 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
g = stronglyConnCompFromEdgedVerticesOrd
[ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ]
[ DigraphNode (l,cafs) l (Set.elems cafs)
| (cafs, Just l) <- localCAFs ]
flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
flatten env cafset = foldSet (lookup env) Set.empty cafset
......
......@@ -399,8 +399,8 @@ emitMultiAssign regs rhss = do
unscramble :: DynFlags -> [Vrtx] -> FCode ()
unscramble dflags vertices = mapM_ do_component components
where
edges :: [ (Vrtx, Key, [Key]) ]
edges = [ (vertex, key1, edges_from stmt1)
edges :: [ Node Key Vrtx ]
edges = [ DigraphNode vertex key1 (edges_from stmt1)
| vertex@(key1, stmt1) <- vertices ]
edges_from :: Stmt -> [Key]
......
......@@ -445,8 +445,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
non_orph_fis decl
edges :: [(IfaceDeclABI, Unique, [Unique])]
edges = [ (abi, getUnique (getOccName decl), out)
edges :: [ Node Unique IfaceDeclABI ]
edges = [ DigraphNode abi (getUnique (getOccName decl)) out
| decl <- new_decls
, let abi = declABI decl
, let out = localOccs $ freeNamesDeclABI abi
......
......@@ -1570,7 +1570,7 @@ typecheckLoop dflags hsc_env mods = do
reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards mod summaries
= [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
= [ node_payload node | node <- reachableG (transposeG graph) root ]
where -- the rest just sets up the graph:
(graph, lookup_node) = moduleGraphNodes False summaries
root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
......@@ -1618,13 +1618,13 @@ topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
| otherwise = throwGhcException (ProgramError "module does not exist")
in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
type SummaryNode = (ModSummary, Int, [Int])
type SummaryNode = Node Int ModSummary
summaryNodeKey :: SummaryNode -> Int
summaryNodeKey (_, k, _) = k
summaryNodeKey = node_key
summaryNodeSummary :: SummaryNode -> ModSummary
summaryNodeSummary (s, _, _) = s
summaryNodeSummary = node_payload
moduleGraphNodes :: Bool -> [ModSummary]
-> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
......@@ -1642,11 +1642,12 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
node_map :: NodeMap SummaryNode
node_map = Map.fromList [ ((moduleName (ms_mod s),
hscSourceToIsBoot (ms_hsc_src s)), node)
| node@(s, _, _) <- nodes ]
| node <- nodes
, let s = summaryNodeSummary node ]
-- We use integers as the keys for the SCC algorithm
nodes :: [SummaryNode]
nodes = [ (s, key, out_keys)
nodes = [ DigraphNode s key out_keys
| (s, key) <- numbered_summaries
-- Drop the hi-boot ones if told to do so
, not (isBootSummary s && drop_hs_boot_nodes)
......@@ -2212,7 +2213,7 @@ cyclicModuleErr mss
, nest 2 (show_path path) ]
where
graph :: [Node NodeKey ModSummary]
graph = [(ms, msKey ms, get_deps ms) | ms <- mss]
graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss]
get_deps :: ModSummary -> [NodeKey]
get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++
......
......@@ -848,9 +848,7 @@ sequenceBlocks infos (entry:blocks) =
sccBlocks
:: Instruction instr
=> [NatBasicBlock instr]
-> [SCC ( NatBasicBlock instr
, BlockId
, [BlockId])]
-> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks blocks = stronglyConnCompFromEdgedVerticesUniqR (map mkNode blocks)
......@@ -867,10 +865,10 @@ getOutEdges instrs
mkNode :: (Instruction t)
=> GenBasicBlock t
-> (GenBasicBlock t, BlockId, [BlockId])
mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
-> Node BlockId (GenBasicBlock t)
mkNode block@(BasicBlock id instrs) = DigraphNode block id (getOutEdges instrs)
seqBlocks :: LabelMap i -> [(GenBasicBlock t1, BlockId, [BlockId])]
seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
-> [GenBasicBlock t1]
seqBlocks infos blocks = placeNext pullable0 todo0
where
......@@ -879,8 +877,8 @@ seqBlocks infos blocks = placeNext pullable0 todo0
-- reason not to;
-- may include blocks that have already been placed, but then
-- these are not in pullable
pullable0 = listToUFM [ (i,(b,n)) | (b,i,n) <- blocks ]
todo0 = [i | (_,i,_) <- blocks ]
pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ]
todo0 = map node_key blocks
placeNext _ [] = []
placeNext pullable (i:rest)
......
......@@ -229,7 +229,7 @@ joinToTargets_again
-- We cut some corners by not handling memory-to-memory moves.
-- This shouldn't happen because every temporary gets its own stack slot.
--
makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]
makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique]
makeRegMovementGraph adjusted_assig dest_assig
= [ node | (vreg, src) <- nonDetUFMToList adjusted_assig
-- This is non-deterministic but we do not
......@@ -255,15 +255,15 @@ expandNode
:: a
-> Loc -- ^ source of move
-> Loc -- ^ destination of move
-> [(a, Loc, [Loc])]
-> [Node Loc a ]
expandNode vreg loc@(InReg src) (InBoth dst mem)
| src == dst = [(vreg, loc, [InMem mem])]
| otherwise = [(vreg, loc, [InReg dst, InMem mem])]
| src == dst = [DigraphNode vreg loc [InMem mem]]
| otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]]
expandNode vreg loc@(InMem src) (InBoth dst mem)
| src == mem = [(vreg, loc, [InReg dst])]
| otherwise = [(vreg, loc, [InReg dst, InMem mem])]
| src == mem = [DigraphNode vreg loc [InReg dst]]
| otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]]
expandNode _ (InBoth _ src) (InMem dst)
| src == dst = [] -- guaranteed to be true
......@@ -276,7 +276,7 @@ expandNode vreg (InBoth src _) dst
expandNode vreg src dst
| src == dst = []
| otherwise = [(vreg, src, [dst])]
| otherwise = [DigraphNode vreg src [dst]]
-- | Generate fixup code for a particular component in the move graph
......@@ -286,14 +286,14 @@ expandNode vreg src dst
--
handleComponent
:: Instruction instr
=> Int -> instr -> SCC (Unique, Loc, [Loc])
=> Int -> instr -> SCC (Node Loc Unique)
-> RegM freeRegs [instr]
-- If the graph is acyclic then we won't get the swapping problem below.
-- In this case we can just do the moves directly, and avoid having to
-- go via a spill slot.
--
handleComponent delta _ (AcyclicSCC (vreg, src, dsts))
handleComponent delta _ (AcyclicSCC (DigraphNode vreg src dsts))
= mapM (makeMove delta vreg src) dsts
......@@ -313,7 +313,7 @@ handleComponent delta _ (AcyclicSCC (vreg, src, dsts))
-- require a fixup.
--
handleComponent delta instr
(CyclicSCC ((vreg, InReg sreg, (InReg dreg: _)) : rest))
(CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest))
-- dest list may have more than one element, if the reg is also InMem.
= do
-- spill the source into its slot
......
......@@ -677,29 +677,28 @@ natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
-- exactly what we do. (#7574)
--
sccBlocks
:: Instruction instr
:: forall instr . Instruction instr
=> [NatBasicBlock instr]
-> [BlockId]
-> [SCC (NatBasicBlock instr)]
sccBlocks blocks entries = map (fmap get_node) sccs
sccBlocks blocks entries = map (fmap node_payload) sccs
where
-- nodes :: [(NatBasicBlock instr, Unique, [Unique])]
nodes = [ (block, id, getOutEdges instrs)
nodes :: [ Node BlockId (NatBasicBlock instr) ]
nodes = [ DigraphNode block id (getOutEdges instrs)
| block@(BasicBlock id instrs) <- blocks ]
g1 = graphFromEdgedVerticesUniq nodes
reachable :: LabelSet
reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ]
reachable = setFromList [ node_key node | node <- reachablesG g1 roots ]
g2 = graphFromEdgedVerticesUniq [ node | node@(_,id,_) <- nodes
, id `setMember` reachable ]
g2 = graphFromEdgedVerticesUniq [ node | node <- nodes
, node_key node
`setMember` reachable ]
sccs = stronglyConnCompG g2
get_node (n, _, _) = n
getOutEdges :: Instruction instr => [instr] -> [BlockId]
getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
......@@ -709,7 +708,8 @@ sccBlocks blocks entries = map (fmap get_node) sccs
-- node: (NatBasicBlock, BlockId, [BlockId]). This takes
-- advantage of the fact that Digraph only looks at the key,
-- even though it asks for the whole triple.
roots = [(panic "sccBlocks",b,panic "sccBlocks") | b <- entries ]
roots = [DigraphNode (panic "sccBlocks") b (panic "sccBlocks")
| b <- entries ]
......
......@@ -49,7 +49,7 @@ import DynFlags
import Util ( debugIsOn, lengthExceeds, partitionWith )
import HscTypes ( HscEnv, hsc_dflags )
import ListSetOps ( findDupsEq, removeDups, equivClasses )
import Digraph ( SCC, flattenSCC, flattenSCCs
import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..)
, stronglyConnCompFromEdgedVerticesUniq )
import UniqSet
import qualified GHC.LanguageExtensions as LangExt
......@@ -1349,7 +1349,8 @@ depAnalTyClDecls :: GlobalRdrEnv
depAnalTyClDecls rdr_env ds_w_fvs
= stronglyConnCompFromEdgedVerticesUniq edges
where
edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nonDetEltsUniqSet fvs))
edges :: [ Node Name (LTyClDecl Name) ]
edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))
| (d, fvs) <- ds_w_fvs ]
-- It's OK to use nonDetEltsUFM here as
-- stronglyConnCompFromEdgedVertices is still deterministic
......
......@@ -11,7 +11,7 @@ The occurrence analyser re-typechecks a core expression, returning a new
core expression with (hopefully) improved usage information.
-}
{-# LANGUAGE CPP, BangPatterns, MultiWayIf #-}
{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-}
module OccurAnal (
occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap
......@@ -35,7 +35,7 @@ import VarSet
import VarEnv
import Var
import Demand ( argOneShots, argsOneShots )
import Digraph ( SCC(..), Node
import Digraph ( SCC(..), Node(..)
, stronglyConnCompFromEdgedVerticesUniq
, stronglyConnCompFromEdgedVerticesUniqR )
import Unique
......@@ -978,7 +978,7 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
(map mk_loop_breaker chosen_nodes ++ binds)
where
(chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb
(nd_score (fstOf3 node))
(nd_score (node_payload node))
[node] [] nodes
approximate_lb = depth >= 2
......@@ -988,14 +988,15 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
-- and approximate, returning to d=0
mk_loop_breaker :: LetrecNode -> Binding
mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs})
= (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs)
where
tail_info = tailCallInfo (idOccInfo bndr)
mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding
-- See Note [Weak loop breakers]
mk_non_loop_breaker weak_fvs (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _)
mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr
, nd_rhs = rhs})
| bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs)
| otherwise = (bndr, rhs)
where
......@@ -1029,7 +1030,7 @@ chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)
| otherwise -- Worse score so don't pick it
= chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes
where
sc = nd_score (fstOf3 node)
sc = nd_score (node_payload node)
{-
Note [Complexity of loop breaking]
......@@ -1223,7 +1224,7 @@ makeNode :: OccEnv -> ImpRuleEdges -> VarSet
-> (Var, CoreExpr) -> LetrecNode
-- See Note [Recursive bindings: the grand plan]
makeNode env imp_rule_edges bndr_set (bndr, rhs)
= (details, varUnique bndr, nonDetKeysUniqSet node_fvs)
= DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs)
-- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR
-- is still deterministic with edges in nondeterministic order as
-- explained in Note [Deterministic SCC] in Digraph.
......@@ -1296,10 +1297,12 @@ mkLoopBreakerNodes lvl bndr_set body_uds details_s
= (final_uds, zipWith mk_lb_node details_s bndrs')
where
(final_uds, bndrs') = tagRecBinders lvl body_uds
[ (nd_bndr nd, nd_uds nd, nd_rhs_bndrs nd)
[ ((nd_bndr nd)
,(nd_uds nd)
,(nd_rhs_bndrs nd))
| nd <- details_s ]
mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr'
= (nd', varUnique bndr, nonDetKeysUniqSet lb_deps)
= DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps)
-- It's OK to use nonDetKeysUniqSet here as
-- stronglyConnCompFromEdgedVerticesR is still deterministic with edges
-- in nondeterministic order as explained in
......
......@@ -552,8 +552,8 @@ type BKey = Int -- Just number off the bindings
mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
-- See Note [Polymorphic recursion] in HsBinds.
mkEdges sig_fn binds
= [ (bind, key, [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
Just key <- [lookupNameEnv key_map n], no_sig n ])
= [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
Just key <- [lookupNameEnv key_map n], no_sig n ]
| (bind, key) <- keyd_binds
]
-- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
......
......@@ -803,12 +803,12 @@ evVarsOfTerms = mapUnionVarSet evVarsOfTerm
sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges
where
edges :: [(EvBind, EvVar, [EvVar])]
edges :: [ Node EvVar EvBind ]
edges = foldrBag ((:) . mk_node) [] bs
mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
mk_node :: EvBind -> Node EvVar EvBind
mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
= (b, var, nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet`
= DigraphNode b var (nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet`
coVarsOfType (varType var)))
-- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
-- is still deterministic even if the edges are in nondeterministic order
......
......@@ -2422,8 +2422,8 @@ checkForCyclicBinds ev_binds_map
coercion_cycles = [c | c <- cycles, any is_co_bind c]
is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b)
edges :: [(EvBind, EvVar, [EvVar])]
edges = [ (bind, bndr, nonDetEltsUniqSet (evVarsOfTerm rhs))
edges :: [ Node EvVar EvBind ]
edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))
| bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]
-- It's OK to use nonDetEltsUFM here as
-- stronglyConnCompFromEdgedVertices is still deterministic even
......
......@@ -1891,16 +1891,18 @@ predTypeEqRel ty
-- (that is, doesn't depend on Uniques).
toposortTyVars :: [TyVar] -> [TyVar]
toposortTyVars tvs = reverse $
[ tv | (tv, _, _) <- topologicalSortG $
[ node_payload node | node <- topologicalSortG $
graphFromEdgedVerticesOrd nodes ]
where
var_ids :: VarEnv Int
var_ids = mkVarEnv (zip tvs [1..])
nodes = [ ( tv
, lookupVarEnv_NF var_ids tv
, mapMaybe (lookupVarEnv var_ids)
(tyCoVarsOfTypeList (tyVarKind tv)) )
nodes :: [ Node Int TyVar ]
nodes = [ DigraphNode
tv
(lookupVarEnv_NF var_ids tv)
(mapMaybe (lookupVarEnv var_ids)
(tyCoVarsOfTypeList (tyVarKind tv)))
| tv <- tvs ]
-- | Extract a well-scoped list of variables from a deterministic set of
......
-- (c) The University of Glasgow 2006
{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-}
module Digraph(
Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
SCC(..), Node, flattenSCC, flattenSCCs,
SCC(..), Node(..), flattenSCC, flattenSCCs,
stronglyConnCompG,
topologicalSortG, dfsTopSortG,
verticesG, edgesG, hasVertexG,
......@@ -89,7 +89,10 @@ data Graph node = Graph {
data Edge node = Edge node node
type Node key payload = (payload, key, [key])
data Node key payload = DigraphNode {
node_payload :: payload,
node_key :: key,
node_dependencies :: [key] }
-- The payload is user data, just carried around in this module
-- The keys are ordered
-- The [key] are the dependencies of the node;
......@@ -109,11 +112,11 @@ graphFromEdgedVertices
graphFromEdgedVertices _reduceFn [] = emptyGraph
graphFromEdgedVertices reduceFn edged_vertices =
Graph graph vertex_fn (key_vertex . key_extractor)
where key_extractor (_, k, _) = k
where key_extractor = node_key
(bounds, vertex_fn, key_vertex, numbered_nodes) =
reduceFn edged_vertices key_extractor
graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)
| (v, (_, _, ks)) <- numbered_nodes]
| (v, (node_dependencies -> ks)) <- numbered_nodes]
-- We normalize outgoing edges by sorting on node order, so
-- that the result doesn't depend on the order of the edges
......@@ -212,14 +215,15 @@ findCycle graph
= go Set.empty (new_work root_deps []) []
where
env :: Map.Map key (Node key payload)
env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ]
env = Map.fromList [ (node_key node, node) | node <- graph ]
-- Find the node with fewest dependencies among the SCC modules
-- This is just a heuristic to find some plausible root module
root :: Node key payload
root = fst (minWith snd [ (node, count (`Map.member` env) deps)
| node@(_,_,deps) <- graph ])
(root_payload,root_key,root_deps) = root
root = fst (minWith snd [ (node, count (`Map.member` env)
(node_dependencies node))
| node <- graph ])
DigraphNode root_payload root_key root_deps = root
-- 'go' implements Dijkstra's algorithm, more or less
......@@ -232,7 +236,7 @@ findCycle graph
go _ [] [] = Nothing -- No cycles
go visited [] qs = go visited qs []
go visited (((payload,key,deps), path) : ps) qs
go visited (((DigraphNode payload key deps), path) : ps) qs
| key == root_key = Just (root_payload : reverse path)
| key `Set.member` visited = go visited ps qs
| key `Map.notMember` env = go visited ps qs
......@@ -294,8 +298,7 @@ stronglyConnCompFromEdgedVerticesOrd
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd
= map (fmap get_node) . stronglyConnCompFromEdgedVerticesOrdR
where get_node (n, _, _) = n
= map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR
-- The following two versions are provided for backwards compatibility:
-- See Note [Deterministic SCC]
......@@ -305,8 +308,7 @@ stronglyConnCompFromEdgedVerticesUniq
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq
= map (fmap get_node) . stronglyConnCompFromEdgedVerticesUniqR
where get_node (n, _, _) = n
= map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR
-- The "R" interface is used when you expect to apply SCC to
-- (some of) the result of SCC, so you dont want to lose the dependency info
......
......@@ -98,7 +98,8 @@ type TyConGroup = ([TyCon], UniqSet TyCon)
tyConGroups :: [TyCon] -> [TyConGroup]
tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVerticesUniq edges)
where
edges = [((tc, ds), tc, nonDetEltsUniqSet ds) | tc <- tcs
edges :: [ Node TyCon (TyCon, UniqSet TyCon) ]
edges = [DigraphNode (tc, ds) tc (nonDetEltsUniqSet ds) | tc <- tcs
, let ds = tyConsOfTyCon tc]
-- It's OK to use nonDetEltsUniqSet here as
-- stronglyConnCompFromEdgedVertices is still deterministic even
......
......@@ -20,4 +20,6 @@ test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])]
test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])]
testSCC = flattenSCCs . stronglyConnCompFromEdgedVerticesOrd
testSCC = flattenSCCs . stronglyConnCompFromEdgedVerticesOrd . map toNode
where
toNode (a, b, c) = DigraphNode a b c
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment