git.iko.soy/project-m36
on master help sign in
add union merge implementation
commitac5c32f25eb7f8c7bd92a0da3bcec97d643f7a2d authorAgentM <agentm@themactionfaction.com> dateSat 2 Jul 2016, 00:47 (10 years ago) parent30b6188
5 files changed+51−16
compare with master
unifiedsplit
ProjectM36/Base.hs+6−3 ProjectM36/Error.hs+4−1 ProjectM36/Transaction.hs+10−5 ProjectM36/TransactionGraph.hs+24−6 test/TransactionGraph/Merge.hs+7−1
ProjectM36/Base.hs+6−3
@@ -309,10 +309,13 @@ data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructo
309309 DataConstructorDefTypeVarNameArg TypeVarName
310310 deriving (Show, Generic, Binary, Eq, NFData)
311311
312+type InclusionDependencies = M.Map IncDepName InclusionDependency
313+type RelationVariables = M.Map RelVarName Relation
314+
312315-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.
313316data DatabaseContext = DatabaseContext {
314− inclusionDependencies :: M.Map IncDepName InclusionDependency,
315− relationVariables :: M.Map RelVarName Relation,
317+ inclusionDependencies :: InclusionDependencies,
318+ relationVariables :: RelationVariables,
316319 atomFunctions :: AtomFunctions,
317320 notifications :: Notifications,
318321 typeConstructorMapping :: TypeConstructorMapping
@@ -389,7 +392,7 @@ data TransactionInfo = TransactionInfo UUID (S.Set UUID) | -- 1 parent + n child
389392 deriving(Show, Generic)
390393
391394instance Binary TransactionInfo
392−
395+
393396-- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.
394397data Transaction = Transaction UUID TransactionInfo DatabaseContext -- self uuid
395398 deriving (Show, Generic)
ProjectM36/Error.hs+4−1
@@ -83,7 +83,10 @@ someErrors errList = if length errList == 1 then
8383
8484data MergeError = SelectedHeadMismatchMergeError |
8585 StrategyViolatesConstraintMergeError |
86− DisconnectedTransactionNotAMergeHeadError U.UUID
86+ DisconnectedTransactionNotAMergeHeadError U.UUID |
87+ StrategyViolatesComponentMergeError | --failed merge in inc deps, relvars, etc.
88+ StrategyViolatesRelationVariableMergeError |
89+ StrategyViolatesTypeConstructorMergeError
8790 deriving (Show, Eq, Generic, Binary, Typeable)
8891
8992instance NFData MergeError where rnf = genericRnf
ProjectM36/Transaction.hs+10−5
@@ -22,9 +22,14 @@ transactionSetChildren t@(Transaction _ (TransactionInfo pUUID _) _) childIds =
2222transactionSetChildren t@(Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _) childIds = Transaction (transactionUUID t) (MergeTransactionInfo pUUID1 pUUID2 childIds) (transactionContext t)
2323
2424-- | 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.
25−filterChildrenFromTransactionInfo :: TransactionInfo -> S.Set U.UUID -> TransactionInfo
26−filterChildrenFromTransactionInfo (TransactionInfo parentId childIds) filterIds = TransactionInfo parentId (S.intersection childIds filterIds)
27−filterChildrenFromTransactionInfo (MergeTransactionInfo parentIdA parentIdB childIds) filterIds = MergeTransactionInfo parentIdA parentIdB (S.intersection childIds filterIds)
25+filterTransactionInfoTransactions :: S.Set U.UUID -> TransactionInfo -> TransactionInfo
26+filterTransactionInfoTransactions filterIds (TransactionInfo parentId childIds) = TransactionInfo (filterParent parentId filterIds) (S.intersection childIds filterIds)
27+filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB childIds) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (S.intersection childIds filterIds)
28+
29+filterParent :: U.UUID -> S.Set U.UUID -> U.UUID
30+filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil
31+
32+-- | Remove any child or parent transaction references not in the valud UUID set.
33+filterTransaction :: S.Set U.UUID -> Transaction -> Transaction
34+filterTransaction filterIds (Transaction selfId tInfo context) = Transaction selfId (filterTransactionInfoTransactions filterIds tInfo) context
2835
29−filterChildTransactions :: Transaction -> S.Set U.UUID -> Transaction
30−filterChildTransactions (Transaction selfId tInfo context) filterIds = Transaction selfId (filterChildrenFromTransactionInfo tInfo filterIds) context
ProjectM36/TransactionGraph.hs+24−6
@@ -16,6 +16,7 @@ import Control.Monad
1616import qualified Data.Text as T
1717import GHC.Generics
1818import Data.Binary
19+import ProjectM36.TransactionGraph.Merge
1920import Data.Either (lefts, rights)
2021--import Debug.Trace
2122
@@ -263,8 +264,18 @@ createMergeTransaction newUUID (SelectedBranchMergeStrategy selectedBranch) grap
263264 selectedTrans <- validateHeadName selectedBranch graph t2
264265 pure $ Transaction newUUID (MergeTransactionInfo (transactionUUID trans1) (transactionUUID trans2) S.empty) (transactionContext selectedTrans)
265266
266−createMergeTransaction newUUID UnionMergeStrategy graph t2 = undefined
267−
267+-- merge functions, relvars, individually
268+createMergeTransaction newUUID UnionMergeStrategy _ (t1,t2) = do
269+ let contextA = transactionContext t1
270+ contextB = transactionContext t2
271+ incDeps <- unionMergeMaps PreferNeither (inclusionDependencies contextA) (inclusionDependencies contextB)
272+ relVars <- unionMergeRelVars PreferNeither (relationVariables contextA) (relationVariables contextB)
273+ atomFuncs <- unionMergeAtomFunctions PreferNeither (atomFunctions contextA) (atomFunctions contextB)
274+ notifs <- unionMergeMaps PreferNeither (notifications contextA) (notifications contextB)
275+ types <- unionMergeTypeConstructorMapping PreferNeither (typeConstructorMapping contextA) (typeConstructorMapping contextB)
276+ pure (Transaction newUUID (MergeTransactionInfo (transactionUUID t1) (transactionUUID t2) S.empty) (DatabaseContext incDeps relVars atomFuncs notifs types))
277+
278+-- merge function, relvars, but, on error, just take the component from the preferred branch
268279createMergeTransaction newUUID (UnionPreferMergeStrategy preferHead) graph t2 = undefined
269280
270281-- | 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.
@@ -334,14 +345,13 @@ mergeTransactions newUUID parentUUID mergeStrategy (headNameA, headNameB) graph
334345 Just t -> Right t
335346 transA <- transactionForHeadErr headNameA
336347 transB <- transactionForHeadErr headNameB
337− let transAid = transactionUUID transA
338− transBid = transactionUUID transB
339348
340349 disconParent <- transactionForUUID parentUUID graph
341350 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)
342351 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
352+ subGraph' <- filterSubGraph subGraph subHeads
343353
344− case createMergeTransaction newUUID mergeStrategy subGraph (transA, transB) of
354+ case createMergeTransaction newUUID mergeStrategy subGraph' (transA, transB) of
345355 Left err -> Left (MergeTransactionError err)
346356 Right mergedTrans -> case headNameForTransaction disconParent graph of
347357 Nothing -> Left (TransactionIsNotAHeadError parentUUID)
@@ -365,4 +375,12 @@ showGraphStructureX :: TransactionGraph -> String
365375showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
366376 where
367377 folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
368− headsInfo = show $ M.map transactionUUID heads
378+ headsInfo = show $ M.map transactionUUID heads
379+
380+-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
381+filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
382+filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
383+ where
384+ validIds = S.map transactionUUID (transactionsForGraph graph)
385+ newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
386+ newHeads = M.map (filterTransaction validIds) heads
test/TransactionGraph/Merge.hs+7−1
@@ -134,4 +134,10 @@ testSelectedBranchMerge = TestCase $ do
134134 rootTrans <- assertEither $ transactionForUUID (fakeUUID 1) graph''
135135 branchBTrans <- assertMaybe (transactionForHead "branchB" graph'') "failed to find branchB head"
136136 assertEqual "head of merged transaction was removed" (transactionUUID branchBTrans) (fakeUUID 3)
137− --assertEqual "bad merge" mergedContext (transactionContext rootTrans)
137+ --assertEqual "bad merge" mergedContext (transactionContext rootTrans)
138+
139+testUnionPreferMergeStrategy :: Test
140+testUnionPreferMergeStrategy = TestCase $ undefined
141+
142+testUnionMergeStrategy :: Test
143+testUnionMergeStrategy = TestCase $ undefined