@@ -13,6 +13,7 @@ import qualified ProjectM36.DisconnectedTransaction as Discon
1313import qualified ProjectM36.Attribute as A
1414
1515import Control.Monad.Except hiding (join)
16+import Control.Monad.Reader hiding (join)
1617import qualified Data.Vector as V
1718import qualified Data.UUID as U
1819import qualified Data.Set as S
@@ -30,6 +31,8 @@ import Data.UUID.V4
3031import Data.Monoid
3132#endif
3233
34+--import Debug.Trace
35+
3336-- | Record a lookup for a specific transaction in the graph.
3437data TransactionIdLookup = TransactionIdLookup TransactionId |
3538 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]
@@ -145,10 +148,24 @@ addTransactionToGraph headName newTrans graph = do
145148 unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)
146149 --validate that the trasaction's id is unique
147150 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))
151+ --replace all references to UncommittedTransactionMarker to new transaction id
152+ let newTrans' = newTransUncommittedReplace newTrans
153+ updatedTransSet = S.insert newTrans' (transactionsForGraph graph)
154+ updatedHeads = M.insert headName newTrans' (transactionHeadsForGraph graph)
155+ pure (newTrans', TransactionGraph updatedHeads updatedTransSet)
156+
157+--replace all occurrences of the uncommitted context marker
158+newTransUncommittedReplace :: Transaction -> Transaction
159+newTransUncommittedReplace trans@(Transaction tid tinfo (Schemas ctx sschemas)) =
160+ Transaction tid tinfo (Schemas fixedContext sschemas)
161+ where
162+ uncommittedReplace UncommittedContextMarker = TransactionMarker tid
163+ uncommittedReplace marker = marker
164+ relvars = relationVariables (concreteDatabaseContext trans)
165+ fixedRelvars = M.map (fmap uncommittedReplace) relvars
166+ fixedContext = ctx { relationVariables = traceShow ("newReplace", M.lookup "conflictrv" fixedRelvars) fixedRelvars }
167+
148168
149− let updatedTransSet = S.insert newTrans (transactionsForGraph graph)
150− updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)
151− pure (newTrans, TransactionGraph updatedHeads updatedTransSet)
152169
153170validateGraph :: TransactionGraph -> Maybe [RelationalError]
154171validateGraph graph@(TransactionGraph _ transSet) = do
@@ -264,7 +281,8 @@ evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case tra
264281 where
265282 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)
266283
267−evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = runGraphRefRelationalExprM env (mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB))
284+evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) =
285+ runGraphRefRelationalExprM env $ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB)
268286 where
269287 env = freshGraphRefRelationalExprEnv Nothing graph
270288
@@ -315,29 +333,32 @@ evalROGraphOp discon graph ShowGraph = do
315333-}
316334
317335-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
318−createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
319−createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
320− let selectedTrans = validateHeadName selectedBranch graph t2
321− Transaction newId (TransactionInfo {
336+createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
337+createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) t2@(trans1, trans2) = do
338+ graph <- gfGraph
339+ selectedTrans <- validateHeadName selectedBranch graph t2
340+ pure $ Transaction newId (TransactionInfo {
322341 parents = NE.fromList [transactionId trans1,
323342 transactionId trans2],
324− stamp = stamp' }) . schemas <$> selectedTrans
343+ stamp = stamp' }) (schemas selectedTrans)
325344
326345-- merge functions, relvars, individually
327−createMergeTransaction stamp' newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp' newId strat graph t2
346+createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =
347+ createUnionMergeTransaction stamp' newId strat t2
328348
329349-- merge function, relvars, but, on error, just take the component from the preferred branch
330−createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp' newId strat graph t2
350+createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) t2 =
351+ createUnionMergeTransaction stamp' newId strat t2
331352
332353-- | 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.
333−validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
354+validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
334355validateHeadName headName graph (t1, t2) =
335356 case transactionForHead headName graph of
336− Nothing -> Left SelectedHeadMismatchMergeError
357+ Nothing -> throwError (MergeTransactionError SelectedHeadMismatchMergeError)
337358 Just trans -> if trans /= t1 && trans /= t2 then
338− Left SelectedHeadMismatchMergeError
359+ throwError (MergeTransactionError SelectedHeadMismatchMergeError)
339360 else
340− Right trans
361+ pure trans
341362
342363-- 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.
343364subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
@@ -405,10 +426,8 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d
405426 let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)
406427 subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
407428 subGraph' <- runE $ filterSubGraph subGraph subHeads
408− case createMergeTransaction stamp' newId mergeStrategy subGraph' (transA, transB) of
409− Left err -> throwError (MergeTransactionError err)
410− Right mergedTrans ->
411− case headNameForTransaction disconParent graph of
429+ mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ createMergeTransaction stamp' newId mergeStrategy (transA, transB)
430+ case headNameForTransaction disconParent graph of
412431 Nothing -> throwError (TransactionIsNotAHeadError parentId)
413432 Just headName -> do
414433 (newTrans, newGraph) <- runE $ addTransactionToGraph headName mergedTrans graph
@@ -443,25 +462,29 @@ filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
443462 newHeads = M.map (filterTransaction validIds) heads
444463
445464--helper function for commonalities in union merge
446−createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
447−createUnionMergeTransaction stamp' newId strategy graph (t1,t2) = do
465+createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
466+createUnionMergeTransaction stamp' newId strategy (t1,t2) = do
448467 let contextA = concreteDatabaseContext t1
449468 contextB = concreteDatabaseContext t2
450−
469+ liftMergeE x = case x of
470+ Left e -> throwError (MergeTransactionError e)
471+ Right t -> pure t
472+
473+ graph <- gfGraph
451474 preference <- case strategy of
452475 UnionMergeStrategy -> pure PreferNeither
453476 UnionPreferMergeStrategy preferBranch ->
454477 case transactionForHead preferBranch graph of
455− Nothing -> Left (PreferredHeadMissingMergeError preferBranch)
478+ Nothing -> throwError (MergeTransactionError (PreferredHeadMissingMergeError preferBranch))
456479 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
457− badStrat -> Left (InvalidMergeStrategyError badStrat)
480+ badStrat -> throwError (MergeTransactionError (InvalidMergeStrategyError badStrat))
458481
459− incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
482+ incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
460483 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
461− atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
462− notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)
463− types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
464− dbcFuncs <- unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)
484+ atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
485+ notifs <- liftMergeE $ unionMergeMaps preference (notifications contextA) (notifications contextB)
486+ types <- liftMergeE $ unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
487+ dbcFuncs <- liftMergeE $ unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)
465488 -- TODO: add merge of subschemas
466489 let newContext = DatabaseContext {
467490 inclusionDependencies = incDeps,