1044f86 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP fix critical bug in adding child transactions which did not update the parent transaction because it took the input transaction at face value instead of updating the transaction in the graph

1044f86AgentM10 years ago

ProjectM36/Error.hs+2

compare with master

unifiedsplit

@@ -28,11 +28,13 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

28 | PredicateExpressionError T.Text

29 | NoCommonTransactionAncestorError U.UUID U.UUID

30 | NoSuchTransactionError U.UUID

31+ | RootTransactionTraversalError

31 | NoSuchHeadNameError HeadName

32 | NoSuchHeadNameError HeadName

32 | TransactionIsNotAHeadError U.UUID

33 | TransactionIsNotAHeadError U.UUID

33 | TransactionGraphCycleError U.UUID

34 | TransactionGraphCycleError U.UUID

34 | SessionIdInUseError U.UUID

35 | SessionIdInUseError U.UUID

35 | NoSuchSessionError U.UUID

36 | NoSuchSessionError U.UUID

37+ | FailedToFindTransactionError U.UUID

36 | NoSuchTupleExprFunctionError AtomFunctionName

38 | NoSuchTupleExprFunctionError AtomFunctionName

37 | NoSuchTypeConstructorName TypeConstructorName

39 | NoSuchTypeConstructorName TypeConstructorName

38 | TypeConstructorAtomTypeMismatch TypeConstructorName AtomType

40 | TypeConstructorAtomTypeMismatch TypeConstructorName AtomType

ProjectM36/Transaction.hs+9

@@ -12,6 +12,15 @@ transactionParentUUIDs :: Transaction -> S.Set U.UUID

12transactionParentUUIDs (Transaction _ (TransactionInfo pUUID _) _) = S.singleton pUUID

13transactionParentUUIDs (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _) = S.fromList [pUUID1, pUUID2]

15+transactionChildren :: Transaction -> S.Set U.UUID

16+transactionChildren (Transaction _ (TransactionInfo _ children) _) = children

17+transactionChildren (Transaction _ (MergeTransactionInfo _ _ children) _) = children

18+

19+-- | Create a new transaction which is identical to the original except that a new set of children UUIDs is added.

20+transactionSetChildren :: Transaction -> S.Set U.UUID -> Transaction

21+transactionSetChildren t@(Transaction _ (TransactionInfo pUUID _) _) childIds = Transaction (transactionUUID t) (TransactionInfo pUUID childIds) (transactionContext t)

22+transactionSetChildren t@(Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _) childIds = Transaction (transactionUUID t) (MergeTransactionInfo pUUID1 pUUID2 childIds) (transactionContext t)

23+

15-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

24-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

16filterChildrenFromTransactionInfo :: TransactionInfo -> S.Set U.UUID -> TransactionInfo

25filterChildrenFromTransactionInfo :: TransactionInfo -> S.Set U.UUID -> TransactionInfo

17filterChildrenFromTransactionInfo (TransactionInfo parentId childIds) filterIds = TransactionInfo parentId (S.intersection childIds filterIds)

26filterChildrenFromTransactionInfo (TransactionInfo parentId childIds) filterIds = TransactionInfo parentId (S.intersection childIds filterIds)

ProjectM36/TransactionGraph.hs+65−36

@@ -17,6 +17,7 @@ import qualified Data.Text as T

17import GHC.Generics

18import Data.Binary

19import Debug.Trace

20+import Data.Either (lefts, rights)

21--operators which manipulate a transaction graph

22--operators which manipulate a transaction graph

22data TransactionGraphOperator = JumpToHead HeadName |

23data TransactionGraphOperator = JumpToHead HeadName |

@@ -52,7 +53,9 @@ headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchi

52 matchingTrans = M.filter (transaction ==) heads

53 matchingTrans = M.filter (transaction ==) heads

54transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction

55transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction

55−transactionForUUID uuid graph = if S.null matchingTrans then

56+transactionForUUID uuid graph = if uuid == U.nil then

57+ Left RootTransactionTraversalError

58+ else if S.null matchingTrans then

56 Left $ NoSuchTransactionError uuid

59 Left $ NoSuchTransactionError uuid

57 else

60 else

58 Right $ head (S.toList matchingTrans)

61 Right $ head (S.toList matchingTrans)

@@ -83,23 +86,24 @@ childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transa

84-- create a new commit and add it to the heads

87-- create a new commit and add it to the heads

85-- 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)

88-- 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)

86−addBranch :: U.UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

89+addBranch :: U.UUID -> HeadName -> U.UUID -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

