Rewrite dependency resolution on algebraic-graphs (fixes exponential non-linear DAG slowdown)

dbmigrations.cabal

@@ -77,7 +77,7 @@ Library
     mtl >= 2.1,
     filepath >= 1.1,
     directory >= 1.0,
-    fgl >= 5.4,
+    algebraic-graphs >= 0.7,
     template-haskell,
     yaml,
     bytestring >= 0.9,
@@ -94,7 +94,6 @@ Library
           Database.Schema.Migrations
           Database.Schema.Migrations.Backend
           Database.Schema.Migrations.Backend.HDBC
-          Database.Schema.Migrations.CycleDetection
           Database.Schema.Migrations.Dependencies
           Database.Schema.Migrations.Filesystem
           Database.Schema.Migrations.Filesystem.Serialize
@@ -118,7 +117,7 @@ test-suite dbmigrations-tests
     mtl >= 2.1,
     filepath >= 1.1,
     directory >= 1.0,
-    fgl >= 5.4,
+    algebraic-graphs >= 0.7,
     template-haskell,
     yaml,
     bytestring >= 0.9,
@@ -134,12 +133,12 @@ test-suite dbmigrations-tests
   other-modules:
     Common
     CommonTH
-    CycleDetectionTest
     DependencyTest
     FilesystemParseTest
     FilesystemSerializeTest
     FilesystemTest
     MigrationsTest
+    NonLinearStressTest
     StoreTest
     InMemoryStore
     LinearMigrationsTest

src/Database/Schema/Migrations.hs

@@ -71,7 +71,8 @@ migrationsToApply storeData backend migration = do
   allMissing <- missingMigrations backend storeData
 
   let deps = (dependencies graph $ mId migration) ++ [mId migration]
-      namesToInstall = [ e | e <- deps, e `elem` allMissing ]
+      missing = Set.fromList allMissing
+      namesToInstall = [ e | e <- deps, e `Set.member` missing ]
       loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToInstall
 
   return loadedMigrations
@@ -87,7 +88,8 @@ migrationsToRevert storeData backend migration = do
   allInstalled <- B.getMigrations backend
 
   let rDeps = (reverseDependencies graph $ mId migration) ++ [mId migration]
-      namesToRevert = [ e | e <- rDeps, e `elem` allInstalled ]
+      installed = Set.fromList allInstalled
+      namesToRevert = [ e | e <- rDeps, e `Set.member` installed ]
       loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToRevert
 
   return loadedMigrations

src/Database/Schema/Migrations/Dependencies.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
 -- |This module types and functions for representing a dependency
 -- graph of arbitrary objects and functions for querying such graphs
 -- to get dependency and reverse dependency information.
@@ -11,13 +11,14 @@ module Database.Schema.Migrations.Dependencies
     )
 where
 
+import Data.List.NonEmpty ( toList )
 import Data.Text ( Text )
-import Data.Maybe ( fromJust )
-import Data.Monoid ( (<>) )
-import Data.Graph.Inductive.Graph ( Graph(..), nodes, edges, Node, suc, pre, lab )
-import Data.Graph.Inductive.PatriciaTree ( Gr )
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
 
-import Database.Schema.Migrations.CycleDetection ( hasCycle )
+import Algebra.Graph.AdjacencyMap ( AdjacencyMap, induce, stars, transpose )
+import Algebra.Graph.AdjacencyMap.Algorithm ( reachable, topSort )
 
 -- |'Dependable' objects supply a representation of their identifiers,
 -- and a list of other objects upon which they depend.
@@ -30,74 +31,64 @@ class (Eq a, Ord a) => Dependable a where
 -- |A 'DependencyGraph' represents a collection of objects together
 -- with a graph of their dependency relationships.  This is intended
 -- to be used with instances of 'Dependable'.
