Replace Digraph's Node type synonym with a data type
authorMatthew Pickering <matthewtpickering@gmail.com>
Wed, 5 Apr 2017 01:47:29 +0000 (21:47 -0400)
committerBen Gamari <ben@smart-cactus.org>
Wed, 5 Apr 2017 01:47:51 +0000 (21:47 -0400)
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

17 files changed:
compiler/basicTypes/NameEnv.hs
compiler/cmm/CmmBuildInfoTables.hs
compiler/codeGen/StgCmmUtils.hs
compiler/iface/MkIface.hs
compiler/main/GhcMake.hs
compiler/nativeGen/AsmCodeGen.hs
compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
compiler/nativeGen/RegAlloc/Liveness.hs
compiler/rename/RnSource.hs
compiler/simplCore/OccurAnal.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcSMonad.hs
compiler/types/Type.hs
compiler/utils/Digraph.hs
compiler/vectorise/Vectorise/Type/Classify.hs
testsuite/tests/determinism/determ001/determinism001.hs

index a0eb933..cca771a 100644 (file)
@@ -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]
index af3a092..78c604e 100644 (file)
@@ -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
index 2a00379..2375208 100644 (file)
@@ -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]
index 435d06c..d157a5a 100644 (file)
@@ -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
index 3912ac5..25b6467 100644 (file)
@@ -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 ] ++
index b4752cc..b4cfd8e 100644 (file)
@@ -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)
index 186ff3f..1b639c9 100644 (file)
@@ -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
index e387f82..53e0928 100644 (file)
@@ -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 ]
 
 
 
index 30915d5..af145e8 100644 (file)
@@ -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
index b14dbd9..98c81ce 100644 (file)
@@ -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
index 0f381c4..1133e81 100644 (file)
@@ -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
index 006b01c..eb809ab 100644 (file)
@@ -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
index 2502c6e..adb8666 100644 (file)
@@ -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
index 37916f4..56fa938 100644 (file)
@@ -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
index 48e39f7..fe325e6 100644 (file)
@@ -1,11 +1,11 @@
 -- (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
index a1215fd..ffe95f3 100644 (file)
@@ -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
index 9ba9b7f..6de1e67 100644 (file)
@@ -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