4160718 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP compilation checkpoint- union merge

commit41607187b5322ea9eea1d627bc37f7584fad9ead authorAgentM <agentm@themactionfaction.com> dateMon 18 Jul 2016, 12:25 (10 years ago) parent0748736

6 files changed+103−52

compare with master

unifiedsplit

ProjectM36/Error.hs+3 ProjectM36/Transaction.hs+6−6 ProjectM36/TransactionGraph.hs+35−11 ProjectM36/TransactionGraph/Show.hs+1−18 ProjectM36/TransactionGraph/Show/Dot.hs+22 test/TransactionGraph/Merge.hs+36−17

ProjectM36/Error.hs+3

@@ -30,11 +30,14 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

3030 | NoSuchTransactionError U.UUID

3131 | RootTransactionTraversalError

3232 | NoSuchHeadNameError HeadName

33+ | NewTransactionMayNotHaveChildrenError U.UUID

34+ | NewTransactionMissingParentError U.UUID

3335 | TransactionIsNotAHeadError U.UUID

3436 | TransactionGraphCycleError U.UUID

3537 | SessionIdInUseError U.UUID

3638 | NoSuchSessionError U.UUID

3739 | FailedToFindTransactionError U.UUID

40+ | TransactionIdInUseError U.UUID

3841 | NoSuchTupleExprFunctionError AtomFunctionName

3942 | NoSuchTypeConstructorName TypeConstructorName

4043 | TypeConstructorAtomTypeMismatch TypeConstructorName AtomType

ProjectM36/Transaction.hs+6−6

@@ -8,13 +8,13 @@ import qualified Data.Set as S

88newDisconnectedTransaction :: U.UUID -> DatabaseContext -> DisconnectedTransaction

99newDisconnectedTransaction parentUUID context = DisconnectedTransaction parentUUID context

1010

11−transactionParentUUIDs :: Transaction -> S.Set U.UUID

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

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

11+transactionParentIds :: Transaction -> S.Set U.UUID

12+transactionParentIds (Transaction _ (TransactionInfo pUUID _) _) = S.singleton pUUID

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

1414

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

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

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

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

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

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

1818

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

2020transactionSetChildren :: Transaction -> S.Set U.UUID -> Transaction

ProjectM36/TransactionGraph.hs+35−11

@@ -7,6 +7,7 @@ import ProjectM36.Relation

77import ProjectM36.TupleSet

88import ProjectM36.Tuple

99import ProjectM36.DataTypes.Primitive

10+import ProjectM36.TransactionGraph.Show.Dot

1011import qualified Data.Vector as V

1112import qualified ProjectM36.Attribute as A

1213import qualified Data.UUID as U

@@ -17,8 +18,8 @@ import qualified Data.Text as T

1718import GHC.Generics

1819import Data.Binary

1920import ProjectM36.TransactionGraph.Merge

20−import Data.Either (lefts, rights)

21−--import Debug.Trace

21+import Data.Either (lefts, rights, isRight)

22+import Debug.Trace

2223

2324--operators which manipulate a transaction graph

2425data TransactionGraphOperator = JumpToHead HeadName |

@@ -90,12 +91,34 @@ childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transa

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

9192addBranch newUUID newBranchName branchPointId graph = do

9293 parentTrans <- transactionForUUID branchPointId graph

93− addTransactionToGraph newBranchName branchPointId newUUID (transactionContext parentTrans) graph

94+ let newTrans = Transaction newUUID (TransactionInfo branchPointId S.empty) (transactionContext parentTrans)

95+ addTransactionToGraph newBranchName newTrans graph

9496

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

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

97−addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = addTransactionToGraph headName parentUUID newUUID context graph

98−

99+addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = addTransactionToGraph headName (Transaction newUUID (TransactionInfo parentUUID S.empty) context) graph

100+

101+addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

102+addTransactionToGraph headName newTrans graph = do

103+ let parentIds = transactionParentIds newTrans

104+ childIds = transactionChildIds newTrans

105+ newId = transactionUUID newTrans

106+ validateIds ids = mapM (\i -> transactionForUUID i graph) (S.toList ids)

107+ addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans))

108+ --validate that the parent transactions are in the graph

109+ _ <- validateIds parentIds

110+ when (S.size parentIds < 1) (Left $ NewTransactionMissingParentError newId)