-data DependencyGraph a = DG { depGraphObjectMap :: [(a, Int)]
-                            -- ^ A mapping of 'Dependable' objects to
-                            -- their graph vertex indices.
-                            , depGraphNameMap :: [(Text, Int)]
-                            -- ^ A mapping of 'Dependable' object
-                            -- identifiers to their graph vertex
-                            -- indices.
-                            , depGraph :: Gr Text Text
-                            -- ^ A directed 'Gr' (graph) of the
-                            -- 'Dependable' objects' dependency
-                            -- relationships, with 'Text' vertex and
-                            -- edge labels.
+data DependencyGraph a = DG { depGraphObjects :: [a]
+                            -- ^ The objects the graph was built from.
+                            , depGraph :: AdjacencyMap Text
+                            -- ^ A directed graph of the objects'
+                            -- dependency relationships, with an edge
+                            -- from each object's identifier to the
+                            -- identifier of each of its dependencies.
                             }
 
 instance (Eq a) => Eq (DependencyGraph a) where
-    g1 == g2 = ((nodes $ depGraph g1) == (nodes $ depGraph g2) &&
-                (edges $ depGraph g1) == (edges $ depGraph g2))
+    g1 == g2 = depGraph g1 == depGraph g2
 
 instance (Show a) => Show (DependencyGraph a) where
-    show g = "(" ++ (show $ nodes $ depGraph g) ++ ", " ++ (show $ edges $ depGraph g) ++ ")"
+    show = show . depGraph
 
--- XXX: provide details about detected cycles
 -- |Build a dependency graph from a list of 'Dependable's.  Return the
 -- graph on success or return an error message if the graph cannot be
--- constructed (e.g., if the graph contains a cycle).
+-- constructed (e.g., if the graph contains a cycle or the object
+-- identifiers are not unique).
 mkDepGraph :: (Dependable a) => [a] -> Either String (DependencyGraph a)
-mkDepGraph objects = if hasCycle theGraph
-                     then Left "Invalid dependency graph; cycle detected"
-                     else Right $ DG { depGraphObjectMap = ids
-                                     , depGraphNameMap = names
-                                     , depGraph = theGraph
-                                     }
+mkDepGraph objects
+    | not (null duplicates) =
+        Left $ "Invalid dependency graph; duplicate object identifiers: "
+               <> T.unpack (T.intercalate ", " duplicates)
+    | otherwise =
+        case topSort theGraph of
+          Left cyc -> Left $ "Invalid dependency graph; cycle detected: "
+                             <> T.unpack (T.intercalate " -> " (toList cyc))
+          Right _ -> Right DG { depGraphObjects = objects
+                              , depGraph = theGraph
+                              }
     where
-      theGraph = mkGraph n e
-      n = [ (fromJust $ lookup o ids, depId o) | o <- objects ]
-      e = [ ( fromJust $ lookup o ids
-            , fromJust $ lookup d ids
-            , depId o <> " -> " <> depId d) | o <- objects, d <- depsOf' o ]
-      depsOf' o = map (\i -> fromJust $ lookup i objMap) $ depsOf o
-
-      objMap = map (\o -> (depId o, o)) objects
-      ids = zip objects [1..]
-      names = map (\(o,i) -> (depId o, i)) ids
-
-type NextNodesFunc = Gr Text Text -> Node -> [Node]
-
-cleanLDups :: (Eq a) => [a] -> [a]
-cleanLDups [] = []
-cleanLDups [e] = [e]
-cleanLDups (e:es) = if e `elem` es then (cleanLDups es) else (e:cleanLDups es)
+      theGraph = stars [ (depId o, depsOf o) | o <- objects ]
+      duplicates = Map.keys $ Map.filter (> 1) $
+                   Map.fromListWith (+) [ (depId o, 1 :: Int) | o <- objects ]
 
 -- |Given a dependency graph and an ID, return the IDs of objects that
 -- the object depends on.  IDs are returned with least direct
 -- dependencies first (i.e., the apply order).
 dependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text]
-dependencies g m = reverse $ cleanLDups $ dependenciesWith suc g m
+dependencies g = closureOf (depGraph g)
 
 -- |Given a dependency graph and an ID, return the IDs of objects that
 -- depend on it.  IDs are returned with least direct reverse
 -- dependencies first (i.e., the revert order).
 reverseDependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text]
-reverseDependencies g m = reverse $ cleanLDups $ dependenciesWith pre g m
+reverseDependencies g = closureOf (transpose $ depGraph g)
 
-dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> Text -> [Text]
-dependenciesWith nextNodes dg@(DG _ nMap theGraph) name =
-    let lookupId = fromJust $ lookup name nMap
-        depNodes = nextNodes theGraph lookupId
-        recurse theNodes = map (dependenciesWith nextNodes dg) theNodes
-        getLabel node = fromJust $ lab theGraph node
-        labels = map getLabel depNodes
-    in labels ++ (concat $ recurse labels)
+-- The transitive closure of a name: topologically sort the subgraph
+-- reachable from it (obtaining the lexicographically smallest such
+-- ordering, so the result is deterministic) and reverse the result so
+-- that the deepest dependencies come first.  The name itself is the
+-- unique source of the subgraph and is excluded from the result.
+closureOf :: AdjacencyMap Text -> Text -> [Text]
+closureOf g name =
+    case topSort (induce (`Set.member` reach) g) of
+      Right order -> reverse $ filter (/= name) order
+      Left cyc -> error $ "BUG: dependency graph contains a cycle: "
+                          <> T.unpack (T.intercalate " -> " (toList cyc))
+    where
+      reach = Set.fromList $ reachable g name

src/Database/Schema/Migrations/Store.hs

@@ -28,7 +28,8 @@ import Data.Maybe ( isJust )
 import Control.Monad ( mzero )
 import Control.Applicative ( (<$>) )
 import qualified Data.Map as Map
-import Data.Graph.Inductive.Graph ( labNodes, indeg )
+import qualified Data.Set as Set
+import Algebra.Graph.AdjacencyMap ( adjacencyMap, vertexList )
 
 import Database.Schema.Migrations.Migration
     ( Migration(..)
@@ -155,5 +156,6 @@ depGraphFromMapping mapping = mkDepGraph $ Map.elems mapping
 -- |Finds migrations that no other migration depends on (effectively finds all
 -- vertices with in-degree equal to zero).
 leafMigrations :: StoreData -> [Text]
-leafMigrations s = [l | (n, l) <- labNodes g, indeg g n == 0]
+leafMigrations s = [l | l <- vertexList g, l `Set.notMember` dependedOn]
     where g = depGraph $ storeDataGraph s
+          dependedOn = Set.unions $ Map.elems $ adjacencyMap g