90+addBranch newUUID newBranchName branchPointId graph = do

91+ parentTrans <- transactionForUUID branchPointId graph

87−addBranch newUUID newBranchName branchPoint graph = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph

92+ addTransactionToGraph newBranchName branchPointId newUUID (transactionContext parentTrans) graph

89--adds a disconnected transaction to a transaction graph at some head

94--adds a disconnected transaction to a transaction graph at some head

90addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

95addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

91−addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = do

96+addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = addTransactionToGraph headName parentUUID newUUID context graph

92− parentTrans <- transactionForUUID parentUUID graph

93− addTransactionToGraph headName parentTrans newUUID context graph

95-- create a new transaction on "newHeadName" with the branchPointTrans

98-- create a new transaction on "newHeadName" with the branchPointTrans

96−addTransactionToGraph :: HeadName -> Transaction -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

99+addTransactionToGraph :: HeadName -> U.UUID -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

97−addTransactionToGraph newHeadName branchPointTrans newUUID newContext (TransactionGraph heads transSet) = do

100+addTransactionToGraph newHeadName branchPointTransId newUUID newContext graph@(TransactionGraph heads transSet) = do

101+ parentTransaction <- transactionForUUID branchPointTransId graph

98− let freshTransaction = Transaction newUUID (TransactionInfo (transactionUUID branchPointTrans) S.empty) newContext

102+ let freshTransaction = Transaction newUUID (TransactionInfo branchPointTransId S.empty) newContext

99 -- there are two parents for MergeTransactions! not implemented

103 -- there are two parents for MergeTransactions! not implemented

100 --update parentTransaction to add child

104 --update parentTransaction to add child

101− let parentTransaction = branchPointTrans

105+ let updatedParentTransaction = transactionSetChildren parentTransaction (S.insert (transactionUUID freshTransaction) (transactionChildren parentTransaction))

102− let updatedTransSet = (S.insert freshTransaction <$> S.insert parentTransaction <$> S.delete parentTransaction) transSet

106+ updatedTransSet = (S.insert freshTransaction <$> S.insert updatedParentTransaction) transSet

103 let updatedGraph = TransactionGraph (M.insert newHeadName freshTransaction heads) updatedTransSet

107 let updatedGraph = TransactionGraph (M.insert newHeadName freshTransaction heads) updatedTransSet

104 return (freshTransaction, updatedGraph)

108 return (freshTransaction, updatedGraph)

105

109

@@ -182,12 +186,10 @@ evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) gr

182

186

183-- create a new commit and add it to the heads

187-- create a new commit and add it to the heads

184-- 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)

188-- 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)

185−evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of

189+evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case addBranch newUUID newBranchName parentUUID graph of

186 Left err -> Left err

190 Left err -> Left err

187− Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of

188− Left err -> Left err

189− Right (_, newGraph) -> Right (newDiscon, newGraph)

191+ Right (_, newGraph) -> Right (newDiscon, newGraph)

190− where

192+ where

191 newDiscon = DisconnectedTransaction newUUID disconContext

193 newDiscon = DisconnectedTransaction newUUID disconContext

192

194

193-- add the disconnected transaction to the graph

195-- add the disconnected transaction to the graph

@@ -273,29 +275,55 @@ validateHeadName headName graph (t1, t2) = do

273 else

275 else

274 Right trans

276 Right trans

275

277

276−-- | Return the common ancestor of two transactions. When looking for the first common ancestor, we don't need to search both parents of a merge transaction because the merge must have diverged from a common ancestor anyway, so we arbitrarily just search one of the parents of a merge transaction. Technically, due to merge transactions, this may not actually return the first common ancestor, but it should be pretty close.

278+-- 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.

277−subGraphToFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> TransactionGraph -> Transaction -> Transaction -> Either RelationalError TransactionGraph

279+subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph

278−subGraphToFirstCommonAncestor origGraph resultHeads subGraph trans1 trans2 = do

280+subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do

279− let t1id = transactionUUID trans1

281+ let currentid = transactionUUID currentTrans

280− t2id = transactionUUID trans2

282+ goalid = transactionUUID goalTrans

281− validChildIds = traceShowId $ S.map transactionUUID (transactionsForGraph subGraph)

283+ if currentTrans == goalTrans then

282− filterTransSet transSet = S.map (\t -> filterChildTransactions t validChildIds) transSet

283− if t1id == t2id then

284− --also filter child transactions

285− Right (TransactionGraph resultHeads (S.union (transactionsForGraph subGraph) (filterTransSet (S.singleton trans1))))

