@@ -10,6 +10,7 @@ import ProjectM36.Key
1010import qualified ProjectM36.DisconnectedTransaction as Discon
1111import qualified ProjectM36.DatabaseContext as DBC
1212import ProjectM36.RelationalExpression
13+import ProjectM36.StaticOptimizer
1314
1415import qualified Data.ByteString.Lazy as BS
1516import System.Exit
@@ -20,8 +21,7 @@ import qualified Data.Map as M
2021import Data.Maybe
2122import Data.Time.Clock
2223import Data.Time.Calendar
23−
24−import Control.Monad.State
24+import qualified Data.List.NonEmpty as NE
2525
2626{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
2727
@@ -61,9 +61,10 @@ basicTransactionGraph = do
6161 uuidA = fakeUUID 10
6262 uuidB = fakeUUID 11
6363 uuidRoot = fakeUUID 1
64+ parents' = uuidRoot NE.:| []
6465 rootContext = concreteDatabaseContext rootTrans
65− (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo S.empty testTime) rootContext) bsGraph
66− (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo S.empty testTime) rootContext) bsGraph'
66+ (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo parents' testTime) rootContext) bsGraph
67+ (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo parents' testTime) rootContext) bsGraph'
6768 pure bsGraph''
6869
6970addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)
@@ -107,7 +108,7 @@ testSubGraphToFirstAncestorSnipBranch = TestCase $ do
107108 baseGraph <- basicTransactionGraph
108109 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"
109110 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"
110− (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1) S.empty testTime) (concreteDatabaseContext transA)) baseGraph
111+ (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1 NE.:| []) testTime) (concreteDatabaseContext transA)) baseGraph
111112 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty
112113 assertGraph subgraph
113114 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
@@ -121,16 +122,18 @@ testSubGraphToFirstAncestorMoreTransactions = TestCase $ do
121122
122123-- add another relvar to branchB
123124 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
124− (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of
125− (Left err, _) -> assertFailure (show err) >> undefined
126− (Right (), context) -> pure context
127− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph
125+ let env = mkDatabaseContextEvalEnv (transactionId branchBTrans) graph
126+ branchBContext = concreteDatabaseContext branchBTrans
127+ updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of
128+ Left err -> assertFailure (show err) >> undefined
129+ Right st -> pure $ dbc_context st
130+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph
128131 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"
129132 assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')
130133
131134 -- add another transaction to branchA
132135 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"
133− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) (concreteDatabaseContext branchATrans)) graph'
136+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) (concreteDatabaseContext branchATrans)) graph'
134137 branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"
135138 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')
136139
@@ -148,10 +151,12 @@ testSelectedBranchMerge = TestCase $ do
148151
149152 -- add another relvar to branchB
150153 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"
151− (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of
152− (Left err, _) -> assertFailure (show err) >> undefined
153− (Right (), context) -> pure context
154− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph
154+ let env = mkDatabaseContextEvalEnv (transactionId branchBTrans) graph
155+ branchBContext = concreteDatabaseContext branchBTrans
156+ updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of
157+ Left err -> assertFailure (show err) >> undefined
158+ Right st -> pure (dbc_context st)
159+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph
155160 --create the merge transaction in the graph
156161 let eGraph' = mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'
157162
@@ -175,18 +180,21 @@ testUnionPreferMergeStrategy = TestCase $ do
175180 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "branchBTrans"
176181 branchBRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []
177182 let branchAContext = (concreteDatabaseContext branchATrans) {relationVariables = M.insert conflictRelVarName branchARelVar (relationVariables (concreteDatabaseContext branchATrans))}
178− branchARelVar = relationTrue
179− branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName branchBRelVar (relationVariables (concreteDatabaseContext branchBTrans))}
180− conflictRelVarName = "conflictRelVar"
183+ branchARelVar = ExistingRelation relationTrue
184+ branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName (ExistingRelation branchBRelVar) (relationVariables (concreteDatabaseContext branchBTrans))}
185+ conflictRelVarName = "conflictRelVar"
181186
182− (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph
183− (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph'
187+ (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) branchAContext) graph
188+ (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) branchBContext) graph'
184189 -- validate that the conflict is hidden because we preferred a branch
185190 let merged = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph''
186191 case merged of
187192 Left err -> assertFailure ("expected merge success: " ++ show err)
188− Right (discon, _) ->
189− assertEqual "branchB relvar preferred in conflict" (Just branchBRelVar) (M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon)))
193+ Right (discon, _) -> do
194+ let Just rvExpr = M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon))
195+ reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph
196+ Right rvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr)
197+ assertEqual "branchB relvar preferred in conflict" branchBRelVar rvRel
190198
191199-- try various individual component conflicts and check for merge failure
192200testUnionMergeStrategy :: Test
@@ -201,14 +209,18 @@ testUnionMergeStrategy = TestCase $ do
201209
202210 let updatedBranchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert branchBOnlyRelVarName branchBOnlyRelVar (relationVariables (concreteDatabaseContext branchBTrans)) }
203211 updatedBranchAContext = (concreteDatabaseContext branchATrans) {inclusionDependencies = M.insert branchAOnlyIncDepName branchAOnlyIncDep (inclusionDependencies (concreteDatabaseContext branchATrans)) }
204− branchBOnlyRelVar = relationTrue
212+ branchBOnlyRelVar = ExistingRelation relationTrue
205213 branchAOnlyIncDepName = "branchAOnlyIncDep"
206214 branchBOnlyRelVarName = "branchBOnlyRelVar"
207215 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)
208− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph
216+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph
209217 (discon, _) <- assertEither $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") graph'
210− assertEqual "branchBOnlyRelVar should appear in the merge" (M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))) (Just relationTrue)
211− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) updatedBranchAContext) graph'
218+ let Just rvExpr = M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))
219+ Right rvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr)
220+ reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph
221+
222+ assertEqual "branchBOnlyRelVar should appear in the merge" relationTrue rvRel
223+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) updatedBranchAContext) graph'
212224 let eMergeGraph = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''
213225 case eMergeGraph of
214226 Left err -> assertFailure ("expected merge success: " ++ show err)
@@ -216,15 +228,18 @@ testUnionMergeStrategy = TestCase $ do
216228 -- check that the new merge transaction has the correct parents
217229 mergeTrans <- assertEither $ transactionForId (fakeUUID 5) mergeGraph
218230 let mergeContext = concreteDatabaseContext mergeTrans
219− assertEqual "merge transaction parents" (transactionParentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4])
231+ assertEqual "merge transaction parents" (parentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4])
220232 -- check that the new merge tranasction has elements from both A and B branches
221− assertEqual "merge transaction relvars" (Just relationTrue) (M.lookup branchBOnlyRelVarName (relationVariables mergeContext))
233+ let Just rvExpr' = M.lookup branchBOnlyRelVarName (relationVariables mergeContext)
234+ Right rvRel' = runGraphRefRelationalExprM reEnv' (evalGraphRefRelationalExpr rvExpr')
235+ reEnv' = freshGraphRefRelationalExprEnv (Just mergeContext) graph
236+ assertEqual "merge transaction relvars" relationTrue rvRel'
222237 assertEqual "merge transaction incdeps" (Just branchAOnlyIncDep) (M.lookup branchAOnlyIncDepName (inclusionDependencies mergeContext))
223238 -- test an expected conflict- add branchBOnlyRelVar with same name but different attributes
224239 conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []
225− let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName conflictRelVar (relationVariables updatedBranchAContext) }
240+ let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName (ExistingRelation conflictRelVar) (relationVariables updatedBranchAContext) }
226241 conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"
227− (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty testTime) conflictContextA) graph''
242+ (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans NE.:| []) testTime) conflictContextA) graph''
228243 let failingMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'''
229244 case failingMerge of
230245 Right _ -> assertFailure "expected merge failure"
@@ -244,17 +259,17 @@ testUnionMergeIncDepViolation = TestCase $ do
244259 rvName = "x"
245260 Right branchArv = eRel 2
246261 Right branchBrv = eRel 3
247− branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchArv}
248− branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchBrv,
262+ branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchArv)}
263+ branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchBrv),
249264 inclusionDependencies = M.singleton incDepName incDep}
250265 incDepName = "x_key"
251266 incDep = inclusionDependencyForKey (AttributeNames (S.singleton "x")) (RelationVariable "x" ())
252267
253268
254269 --add the rv in new commits to both branches
255− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph
270+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) branchBContext) graph
256271
257− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph'
272+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) branchAContext) graph'
258273
259274 --check that the union merge fails due to a violated constraint
260275 let eMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''