@@ -13,6 +13,7 @@ import Data.Map (Map)
1313import qualified Data.Map as Map
1414import Data.Maybe (catMaybes)
1515import Data.Semigroup ((<>))
16+import Data.Set (Set)
1617import qualified Data.Set as Set
1718import Data.Text (Text)
1819import qualified Data.Text as T
@@ -33,6 +34,8 @@ data Migration action = Migration
3334-- A path is a list of edges
3435type Path = [(Hash, Hash)]
3536
37+data GraphInternalError = GraphInternalError Text
38+ deriving Show
3639
3740data CyclicGraphError = CyclicGraphError
3841 deriving Show
@@ -49,11 +52,18 @@ data NonEquivalentPaths = NonEquivalentPaths Hash Hash
4952data MissingEdgeInActionMap = MissingEdgeInActionMap (Hash, Hash)
5053 deriving Show
5154
55+data NonLinearGraph
56+ = NonLinearGraph_MultipleAdjacents Hash
57+ | NonLinearGraph_NotConnected (Set Hash)
58+ deriving Show
59+
60+instance Exception GraphInternalError
5261instance Exception CyclicGraphError
5362instance Exception MultipleTerminalVertices
5463instance Exception NoTerminalVertex
5564instance Exception NonEquivalentPaths
5665instance Exception MissingEdgeInActionMap
66+instance Exception NonLinearGraph
5767
5868class Action action where
5969 parseEdgeMeta :: String -> action
@@ -62,6 +72,7 @@ instance Action Text where
6272 parseEdgeMeta = T.pack
6373
6474-- | Get the directed-acylic graph of migration
75+-- TODO: Consider calling getDag only when reading the graph for efficiency.
6576getDag :: (MonadThrow m, Ord a) => AdjacencyMap a -> m (AdjacencyMap a)
6677getDag g = case topSort g of
6778 Just _ -> pure g
@@ -89,7 +100,7 @@ readGraph root name = doesDirectoryExist root >>= \case
89100 False -> do
90101 return Nothing
91102
92−-- | Ensures that the migration graph is correct
103+-- | Ensure that the migration graph is correct
93104--
94105-- In a correct migration graph: for all pairs of nodes, all paths between
95106-- those nodes have the same migration value
@@ -122,6 +133,25 @@ ensureGraphIntegrity m = do
122133 -- further above).
123134 visitFrom mempty mempty firstVertex
124135
136+-- | Ensure that the graph is a fully connected linear list
137+ensureGraphLinearity :: MonadThrow m => Migration action -> m ()
138+ensureGraphLinearity m = do
139+ graph <- fmap adjacencyMap $ getDag $ _migration_graph m
140+ firstVertex <- getFirst $ _migration_graph m
141+ let
142+ visitFrom start = case Map.lookup start graph of
143+ Nothing -> throwM $ GraphInternalError $ "Vertex not found: " <> start
144+ Just adjs -> case (Set.toList adjs) of
145+ [] -> [start]
146+ [adj] -> start : visitFrom adj
147+ _ -> throwM $ NonLinearGraph_MultipleAdjacents start
148+ visitedVertices = Set.fromList $ visitFrom firstVertex
149+ allVertices = vertexSet $ _migration_graph m
150+ unvisitedVertices = Set.difference allVertices visitedVertices
151+ if Set.null unvisitedVertices
152+ then pure ()
153+ else throwM $ NonLinearGraph_NotConnected unvisitedVertices
154+
125155-- | Find the concatenated actions between two vertices
126156--
127157-- All paths between the vertices must have the same mappend'ed action;