284+ Right (TransactionGraph resultHeads traverseSet) -- add filter

286− else if U.null t1id || U.null t2id then --no common ancestor

285+ --catch root transaction to improve error?

287− Left (NoCommonTransactionAncestorError t1id t2id)

288 else do

286 else do

289− parentTrans1 <- oneParent trans1

287+ currentTransChildren <- liftM S.fromList $ mapM (flip transactionForUUID origGraph) (S.toList (transactionChildren currentTrans))

290− parentTrans2 <- oneParent trans2

288+ let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren

291− --add transactions to graph

289+ searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)

290+ childSearches = map searchChild (S.toList searchChildren)

291+ errors = lefts childSearches

292+ pathsFound = rights childSearches

293+ if null childSearches || all (== (Left (FailedToFindTransactionError goalid))) childSearches then --no path found, so search the parent

294+ case oneParent currentTrans of

295+ Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)

296+ Left err -> Left err

297+ Right currentTransParent -> do

298+ subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)

299+ else if length errors > 0 then -- traversal error

300+ Left (head errors)

301+ else -- we found a path

292− let subGraph' = TransactionGraph resultHeads newTrans

302+ Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))

293− newTrans = S.union (transactionsForGraph subGraph) (filterTransSet (S.fromList [trans1, trans2]))

294− subGraphToFirstCommonAncestor origGraph resultHeads subGraph' parentTrans1 parentTrans2

295 where

303 where

296 oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForUUID parentId origGraph

304 oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForUUID parentId origGraph

297 oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForUUID parentId origGraph

305 oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForUUID parentId origGraph

298

306

307+-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.

308+pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)

309+pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

310+ let targetId = transactionUUID targetTransaction

311+ if targetTransaction == currentTransaction then

312+ Right accumTransSet

313+ else do

314+ currentTransChildren <- mapM (flip transactionForUUID graph) (S.toList (transactionChildren currentTransaction))

315+ if length currentTransChildren == 0 then

316+ Left (FailedToFindTransactionError targetId)

317+ else do

318+ let searches = map (\t -> pathToTransaction graph targetTransaction t (S.insert t accumTransSet)) currentTransChildren

319+ let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)

320+ paths = rights searches

321+ if length realErrors > 0 then -- found some real errors

322+ Left (head realErrors)

323+ else if length paths == 0 then -- failed to find transaction in all children

324+ Left (FailedToFindTransactionError targetId)

325+ else --we have some paths!

326+ Right (S.unions paths)

299

327

300mergeTransactions :: U.UUID -> U.UUID -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

328mergeTransactions :: U.UUID -> U.UUID -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

301mergeTransactions newUUID parentUUID mergeStrategy (headNameA, headNameB) graph = do

329mergeTransactions newUUID parentUUID mergeStrategy (headNameA, headNameB) graph = do

@@ -315,14 +343,15 @@ mergeTransactions newUUID parentUUID mergeStrategy (headNameA, headNameB) graph

315

343

316 disconParent <- transactionForUUID parentUUID graph

344 disconParent <- transactionForUUID parentUUID graph

317 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)

345 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)

318− subGraph <- subGraphToFirstCommonAncestor graph subHeads emptyTransactionGraph transA transB

346+ subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty

347+

319 case createMergeTransaction newUUID mergeStrategy subGraph (transA, transB) of

348 case createMergeTransaction newUUID mergeStrategy subGraph (transA, transB) of

320 Left err -> Left (MergeTransactionError err)

349 Left err -> Left (MergeTransactionError err)

321 Right mergedTrans -> case headNameForTransaction disconParent graph of

350 Right mergedTrans -> case headNameForTransaction disconParent graph of

322 Nothing -> Left (TransactionIsNotAHeadError parentUUID)

351 Nothing -> Left (TransactionIsNotAHeadError parentUUID)

323 Just headName -> do

352 Just headName -> do

324 -- why create a merge transaction and then only use the context?

353 -- why create a merge transaction and then only use the context?

325− (newTrans, newGraph) <- addTransactionToGraph headName disconParent newUUID (transactionContext mergedTrans) graph

354+ (newTrans, newGraph) <- addTransactionToGraph headName parentUUID newUUID (transactionContext mergedTrans) graph

326 let newGraph' = TransactionGraph newHeads (transactionsForGraph newGraph)

355 let newGraph' = TransactionGraph newHeads (transactionsForGraph newGraph)

327 newHeads = M.delete headNameToDelete (transactionHeadsForGraph newGraph)

