git.iko.soy/project-m36
on 8b7e4e4 help sign in
project-m36/src/lib/ProjectM36/TransactionGraph.hs
458 lines 27 kB history raw
1{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
2module ProjectM36.TransactionGraph where
3import ProjectM36.Base
4import ProjectM36.Error
5import ProjectM36.Transaction
6import ProjectM36.Relation
7import ProjectM36.TupleSet
8import ProjectM36.Tuple
9import qualified Data.Vector as V
10import qualified ProjectM36.Attribute as A
11import qualified Data.UUID as U
12import qualified Data.Set as S
13import qualified Data.Map as M
14import Control.Monad
15import qualified Data.Text as T
16import GHC.Generics
17import Data.Binary
18import ProjectM36.TransactionGraph.Merge
19import Data.Either (lefts, rights, isRight)
20--import Debug.Trace
22-- | Record a lookup for a specific transaction in the graph.
23data TransactionIdLookup = TransactionIdLookup TransactionId |
24 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]
25 deriving (Show, Eq, Binary, Generic)
27-- topic~3^2
28data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- git ~: walk back n parents, arbitrarily choosing a parent when a choice must be made
29 TransactionIdHeadBranchBacktrack Int -- git ^: walk back one parent level to the nth arbitrarily-chosen parent
30 deriving (Show, Eq, Binary, Generic)
32--operators which manipulate a transaction graph
33data TransactionGraphOperator = JumpToHead HeadName |
34 JumpToTransaction TransactionId |
35 Branch HeadName |
36 MergeTransactions MergeStrategy HeadName HeadName |
37 Commit |
38 Rollback
39 deriving (Eq, Show, Binary, Generic)
41data ROTransactionGraphOperator = ShowGraph
44bootstrapTransactionGraph :: TransactionId -> DatabaseContext -> TransactionGraph
45bootstrapTransactionGraph freshId context = TransactionGraph bootstrapHeads bootstrapTransactions
46 where
47 bootstrapHeads = M.singleton "master" freshTransaction
48 freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty) context
49 bootstrapTransactions = S.singleton freshTransaction
51emptyTransactionGraph :: TransactionGraph
52emptyTransactionGraph = TransactionGraph M.empty S.empty
54transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
55transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads
57headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
58headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then
59 Nothing
60 else
61 Just $ (head . M.keys) matchingTrans
62 where
63 matchingTrans = M.filter (transaction ==) heads
65transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
66transactionForId tid graph = if tid == U.nil then
67 Left RootTransactionTraversalError
68 else if S.null matchingTrans then
69 Left $ NoSuchTransactionError tid
70 else
71 Right $ head (S.toList matchingTrans)
72 where
73 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
75transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)
76transactionsForIds idSet graph = do
77 transList <- forM (S.toList idSet) ((flip transactionForId) graph)
78 return (S.fromList transList)
80isRootTransaction :: Transaction -> TransactionGraph -> Bool
81isRootTransaction (Transaction _ (TransactionInfo pId _) _) _ = U.null pId
82isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False
84-- the first transaction has no parent - all other do have parents- merges have two parents
85parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
86parentTransactions (Transaction _ (TransactionInfo pId _) _) graph = do
87 trans <- transactionForId pId graph
88 return (S.singleton trans)
90parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph
93childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
94childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForIds children
95childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForIds children
97-- create a new commit and add it to the heads
98-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
99addBranch :: TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
100addBranch newId newBranchName branchPointId graph = do
101 parentTrans <- transactionForId branchPointId graph
102 let newTrans = Transaction newId (TransactionInfo branchPointId S.empty) (transactionContext parentTrans)
103 addTransactionToGraph newBranchName newTrans graph
105--adds a disconnected transaction to a transaction graph at some head
106addDisconnectedTransaction :: TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
107addDisconnectedTransaction newId headName (DisconnectedTransaction parentId context) graph = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) context) graph
109addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
110addTransactionToGraph headName newTrans graph = do
111 let parentIds = transactionParentIds newTrans
112 childIds = transactionChildIds newTrans
113 newId = transactionId newTrans
114 validateIds ids = mapM (\i -> transactionForId i graph) (S.toList ids)
115 addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans))
116 --validate that the parent transactions are in the graph
117 _ <- validateIds parentIds
118 when (S.size parentIds < 1) (Left $ NewTransactionMissingParentError newId)
119 --if the headName already exists, ensure that it refers to a parent
120 case transactionForHead headName graph of
121 Nothing -> pure () -- any headName is OK
122 Just trans -> when (S.notMember (transactionId trans) parentIds) (Left (HeadNameSwitchingHeadProhibitedError headName))
123 --validate that the transaction has no children
124 when (not (S.null childIds)) (Left $ NewTransactionMayNotHaveChildrenError newId)
125 --validate that the trasaction's id is unique
126 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))
127 --update the parent transactions to point to the new transaction
128 parents <- mapM (\tid -> transactionForId tid graph) (S.toList parentIds)
129 let updatedParents = S.map addChildTransaction (S.fromList parents)
130 updatedTransSet = S.insert newTrans (S.union updatedParents (transactionsForGraph graph))
131 updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)
132 pure (newTrans, (TransactionGraph updatedHeads updatedTransSet))
134validateGraph :: TransactionGraph -> Maybe [RelationalError]
135validateGraph graph@(TransactionGraph _ transSet) = do
136 --check that all transaction ids are unique in the graph
137 --FINISH ME!
138 --uuids = map transactionId transSet
139 --check that all heads appear in the transSet
140 --check that all forward and backward links are in place
141 _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
142 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
144--verify that all parent links exist and that all children exist
145--maybe verify that all parents end at transaction id nil and all children end at leaves
146walkParentTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
147walkParentTransactions seenTransSet graph trans =
148 let transId = transactionId trans in
149 if transId == U.nil then
150 Nothing
151 else if S.member transId seenTransSet then
152 Just $ TransactionGraphCycleError transId
153 else
154 let parentTransSetOrError = parentTransactions trans graph in
155 case parentTransSetOrError of
156 Left err -> Just err
157 Right parentTransSet -> do
158 walk <- mapM (walkParentTransactions (S.insert transId seenTransSet) graph) (S.toList parentTransSet)
159 case walk of
160 err:_ -> Just err
161 _ -> Nothing
163--refactor: needless duplication in these two functions
164walkChildTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
165walkChildTransactions seenTransSet graph trans =
166 let transId = transactionId trans in
167 if childTransactions trans graph == Right S.empty then
168 Nothing
169 else if S.member transId seenTransSet then
170 Just $ TransactionGraphCycleError transId
171 else
172 let childTransSetOrError = childTransactions trans graph in
173 case childTransSetOrError of
174 Left err -> Just err
175 Right childTransSet -> do
176 walk <- mapM (walkChildTransactions (S.insert transId seenTransSet) graph) (S.toList childTransSet)
177 case walk of
178 err:_ -> Just err
179 _ -> Nothing
181-- returns the new "current" transaction, updated graph, and tutorial d result
182-- the current transaction is not part of the transaction graph until it is committed
183evalGraphOp :: TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
185--affects only disconncted transaction
186evalGraphOp _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of
187 Left err -> Left err
188 Right parentTrans -> Right (newTrans, graph)
189 where
190 newTrans = DisconnectedTransaction jumpId (transactionContext parentTrans)
192-- switch from one head to another
193-- affects only disconnectedtransaction
194evalGraphOp _ _ graph (JumpToHead headName) =
195 case transactionForHead headName graph of
196 Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionId newHeadTransaction) (transactionContext newHeadTransaction) in
197 Right (disconnectedTrans, graph)
198 Nothing -> Left $ NoSuchHeadNameError headName
199-- add new head pointing to branchPoint
200-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
201-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
202 {-
203evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case transactionForId parentId graph of
204 Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
205 Just parentTrans -> case addBranch newBranchName parentTrans graph of
206 Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
207 Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
208 where
209 newDiscon = DisconnectedTransaction (transactionId parentTrans) disconContext
210-}
212-- create a new commit and add it to the heads
213-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
214evalGraphOp newId (DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case addBranch newId newBranchName parentId graph of
215 Left err -> Left err
216 Right (_, newGraph) -> Right (newDiscon, newGraph)
217 where
218 newDiscon = DisconnectedTransaction newId disconContext
220-- add the disconnected transaction to the graph
221-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
222evalGraphOp newTransId discon@(DisconnectedTransaction parentId context) graph Commit = case transactionForId parentId graph of
223 Left err -> Left err
224 Right parentTransaction -> case headNameForTransaction parentTransaction graph of
225 Nothing -> Left $ TransactionIsNotAHeadError parentId
226 Just headName -> case maybeUpdatedGraph of
227 Left err-> Left err
228 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
229 where
230 newDisconnectedTrans = newDisconnectedTransaction newTransId context
231 maybeUpdatedGraph = addDisconnectedTransaction newTransId headName discon graph
233-- refresh the disconnected transaction, return the same graph
234evalGraphOp _ (DisconnectedTransaction parentId _) graph Rollback = case transactionForId parentId graph of
235 Left err -> Left err
236 Right parentTransaction -> Right (newDiscon, graph)
237 where
238 newDiscon = newDisconnectedTransaction parentId (transactionContext parentTransaction)
240-- a successful merge should remove a head
241evalGraphOp newId (DisconnectedTransaction parentId _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph
243--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
244graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
245graphAsRelation (DisconnectedTransaction parentId _) graph@(TransactionGraph _ transSet) = do
246 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
247 mkRelationFromList attrs tupleMatrix
248 where
249 attrs = A.attributesFromList [Attribute "id" TextAtomType,
250 Attribute "parents" (RelationAtomType parentAttributes),
251 Attribute "current" BoolAtomType,
252 Attribute "head" TextAtomType
253 ]
254 parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]
255 tupleGenerator transaction = case transactionParentsRelation transaction graph of
256 Left err -> Left err
257 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),
258 RelationAtom parentTransRel,
259 BoolAtom $ parentId == transactionId transaction,
260 TextAtom $ case headNameForTransaction transaction graph of
261 Just headName -> headName
262 Nothing -> ""
263 ]
265transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
266transactionParentsRelation trans graph = do
267 if isRootTransaction trans graph then do
268 mkRelation attrs emptyTupleSet
269 else do
270 parentTransSet <- parentTransactions trans graph
271 let tuples = map trans2tuple (S.toList parentTransSet)
272 mkRelationFromTuples attrs tuples
273 where
274 attrs = A.attributesFromList [Attribute "id" TextAtomType]
275 trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))
277{-
278--display transaction graph as relation
279evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
280evalROGraphOp discon graph ShowGraph = do
281 graphRel <- graphAsRelation discon graph
282 return graphRel
283-}
285-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
286createMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
287createMergeTransaction newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
288 selectedTrans <- validateHeadName selectedBranch graph t2
289 pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty) (transactionContext selectedTrans)
291-- merge functions, relvars, individually
292createMergeTransaction newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction newId strat graph t2
294-- merge function, relvars, but, on error, just take the component from the preferred branch
295createMergeTransaction newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction newId strat graph t2
297-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.
298validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
299validateHeadName headName graph (t1, t2) = do
300 case transactionForHead headName graph of
301 Nothing -> Left SelectedHeadMismatchMergeError
302 Just trans -> if trans /= t1 && trans /= t2 then
303 Left SelectedHeadMismatchMergeError
304 else
305 Right trans
307-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal.
308subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
309subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do
310 let currentid = transactionId currentTrans
311 goalid = transactionId goalTrans
312 if currentTrans == goalTrans then
313 Right (TransactionGraph resultHeads traverseSet) -- add filter
314 --catch root transaction to improve error?
315 else do
316 currentTransChildren <- liftM S.fromList $ mapM (flip transactionForId origGraph) (S.toList (transactionChildIds currentTrans))
317 let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren
318 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)
319 childSearches = map searchChild (S.toList searchChildren)
320 errors = lefts childSearches
321 pathsFound = rights childSearches
322 realErrors = filter (/= (FailedToFindTransactionError goalid)) errors
323 -- report any non-search-related errors
324 when (not (null realErrors)) (Left (head realErrors))
325 -- if no paths found, search the parent
326 if null pathsFound then
327 case oneParent currentTrans of
328 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
329 Left err -> Left err
330 Right currentTransParent -> do
331 subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)
332 else -- we found a path
333 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
334 where
335 oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForId parentId origGraph
336 oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForId parentId origGraph
338-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
339pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
340pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
341 let targetId = transactionId targetTransaction
342 if transactionId targetTransaction == transactionId currentTransaction then do
343 Right accumTransSet
344 else do
345 currentTransChildren <- mapM (flip transactionForId graph) (S.toList (transactionChildIds currentTransaction))
346 if length currentTransChildren == 0 then
347 Left (FailedToFindTransactionError targetId)
348 else do
349 let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) currentTransChildren
350 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
351 paths = rights searches
352 if length realErrors > 0 then -- found some real errors
353 Left (head realErrors)
354 else if length paths == 0 then -- failed to find transaction in all children
355 Left (FailedToFindTransactionError targetId)
356 else --we have some paths!
357 Right (S.unions paths)
359mergeTransactions :: TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
360mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph = do
361 let transactionForHeadErr name = case transactionForHead name graph of
362 Nothing -> Left (NoSuchHeadNameError name)
363 Just t -> Right t
364 transA <- transactionForHeadErr headNameA
365 transB <- transactionForHeadErr headNameB
366 disconParent <- transactionForId parentId graph
367 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)
368 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
369 subGraph' <- filterSubGraph subGraph subHeads
370 case createMergeTransaction newId mergeStrategy subGraph' (transA, transB) of
371 Left err -> Left (MergeTransactionError err)
372 Right mergedTrans -> case headNameForTransaction disconParent graph of
373 Nothing -> Left (TransactionIsNotAHeadError parentId)
374 Just headName -> do
375 (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph
376 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
377 newDiscon = newDisconnectedTransaction newId (transactionContext newTrans)
378 pure (newDiscon, newGraph')
380--TEMPORARY COPY/PASTE
381showTransactionStructureX :: Transaction -> TransactionGraph -> String
382showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo
383 where
384 headInfo = maybe "" show (headNameForTransaction trans graph)
385 parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of
386 Left err -> show err
387 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet
389showGraphStructureX :: TransactionGraph -> String
390showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
391 where
392 folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
393 headsInfo = show $ M.map transactionId heads
395-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
396filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
397filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
398 where
399 validIds = S.map transactionId (transactionsForGraph graph)
400 newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
401 newHeads = M.map (filterTransaction validIds) heads
403--helper function for commonalities in union merge
404createUnionMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
405createUnionMergeTransaction newId strategy graph (t1,t2) = do
406 let contextA = transactionContext t1
407 contextB = transactionContext t2
409 preference <- case strategy of
410 UnionMergeStrategy -> pure PreferNeither
411 UnionPreferMergeStrategy preferBranch -> do
412 case transactionForHead preferBranch graph of
413 Nothing -> Left (PreferredHeadMissingMergeError preferBranch)
414 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
415 badStrat -> Left (InvalidMergeStrategyError badStrat)
417 incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
418 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
419 atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
420 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)
421 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
422 pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) (DatabaseContext incDeps relVars atomFuncs notifs types))
424lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction
425lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph
426lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of
427 Nothing -> Left (NoSuchHeadNameError headName)
428 Just headTrans -> do
429 traversedId <- traverseGraph graph (transactionId headTrans) backtracks
430 transactionForId traversedId graph
432traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId
433traverseGraph graph currentTid backtrackSteps = foldM (backtrackGraph graph) currentTid backtrackSteps
435backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId
436-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily
437backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do
438 trans <- transactionForId currentTid graph
439 let parents = S.toAscList (transactionParentIds trans)
440 if length parents < 1 then
441 Left RootTransactionTraversalError
442 else do
443 parentTrans <- transactionForId (head parents) graph
444 if steps == 1 then do
445 pure (transactionId parentTrans)
446 else
447 backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))
449backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do
450 trans <- transactionForId currentTid graph
451 let parents = transactionParentIds trans
452 if S.size parents < 1 then
453 Left RootTransactionTraversalError
454 else if S.size parents < steps then
455 Left (ParentCountTraversalError (S.size parents) steps)
456 else
457 pure (S.elemAt (steps - 1) parents)