111+ --validate that the transaction has no children

112+ when (not (S.null childIds)) (Left $ NewTransactionMayNotHaveChildrenError newId)

113+ --validate that the trasaction's id is unique

114+ when (isRight (transactionForUUID newId graph)) (Left (TransactionIdInUseError newId))

115+ --update the parent transactions to point to the new transaction

116+ parents <- mapM (\tid -> transactionForUUID tid graph) (S.toList parentIds)

117+ let updatedParents = S.map addChildTransaction (S.fromList parents)

118+ updatedTransSet = S.union updatedParents (transactionsForGraph graph)

119+ updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)

120+ pure (newTrans, (TransactionGraph updatedHeads updatedTransSet))

121+{-

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

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

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

@@ -107,7 +130,7 @@ addTransactionToGraph newHeadName branchPointTransId newUUID newContext graph@(T

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

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

109132 return (freshTransaction, updatedGraph)

110−

133+-}

111134validateGraph :: TransactionGraph -> Maybe [RelationalError]

112135validateGraph graph@(TransactionGraph _ transSet) = do

113136 --check that all UUIDs are unique in the graph

@@ -297,7 +320,7 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans trave

297320 Right (TransactionGraph resultHeads traverseSet) -- add filter

298321 --catch root transaction to improve error?

299322 else do

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

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

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

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

303326 childSearches = map searchChild (S.toList searchChildren)

@@ -324,7 +347,7 @@ pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

324347 if targetTransaction == currentTransaction then

325348 Right accumTransSet

326349 else do

327− currentTransChildren <- mapM (flip transactionForUUID graph) (S.toList (transactionChildren currentTransaction))

350+ currentTransChildren <- mapM (flip transactionForUUID graph) (S.toList (transactionChildIds currentTransaction))

328351 if length currentTransChildren == 0 then

329352 Left (FailedToFindTransactionError targetId)

330353 else do

@@ -356,10 +379,10 @@ mergeTransactions newUUID parentUUID mergeStrategy (headNameA, headNameB) graph

356379 Right mergedTrans -> case headNameForTransaction disconParent graph of

357380 Nothing -> Left (TransactionIsNotAHeadError parentUUID)

358381 Just headName -> do

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

360− (newTrans, newGraph) <- addTransactionToGraph headName parentUUID newUUID (transactionContext mergedTrans) graph

382+ (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph

361383 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)

362384 newDiscon = newDisconnectedTransaction newUUID (transactionContext newTrans)

385+ traceM (graphAsDot newGraph)

363386 pure (newDiscon, newGraph')

364387

365388--TEMPORARY COPY/PASTE

@@ -383,4 +406,5 @@ filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet

383406 where

384407 validIds = S.map transactionUUID (transactionsForGraph graph)

385408 newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)

386− newHeads = M.map (filterTransaction validIds) heads

409+ newHeads = M.map (filterTransaction validIds) heads

410+

ProjectM36/TransactionGraph/Show.hs+1−18

@@ -4,8 +4,6 @@ import ProjectM36.Base

44import ProjectM36.TransactionGraph

55import ProjectM36.Transaction

66import qualified Data.Set as S

7−import qualified Data.Map as M

8−import qualified Data.Text as T

108showTransactionStructure :: Transaction -> TransactionGraph -> String

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

@@ -14,26 +12,11 @@ showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID

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

1513 Left err -> show err

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

17− childTransactionsInfo = show (S.toList (transactionChildren trans))

15+ childTransactionsInfo = show (S.toList (transactionChildIds trans))

1816

1917showGraphStructure :: TransactionGraph -> String

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

2119 where

2220 folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"

2321

24−graphAsDot :: TransactionGraph -> String

25−graphAsDot (TransactionGraph heads transSet) = "digraph {" ++ dot ++ headInfo ++ "}"

26− where

27− dot = S.foldr transactionAsDot "" transSet

28− transactionAsDot trans acc = acc ++ childArrows trans ++ parentArrows trans

29− arrows trans idSet = S.foldr (\c acc' -> acc' ++ oneArrow trans c) "" idSet

30− childArrows trans = arrows trans (transactionChildren trans)

31− parentArrows trans = arrows trans (transactionParentUUIDs trans)

32− transLabel t = tidLabel (transactionUUID t)

33− tidLabel l = "\"" ++ show l ++ "\""

34− oneArrow trans tid = transLabel trans ++ " -> " ++ tidLabel tid ++ ";\n"

35− headInfo = M.foldrWithKey (\headName t acc -> transLabel t ++ " [label=\"" ++ (show . transactionUUID) t ++ ":" ++ T.unpack headName ++ "\"];\n" ++ acc) "" heads

36−

37−

38−

3922

ProjectM36/TransactionGraph/Show/Dot.hsnew file+22

@@ -0,0 +1,22 @@

1+module ProjectM36.TransactionGraph.Show.Dot where

2+import ProjectM36.Transaction

3+import ProjectM36.Base

4+import qualified Data.Text as T

5+import qualified Data.Set as S

6+import qualified Data.Map as M

8+graphAsDot :: TransactionGraph -> String

9+graphAsDot (TransactionGraph heads transSet) = "digraph {" ++ dot ++ headInfo ++ "}"

10+ where

11+ dot = S.foldr transactionAsDot "" transSet

12+ transactionAsDot trans acc = acc ++ childArrows trans ++ parentArrows trans

13+ arrows trans idSet = S.foldr (\c acc' -> acc' ++ oneArrow trans c) "" idSet

14+ childArrows trans = arrows trans (transactionChildIds trans)

15+ parentArrows trans = arrows trans (transactionParentIds trans)

16+ transLabel t = tidLabel (transactionUUID t)

17+ tidLabel l = "\"" ++ show l ++ "\""

18+ oneArrow trans tid = transLabel trans ++ " -> " ++ tidLabel tid ++ ";"

19+ headInfo = M.foldrWithKey (\headName t acc -> transLabel t ++ " [label=\"" ++ (show . transactionUUID) t ++ ":" ++ T.unpack headName ++ "\"];" ++ acc) "" heads

20+

21+

22+

test/TransactionGraph/Merge.hs+36−17

@@ -4,6 +4,7 @@ import Test.HUnit

44import ProjectM36.Base

55import ProjectM36.TransactionGraph

66import ProjectM36.TransactionGraph.Show

7+import ProjectM36.TransactionGraph.Show.Dot

78import ProjectM36.DateExamples

89import ProjectM36.Error

910import qualified Data.ByteString.Lazy as BS

@@ -12,6 +13,7 @@ import Data.Word

1213import ProjectM36.RelationalExpression

1314import qualified Data.UUID as U

1415import qualified Data.Set as S

16+import qualified Data.Map as M

1517import qualified ProjectM36.DatabaseContext as DBC

1618import Control.Monad.State hiding (join)

1719import ProjectM36.Relation (relationTrue)

@@ -24,9 +26,10 @@ main = do

2426

2527testList :: Test

2628testList = TestList [

27− testSubGraphToFirstAncestorBasic,

28− testSubGraphToFirstAncestorSnipBranch,

29− testSelectedBranchMerge

29+ --testSubGraphToFirstAncestorBasic,

30+ --testSubGraphToFirstAncestorSnipBranch,

31+ --testSelectedBranchMerge,

32+ testUnionMergeStrategy

3033 ]

3134

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

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

4548 uuidB = fakeUUID 11

4649 uuidRoot = fakeUUID 1

4750 rootContext = transactionContext rootTrans

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

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

51+ (_, bsGraph') <- addTransaction "branchA" (Transaction uuidA (TransactionInfo uuidRoot S.empty) rootContext) bsGraph

52+ (_, bsGraph'') <- addTransaction "branchB" (Transaction uuidB (TransactionInfo uuidRoot S.empty) rootContext) bsGraph'

5053 pure bsGraph''

5154

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

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

55+addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)

56+addTransaction headName transaction graph = case addTransactionToGraph headName transaction graph of

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

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

5659

@@ -92,7 +95,7 @@ testSubGraphToFirstAncestorSnipBranch = TestCase $ do

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

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

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

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

98+ (_, graph) <- addTransaction "branchC" (Transaction (fakeUUID 12) (TransactionInfo (fakeUUID 1) S.empty) (transactionContext transA)) baseGraph

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

97100 assertGraph subgraph

98101 assertEqual "failed to snip branch" baseGraph subgraph

@@ -108,7 +111,8 @@ testSubGraphToFirstAncestorMoreTransactions = TestCase $ do

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

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

110113 (Nothing, context) -> pure context

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

114+ (_, graph') <- addTransaction "branchB" (Transaction (fakeUUID 3) (TransactionInfo (transactionUUID branchBTrans) S.empty) updatedBranchBContext) graph

115+ --FINISH ME

112116 pure ()

113117

114118

@@ -122,8 +126,7 @@ testSelectedBranchMerge = TestCase $ do

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

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

124128 (Nothing, context) -> pure context

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

126−

129+ (_, graph') <- addTransaction "branchB" (Transaction (fakeUUID 3) (TransactionInfo (transactionUUID branchBTrans) S.empty) updatedBranchBContext) graph

127130 --create the merge transaction in the graph

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

129132

@@ -136,8 +139,8 @@ testSelectedBranchMerge = TestCase $ do

136139 assertEqual "head of merged transaction was removed" (transactionUUID branchBTrans) (fakeUUID 3)

137140

138141 --validate that the branchB relvar does *not* appear in the merge because branchA was selected

139− mergeTrans <- assertMaybe (transactionForUUID (fakeUUID 4) graph'')

140− assertTrue "branchOnlyRelvar is present in merge" (M.notMember "branchBOnlyRelvar" (relationVariables (transactionContext mergeTrans)))

142+ mergeTrans <- assertEither (transactionForUUID (fakeUUID 4) graph'')

143+ assertBool "branchOnlyRelvar is present in merge" (M.notMember "branchBOnlyRelvar" (relationVariables (transactionContext mergeTrans)))

141144

142145-- try various individual component conflicts and check for resolution

143146testUnionPreferMergeStrategy :: Test

@@ -149,14 +152,30 @@ testUnionMergeStrategy = TestCase $ do

149152 graph <- basicTransactionGraph

150153 assertGraph graph

151154

152−

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

154156 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"

155157 -- add another relvar to branchB - branchBOnlyRelvar should appear in the merge

156158 -- add inclusion dependency in branchA

157159

158− let updatedBranchBContext = branchBTrans {relationVariables = M.insert "branchBOnlyRelVar" (relationVariables branchBTrans) }

159− let updatedBranchAContext = branchATrans {inclusionDependencies = M.insert "branchAOnlyIncDep" (inclusionDependencies branchATrans) }

160+ let updatedBranchBContext = (transactionContext branchBTrans) {relationVariables = M.insert branchBOnlyRelVarName branchBOnlyRelVar (relationVariables (transactionContext branchBTrans)) }

161+ updatedBranchAContext = (transactionContext branchATrans) {inclusionDependencies = M.insert "branchAOnlyIncDep" branchAOnlyIncDep (inclusionDependencies (transactionContext branchATrans)) }

162+ branchBOnlyRelVar = relationTrue

163+ branchBOnlyRelVarName = "branchBOnlyRelVar"

164+ branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)

165+ assertMergeError mergeResult = case mergeResult of

166+ Left err -> assertEqual "incorrect merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)

167+ Right (_, g) -> do

168+ putStrLn (graphAsDot g)

169+ assertFailure "expected merge failure"

170+

171+ (_, graph') <- addTransaction "branchB" (Transaction (fakeUUID 3) (TransactionInfo (transactionUUID branchBTrans) S.empty) updatedBranchBContext) graph

172+ ((DisconnectedTransaction _ mergeContext1), mergedGraph1) <- assertEither $ mergeTransactions (fakeUUID 5) (fakeUUID 1) UnionMergeStrategy ("branchA", "branchB") graph'

173+ assertEqual "branchBOnlyRelVar should appear in the merge" (M.lookup branchBOnlyRelVarName (relationVariables mergeContext1)) (Just relationTrue)

174+ --putStrLn (graphAsDot graph')

175+

176+ (_, graph'') <- addTransaction "branchA" (Transaction (fakeUUID 4) (TransactionInfo (transactionUUID branchATrans) S.empty) updatedBranchAContext) graph'

177+ let eMergeGraph = mergeTransactions (fakeUUID 5) (fakeUUID 1) UnionMergeStrategy ("branchA", "branchB") graph''

178+ --putStrLn (showGraphStructure graph'')

179+ pure ()

160180

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

162181