356 newHeads = M.delete headNameToDelete (transactionHeadsForGraph newGraph)

328 newDiscon = newDisconnectedTransaction newUUID (transactionContext newTrans)

357 newDiscon = newDisconnectedTransaction newUUID (transactionContext newTrans)

ProjectM36/TransactionGraph/Show.hs+3−1

@@ -2,16 +2,18 @@

2module ProjectM36.TransactionGraph.Show where

3import ProjectM36.Base

4import ProjectM36.TransactionGraph

5+import ProjectM36.Transaction

5import qualified Data.Set as S

6import qualified Data.Set as S

8showTransactionStructure :: Transaction -> TransactionGraph -> String

9showTransactionStructure :: Transaction -> TransactionGraph -> String

9−showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo

10+showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " p" ++ parentTransactionsInfo ++ " c" ++ childTransactionsInfo

10 where

11 where

11 headInfo = maybe "" show (headNameForTransaction trans graph)

12 headInfo = maybe "" show (headNameForTransaction trans graph)

12 parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of

13 parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of

13 Left err -> show err

14 Left err -> show err

14 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionUUID) parentTransSet

15 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionUUID) parentTransSet

16+ childTransactionsInfo = show (S.toList (transactionChildren trans))

16showGraphStructure :: TransactionGraph -> String

18showGraphStructure :: TransactionGraph -> String

17showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" transSet

19showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" transSet

test/TransactionGraph/Merge.hs+38−13

@@ -11,6 +11,7 @@ import System.Exit

11import Data.Word

12import ProjectM36.RelationalExpression

13import qualified Data.UUID as U

14+import qualified Data.Set as S

14import qualified ProjectM36.DatabaseContext as DBC

15import qualified ProjectM36.DatabaseContext as DBC

15import Control.Monad.State hiding (join)

16import Control.Monad.State hiding (join)

16import ProjectM36.Relation (relationTrue)

17import ProjectM36.Relation (relationTrue)

@@ -23,9 +24,9 @@ main = do

24testList :: Test

25testList :: Test

25testList = TestList [

26testList = TestList [

26− testSubGraphToFirstAncestorBasic,

27+ testSubGraphToFirstAncestorBasic

27− testSubGraphToFirstAncestorSnipBranch,

28+ --testSubGraphToFirstAncestorSnipBranch,

28− testSelectedBranchMerge

29+ --testSelectedBranchMerge

29 ]

30 ]

31-- | Create a transaction graph with two branches and no changes between them.

32-- | Create a transaction graph with two branches and no changes between them.

@@ -44,12 +45,12 @@ basicTransactionGraph = do

44 uuidB = fakeUUID 11

45 uuidB = fakeUUID 11

45 uuidRoot = fakeUUID 1

46 uuidRoot = fakeUUID 1

46 rootContext = transactionContext rootTrans

47 rootContext = transactionContext rootTrans

47− (_, bsGraph') <- addTransaction "branchA" uuidA rootContext rootTrans bsGraph

48+ (_, bsGraph') <- addTransaction "branchA" uuidA rootContext uuidRoot bsGraph

48− (_, bsGraph'') <- addTransaction "branchB" uuidB rootContext rootTrans bsGraph'

49+ (_, bsGraph'') <- addTransaction "branchB" uuidB rootContext uuidRoot bsGraph'

49 pure bsGraph''

50 pure bsGraph''

51−addTransaction :: HeadName -> U.UUID -> DatabaseContext -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)

52+addTransaction :: HeadName -> U.UUID -> DatabaseContext -> U.UUID -> TransactionGraph -> IO (Transaction, TransactionGraph)

52−addTransaction headName newTransUUID context parentTrans graph = case addTransactionToGraph headName parentTrans newTransUUID context graph of

53+addTransaction headName newTransUUID context parentTransId graph = case addTransactionToGraph headName parentTransId newTransUUID context graph of

53 Left err -> assertFailure (show err) >> error ""

54 Left err -> assertFailure (show err) >> error ""

54 Right (t,g) -> pure (t,g)

55 Right (t,g) -> pure (t,g)

@@ -77,11 +78,12 @@ assertMaybe x msg = case x of

77-- | Test that a subgraph of the basic graph is equal to the original graph (nothing to filter).

78-- | Test that a subgraph of the basic graph is equal to the original graph (nothing to filter).

78testSubGraphToFirstAncestorBasic :: Test

79testSubGraphToFirstAncestorBasic :: Test

79testSubGraphToFirstAncestorBasic = TestCase $ do

80testSubGraphToFirstAncestorBasic = TestCase $ do

80− graph <- basicTransactionGraph

81+ graph <- basicTransactionGraph

82+ putStrLn $ showGraphStructure graph

81 assertGraph graph

83 assertGraph graph

82 transA <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA"

84 transA <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA"

83 transB <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB"

85 transB <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB"

84− subgraph <- assertEither $ subGraphToFirstCommonAncestor graph (transactionHeadsForGraph graph) emptyTransactionGraph transA transB

86+ subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph graph) transA transB S.empty

