@@ -6,7 +6,7 @@
66module Obelisk.Migration where
77
88import Control.Monad (forM, forM_, unless, void)
9−import Control.Monad.Catch (Exception, MonadThrow, throwM)
9+import Control.Monad.Except
1010import Control.Monad.IO.Class (MonadIO, liftIO)
1111import Control.Monad.State.Strict (evalStateT, get, put)
1212import Data.Map (Map)
@@ -34,36 +34,16 @@ data Migration action = Migration
3434-- A path is a list of edges
3535type Path = [(Hash, Hash)]
3636
37−data GraphInternalError = GraphInternalError Text
38− deriving Show
39−
40−data CyclicGraphError = CyclicGraphError
41− deriving Show
42−
43−data MultipleTerminalVertices = MultipleTerminalVertices
44− deriving Show
45−
46−data NoTerminalVertex = NoTerminalVertex
47− deriving Show
48−
49−data NonEquivalentPaths = NonEquivalentPaths Hash Hash
50− deriving Show
51−
52−data MissingEdgeInActionMap = MissingEdgeInActionMap (Hash, Hash)
53− deriving Show
54−
55−data NonLinearGraph
56− = NonLinearGraph_MultipleAdjacents Hash
37+data MigrationError
38+ = GraphInternalError Text
39+ | CyclicGraphError
40+ | MultipleTerminalVertices
41+ | NoTerminalVertex
42+ | NonEquivalentPaths Hash Hash
43+ | MissingEdgeInActionMap (Hash, Hash)
44+ | NonLinearGraph_MultipleAdjacents Hash
5745 | NonLinearGraph_NotConnected (Set Hash)
58− deriving Show
59−
60−instance Exception GraphInternalError
61−instance Exception CyclicGraphError
62−instance Exception MultipleTerminalVertices
63−instance Exception NoTerminalVertex
64−instance Exception NonEquivalentPaths
65−instance Exception MissingEdgeInActionMap
66−instance Exception NonLinearGraph
46+ deriving (Eq, Ord, Show)
6747
6848class Action action where
6949 parseEdgeMeta :: String -> action
@@ -73,10 +53,10 @@ instance Action Text where
7353
7454-- | Get the directed-acylic graph of migration
7555-- TODO: Consider calling getDag only when reading the graph for efficiency.
76−getDag :: (MonadThrow m, Ord a) => AdjacencyMap a -> m (AdjacencyMap a)
56+getDag :: (MonadError MigrationError m, Ord a) => AdjacencyMap a -> m (AdjacencyMap a)
7757getDag g = case topSort g of
7858 Just _ -> pure g
79− Nothing -> throwM CyclicGraphError
59+ Nothing -> throwError CyclicGraphError
8060
8161-- | Read the graph from a directory of files.
8262readGraph :: Action action => FilePath -> Text -> IO (Maybe (Migration action))
@@ -111,7 +91,7 @@ readGraph root name = doesDirectoryExist root >>= \case
11191--
11292-- Complexity: O(V+E)
11393ensureGraphIntegrity
114− :: (MonadThrow m, Monoid action, Ord action)
94+ :: (MonadError MigrationError m, Monoid action, Ord action)
11595 => Migration action -> m ()
11696ensureGraphIntegrity m = do
11797 graph <- fmap adjacencyMap $ getDag $ _migration_graph m
@@ -125,7 +105,7 @@ ensureGraphIntegrity m = do
125105 Nothing -> pure $ Map.insert adj acc' visited
126106 Just adjAcc -> if acc' == adjAcc
127107 then pure visited
128− else throwM $ NonEquivalentPaths start adj
108+ else throwError $ NonEquivalentPaths start adj
129109 visitFrom visited' acc' adj
130110 -- We only check all paths from the _first_ vertex; it is not necessary to
131111 -- check all paths between _all_ pairs of vertices as that can be proved by
@@ -136,23 +116,23 @@ ensureGraphIntegrity m = do
136116-- | Ensure that the graph is a fully connected linear list
137117--
138118-- Returns the last vertex in the linear list.
139−ensureGraphLinearity :: MonadThrow m => Migration action -> m Hash
119+ensureGraphLinearity :: MonadError MigrationError m => Migration action -> m Hash
140120ensureGraphLinearity m = do
141121 graph <- fmap adjacencyMap $ getDag $ _migration_graph m
142122 firstVertex <- getFirst $ _migration_graph m
143123 let
144124 allVertices = vertexSet $ _migration_graph m
145125 visitFrom start = case Map.lookup start graph of
146− Nothing -> throwM $ GraphInternalError $ "Vertex not found: " <> start
126+ Nothing -> throwError $ GraphInternalError $ "Vertex not found: " <> start
147127 Just adjs -> case (Set.toList adjs) of
148128 [] -> pure (start, [start])
149129 [adj] -> fmap (start :) <$> visitFrom adj
150− _ -> throwM $ NonLinearGraph_MultipleAdjacents start
130+ _ -> throwError $ NonLinearGraph_MultipleAdjacents start
151131 (lastVertex, visitedVertices) <- visitFrom firstVertex
152132 let unvisitedVertices = Set.difference allVertices $ Set.fromList visitedVertices
153133 if Set.null unvisitedVertices
154134 then pure lastVertex
155− else throwM $ NonLinearGraph_NotConnected unvisitedVertices
135+ else throwError $ NonLinearGraph_NotConnected unvisitedVertices
156136
157137-- | Find the concatenated actions between two vertices
158138--
@@ -161,7 +141,7 @@ ensureGraphLinearity m = do
161141--
162142-- Complexity: O(V+E)
163143findPathAction
164− :: (MonadThrow m, Action action, Monoid action, Ord action)
144+ :: (MonadError MigrationError m, Action action, Monoid action, Ord action)
165145 => Migration action -> Hash -> Hash -> m (Maybe action)
166146findPathAction m start end = flip evalStateT Map.empty $ do
167147 graph <- fmap adjacencyMap $ getDag $ _migration_graph m
@@ -188,7 +168,7 @@ findPathAction m start end = flip evalStateT Map.empty $ do
188168 case uniqs actions of
189169 [] -> pure Nothing
190170 [v] -> pure $ Just v -- Exactly one monoidal value; accept.
191− _ -> throwM $ NonEquivalentPaths start' end
171+ _ -> throwError $ NonEquivalentPaths start' end
192172 Nothing ->
193173 pure Nothing
194174 uniqs = Set.toList . Set.fromList
@@ -198,19 +178,19 @@ hasVertex :: Hash -> Migration action -> Bool
198178hasVertex h (Migration g _) = Set.member h $ vertexSet g
199179
200180-- | Get the action for the given edge (which must exist)
201−getAction :: MonadThrow m => Migration action -> (Hash, Hash) -> m action
181+getAction :: MonadError MigrationError m => Migration action -> (Hash, Hash) -> m action
202182getAction (Migration _ h) e = case Map.lookup e h of
203183 Just v -> pure v
204− Nothing -> throwM $ MissingEdgeInActionMap e
184+ Nothing -> throwError $ MissingEdgeInActionMap e
205185
206186-- | Get the last vertex of the given DAG. Nothing if empty graph.
207187--
208188-- Assumes that the graph is fully connected.
209−getLast :: (MonadThrow m, Ord a, Eq a) => AdjacencyMap a -> m a
189+getLast :: (MonadError MigrationError m, Ord a, Eq a) => AdjacencyMap a -> m a
210190getLast g = lastVertices >>= \case
211− [] -> throwM NoTerminalVertex
191+ [] -> throwError NoTerminalVertex
212192 [x] -> pure x
213− _ -> throwM MultipleTerminalVertices
193+ _ -> throwError MultipleTerminalVertices
214194 where
215195 lastVertices
216196 = pure
@@ -220,7 +200,7 @@ getLast g = lastVertices >>= \case
220200 =<< getDag g
221201
222202-- | Get the first vertex of the given DAG. Nothing if empty graph.
223−getFirst :: (MonadThrow m, Ord a, Eq a) => AdjacencyMap a -> m a
203+getFirst :: (MonadError MigrationError m, Ord a, Eq a) => AdjacencyMap a -> m a
224204getFirst = getLast . transpose
225205
226206-- | Write an edge directly to the filesystem.