85 assertEqual "no graph changes" subgraph graph

87 assertEqual "no graph changes" subgraph graph

87-- | Test that a branch anchored at the root transaction is removed when using the first ancestor function.

89-- | Test that a branch anchored at the root transaction is removed when using the first ancestor function.

@@ -91,11 +93,26 @@ testSubGraphToFirstAncestorSnipBranch = TestCase $ do

91 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"

93 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"

92 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"

94 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"

93 rootTrans <- assertEither (transactionForUUID (fakeUUID 1) baseGraph)

95 rootTrans <- assertEither (transactionForUUID (fakeUUID 1) baseGraph)

94− (_, graph) <- addTransaction "branchC" (fakeUUID 12) (transactionContext transA) rootTrans baseGraph

96+ (_, graph) <- addTransaction "branchC" (fakeUUID 12) (transactionContext transA) (fakeUUID 1) baseGraph

95− subgraph <- assertEither $ subGraphToFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) emptyTransactionGraph transA transB

97+ subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty

96 assertGraph subgraph

98 assertGraph subgraph

97 assertEqual "failed to snip branch" baseGraph subgraph

99 assertEqual "failed to snip branch" baseGraph subgraph

100

101+-- | Test that the subgraph function recurses properly through multiple parent transactions.

102+testSubGraphToFirstAncestorMoreTransactions :: Test

103+testSubGraphToFirstAncestorMoreTransactions = TestCase $ do

104+ graph <- basicTransactionGraph

105+ assertGraph graph

106+

107+ -- add another relvar to branchB

108+ branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"

109+ updatedBranchBContext <- case runState (evalContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (transactionContext branchBTrans) of

110+ (Just err, _) -> assertFailure (show err) >> undefined

111+ (Nothing, context) -> pure context

112+ (_, graph') <- addTransaction "branchB" (fakeUUID 3) updatedBranchBContext (transactionUUID branchBTrans) graph

113+ pure ()

114+

115+

99testSelectedBranchMerge :: Test

116testSelectedBranchMerge :: Test

100testSelectedBranchMerge = TestCase $ do

117testSelectedBranchMerge = TestCase $ do

101 graph <- basicTransactionGraph

118 graph <- basicTransactionGraph

@@ -106,12 +123,20 @@ testSelectedBranchMerge = TestCase $ do

106 updatedBranchBContext <- case runState (evalContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (transactionContext branchBTrans) of

123 updatedBranchBContext <- case runState (evalContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (transactionContext branchBTrans) of

107 (Just err, _) -> assertFailure (show err) >> undefined

124 (Just err, _) -> assertFailure (show err) >> undefined

108 (Nothing, context) -> pure context

125 (Nothing, context) -> pure context

109− (_, graph') <- addTransaction "branchB" (fakeUUID 3) updatedBranchBContext branchBTrans graph

126+ (_, graph') <- addTransaction "branchB" (fakeUUID 3) updatedBranchBContext (transactionUUID branchBTrans) graph

127+ --putStrLn $ "struct " ++ showGraphStructure graph'

110 --create the merge transaction in the graph

128 --create the merge transaction in the graph

111 let eGraph' = mergeTransactions (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'

129 let eGraph' = mergeTransactions (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'

112− putStrLn "SPAMMO"

113

130

131+ case eGraph' of

132+ Left err -> assertFailure ("poop" ++ show err)

133+ Right (_, pgraph) -> putStrLn (showGraphStructure pgraph)

134+

135+ putStrLn "SPAMMO"

136+

114 (DisconnectedTransaction _ mergedContext, graph'') <- assertEither eGraph'

137 (DisconnectedTransaction _ mergedContext, graph'') <- assertEither eGraph'

138+

139+ putStrLn "SPAMMO2"

115 assertGraph graph''

140 assertGraph graph''

116 --validate that the branchB was removed

141 --validate that the branchB was removed

117 rootTrans <- assertEither $ transactionForUUID (fakeUUID 1) graph''

142 rootTrans <- assertEither $ transactionForUUID (fakeUUID 1) graph''