3ac630e · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

refactoring checkpoint

3ac630eAgentM8 years ago

src/lib/ProjectM36/Base.hs+22−20

compare with master

unifiedsplit

@@ -305,20 +305,22 @@ type AttributeNameAtomExprMap = M.Map AttributeName AtomExpr

305--used for returning information about individual expressions

306type DatabaseContextExprName = StringType

307

308+type DatabaseContextExpr = DatabaseContextExprBase ()

309+

308-- | Database context expressions modify the database context.

310-- | Database context expressions modify the database context.

309−data DatabaseContextExpr =

311+data DatabaseContextExprBase a =

310 NoOperation |

312 NoOperation |

311 Define RelVarName [AttributeExpr] |

313 Define RelVarName [AttributeExpr] |

312 Undefine RelVarName | --forget existence of relvar X

314 Undefine RelVarName | --forget existence of relvar X

313− Assign RelVarName RelationalExpr |

315+ Assign RelVarName (RelationalExprBase a) |

314− Insert RelVarName RelationalExpr |

316+ Insert RelVarName (RelationalExprBase a) |

315 Delete RelVarName RestrictionPredicateExpr |

317 Delete RelVarName RestrictionPredicateExpr |

316 Update RelVarName AttributeNameAtomExprMap RestrictionPredicateExpr |

318 Update RelVarName AttributeNameAtomExprMap RestrictionPredicateExpr |

317

319

318 AddInclusionDependency IncDepName InclusionDependency |

320 AddInclusionDependency IncDepName InclusionDependency |

319 RemoveInclusionDependency IncDepName |

321 RemoveInclusionDependency IncDepName |

320

322

321− AddNotification NotificationName RelationalExpr RelationalExpr RelationalExpr |

323+ AddNotification NotificationName (RelationalExprBase a) (RelationalExprBase a) (RelationalExprBase a) |

322 RemoveNotification NotificationName |

324 RemoveNotification NotificationName |

323

325

324 AddTypeConstructor TypeConstructorDef [DataConstructorDef] |

326 AddTypeConstructor TypeConstructorDef [DataConstructorDef] |

@@ -331,8 +333,10 @@ data DatabaseContextExpr =

331

333

332 ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExpr] |

334 ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExpr] |

333

335

334− MultipleExpr [DatabaseContextExpr]

336+ MultipleExpr [DatabaseContextExprBase a]

335− deriving (Show, Eq, Binary, Generic)

337+ deriving (Show, Eq, Generic)

338+

339+instance Binary DatabaseContextExpr

336

340

337type ObjModuleName = StringType

341type ObjModuleName = StringType

338type ObjFunctionName = StringType

342type ObjFunctionName = StringType

@@ -369,17 +373,15 @@ type TransactionHeads = M.Map HeadName Transaction

369-- | The transaction graph is the global database's state which references every committed transaction.

373-- | The transaction graph is the global database's state which references every committed transaction.

370data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

374data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

371

375

372−transactionsForGraph :: TransactionGraph -> S.Set Transaction

373−transactionsForGraph (TransactionGraph _ t) = t

374−

375−transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

376−transactionHeadsForGraph (TransactionGraph heads _) = heads

377−

378-- | Every transaction has context-specific information attached to it.

376-- | Every transaction has context-specific information attached to it.

377+-- The `TransactionDiff`s represent child/edge relationships to subsequent transactions (branches or continuations of the same branch).

379−data TransactionInfo = TransactionInfo TransactionId (S.Set TransactionId) UTCTime | -- 1 parent + n children

378+data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime | -- 1 parent + n children

380− MergeTransactionInfo TransactionId TransactionId (S.Set TransactionId) UTCTime -- 2 parents, n children

379+ MergeTransactionInfo TransactionId TransactionId TransactionDiffs UTCTime -- 2 parents, n children

381 deriving(Show, Generic)

380 deriving(Show, Generic)

382−

381+

382+-- | Each child transaction must have a corresponding difference expression.

383+type TransactionDiffs = [(TransactionId, TransactionDiffExpr)]

384+

383instance Binary TransactionInfo

385instance Binary TransactionInfo

384

386

385-- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.

387-- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.

@@ -387,13 +389,13 @@ type TransactionId = UUID

387

389

388data Transaction = Transaction TransactionId TransactionInfo Schemas

390data Transaction = Transaction TransactionId TransactionInfo Schemas

389

391

390−--instance Binary Transaction

392+-- | The disconnected transaction represents an in-progress workspace used by sessions before changes are committed. This is similar to git's "index". After a transaction is committed, it is "connected" in the transaction graph and can no longer be modified.

391−

393+data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DatabaseContextExpr

394+--the database context expression represents a difference between the disconnected transaction and its immutable parent transaction

395+

392type DirtyFlag = Bool

396type DirtyFlag = Bool

393

397

394−-- | The disconnected transaction represents an in-progress workspace used by sessions before changes are committed. This is similar to git's "index". After a transaction is committed, it is "connected" in the transaction graph and can no longer be modified.

398+type TransactionDiffExpr = DatabaseContextExpr

395−data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag --parentID, context- the context here represents the singular concrete context from the schema

396−--the dirty flag indicates that the database context has diverged from its parent's context

397

399

398transactionId :: Transaction -> TransactionId

400transactionId :: Transaction -> TransactionId

399transactionId (Transaction tid _ _) = tid

401transactionId (Transaction tid _ _) = tid

src/lib/ProjectM36/DisconnectedTransaction.hs+11−1

@@ -8,4 +8,14 @@ schemas :: DisconnectedTransaction -> Schemas

8schemas (DisconnectedTransaction _ s _) = s

10parentId :: DisconnectedTransaction -> TransactionId

11−parentId (DisconnectedTransaction pid _ _) = pid

11+parentId (DisconnectedTransaction pid _ _) = pid

12+

13+isDirty :: DisconnectedTransaction -> Bool

14+isDirty (DisconnectedTransaction _ _ NoOperation) = False

15+isDirty _ = True

16+

17+diffExpr :: DisconnectedTransaction -> DatabaseContextExpr

18+diffExpr (DisconnectedTransaction _ _ expr) = expr

19+

20+freshTransaction :: TransactionId -> Schemas -> DisconnectedTransaction

21+freshTransaction tid schemas' = DisconnectedTransaction tid schemas' NoOperation

src/lib/ProjectM36/Session.hs+3−2

@@ -3,6 +3,7 @@ import ProjectM36.Base

3import Data.UUID

4import qualified Data.Map as M

5import ProjectM36.Error

6+import qualified ProjectM36.DisconnectedTransaction as Discon

7type SessionId = UUID

8type SessionId = UUID

@@ -18,7 +19,7 @@ disconnectedTransaction :: Session -> DisconnectedTransaction

18disconnectedTransaction (Session discon _) = discon

19disconnectedTransaction (Session discon _) = discon

20isDirty :: Session -> DirtyFlag

21isDirty :: Session -> DirtyFlag

21−isDirty (Session (DisconnectedTransaction _ _ dirtyFlag) _) = dirtyFlag

22+isDirty (Session discon _) = Discon.isDirty discon

23concreteDatabaseContext :: Session -> DatabaseContext

24concreteDatabaseContext :: Session -> DatabaseContext

24concreteDatabaseContext (Session (DisconnectedTransaction _ (Schemas context _) _) _) = context

25concreteDatabaseContext (Session (DisconnectedTransaction _ (Schemas context _) _) _) = context

@@ -40,4 +41,4 @@ setSchemaName sname session = if sname == defaultSchemaName || M.member sname (s

40 pure (Session (disconnectedTransaction session) sname)

41 pure (Session (disconnectedTransaction session) sname)

41 else

42 else

42 Left (SubschemaNameNotInUseError sname)

43 Left (SubschemaNameNotInUseError sname)

43−

44+

src/lib/ProjectM36/Transaction.hs+14−7

@@ -13,18 +13,21 @@ transactionParentIds (Transaction _ (TransactionInfo pId _ _) _) = S.singleton p

13transactionParentIds (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _) = S.fromList [pId1, pId2]

15transactionChildIds :: Transaction -> S.Set TransactionId

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

16+transactionChildIds (Transaction _ (TransactionInfo _ children _) _) = S.fromList (map fst children)

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

17+transactionChildIds (Transaction _ (MergeTransactionInfo _ _ children _) _) = S.fromList (map fst children)

19-- | Create a new transaction which is identical to the original except that a new set of child transaction ids is added.

20−transactionSetChildren :: Transaction -> S.Set TransactionId -> Transaction

20+transactionSetChildren :: Transaction -> TransactionDiffs -> Transaction

21−transactionSetChildren t@(Transaction _ (TransactionInfo pId _ stamp) schemas') childIds = Transaction (transactionId t) (TransactionInfo pId childIds stamp) schemas'

21+transactionSetChildren t@(Transaction _ (TransactionInfo pId _ stamp) schemas') diffs' = Transaction (transactionId t) (TransactionInfo pId diffs' stamp) schemas'

22−transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _ stamp) schemas') childIds = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 childIds stamp) schemas'

22+transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _ stamp) schemas') diffs' = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 diffs' stamp) schemas'

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.

25filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

26−filterTransactionInfoTransactions filterIds (TransactionInfo parentId childIds stamp) = TransactionInfo (filterParent parentId filterIds) (S.intersection childIds filterIds) stamp

26+filterTransactionInfoTransactions filterIds (TransactionInfo parentId diffs' stamp) = TransactionInfo (filterParent parentId filterIds) (filterDiffs filterIds diffs') stamp

27−filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB childIds stamp) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (S.intersection childIds filterIds) stamp

27+filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB diffs' stamp) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (filterDiffs filterIds diffs') stamp

28+

29+filterDiffs :: S.Set TransactionId -> TransactionDiffs -> TransactionDiffs

30+filterDiffs filterIds = filter (\(tid,_) -> S.member tid filterIds)

29filterParent :: TransactionId -> S.Set TransactionId -> TransactionId

32filterParent :: TransactionId -> S.Set TransactionId -> TransactionId

30filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil

33filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil

@@ -44,3 +47,7 @@ schemas (Transaction _ _ schemas') = schemas'

44-- | Returns all subschemas which are isomorphic or sub-isomorphic to the concrete schema.

47-- | Returns all subschemas which are isomorphic or sub-isomorphic to the concrete schema.

45subschemas :: Transaction -> Subschemas

48subschemas :: Transaction -> Subschemas

46subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas

49subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas

50+

51+diffs :: Transaction -> TransactionDiffs

52+diffs (Transaction _ (TransactionInfo _ diffs' _) _) = diffs'

53+diffs (Transaction _ (MergeTransactionInfo _ _ diffs' _) _) = diffs'

src/lib/ProjectM36/TransactionDiffs.hsnew file+5

@@ -0,0 +1,5 @@

1+module ProjectM36.TransactionDiffs where

2+import ProjectM36.Base

4+empty :: TransactionDiffs

5+empty = []

src/lib/ProjectM36/TransactionGraph.hs+25−19

@@ -9,6 +9,7 @@ import ProjectM36.Tuple

9import ProjectM36.RelationalExpression

10import ProjectM36.TransactionGraph.Merge

11import qualified ProjectM36.DisconnectedTransaction as Discon

12+import qualified ProjectM36.TransactionDiffs as TD

13import qualified Data.Vector as V

14import qualified Data.Vector as V

14import qualified ProjectM36.Attribute as A

15import qualified ProjectM36.Attribute as A

@@ -66,7 +67,7 @@ bootstrapTransactionGraph stamp freshId context = TransactionGraph bootstrapHead

66 where

67 where

67 bootstrapHeads = M.singleton "master" freshTransaction

68 bootstrapHeads = M.singleton "master" freshTransaction

68 newSchemas = Schemas context M.empty

69 newSchemas = Schemas context M.empty

69− freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty stamp) newSchemas

70+ freshTransaction = Transaction freshId (TransactionInfo U.nil TD.empty stamp) newSchemas

70 bootstrapTransactions = S.singleton freshTransaction

71 bootstrapTransactions = S.singleton freshTransaction

72emptyTransactionGraph :: TransactionGraph

73emptyTransactionGraph :: TransactionGraph

@@ -86,6 +87,12 @@ headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchi

86 where

87 where

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

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

90+transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

91+transactionHeadsForGraph (TransactionGraph hs _) = hs

92+

93+transactionsForGraph :: TransactionGraph -> S.Set Transaction

94+transactionsForGraph (TransactionGraph _ ts) = ts

95+

89transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction

96transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction

90transactionForId tid graph

97transactionForId tid graph

91 | tid == U.nil =

98 | tid == U.nil =

@@ -115,29 +122,28 @@ parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph

115

122

116

123

117childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

124childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

118−childTransactions (Transaction _ (TransactionInfo _ children _) _) = transactionsForIds children

125+childTransactions trans = transactionsForIds (transactionChildIds trans)

119−childTransactions (Transaction _ (MergeTransactionInfo _ _ children _) _) = transactionsForIds children

120

126

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

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

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

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

123addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

129addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

124addBranch stamp newId newBranchName branchPointId graph = do

130addBranch stamp newId newBranchName branchPointId graph = do

125 parentTrans <- transactionForId branchPointId graph

131 parentTrans <- transactionForId branchPointId graph

126− let newTrans = Transaction newId (TransactionInfo branchPointId S.empty stamp) (schemas parentTrans)

132+ let newTrans = Transaction newId (TransactionInfo branchPointId TD.empty stamp) (schemas parentTrans)

127− addTransactionToGraph newBranchName newTrans graph

133+ addTransactionToGraph newBranchName newTrans [(newId, NoOperation)] graph

128

134

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

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

130addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

136addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

131−addDisconnectedTransaction stamp newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty stamp) schemas')

137+addDisconnectedTransaction stamp newId headName discon@(DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId TD.empty stamp) schemas') [(newId, Discon.diffExpr discon)]

132

138

133

139

134−addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

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

135−addTransactionToGraph headName newTrans graph = do

141+addTransactionToGraph headName newTrans transDiffs graph = do

136 let parentIds = transactionParentIds newTrans

142 let parentIds = transactionParentIds newTrans

137 childIds = transactionChildIds newTrans

143 childIds = transactionChildIds newTrans

138 newId = transactionId newTrans

144 newId = transactionId newTrans

139 validateIds ids = mapM (`transactionForId` graph) (S.toList ids)

145 validateIds ids = mapM (`transactionForId` graph) (S.toList ids)

140− addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans))

146+ addChildTransaction trans = transactionSetChildren trans (transDiffs ++ diffs trans)

141 --validate that the parent transactions are in the graph

147 --validate that the parent transactions are in the graph

142 _ <- validateIds parentIds

148 _ <- validateIds parentIds

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

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

@@ -211,12 +217,12 @@ evalGraphOp _ _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpI

211 Left err -> Left err

217 Left err -> Left err

212 Right parentTrans -> Right (newTrans, graph)

218 Right parentTrans -> Right (newTrans, graph)

213 where

219 where

214− newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False

220+ newTrans = DisconnectedTransaction jumpId (schemas parentTrans) NoOperation

215

221

216-- switch from one head to another

222-- switch from one head to another

217evalGraphOp _ _ _ graph (JumpToHead headName) =

223evalGraphOp _ _ _ graph (JumpToHead headName) =

218 case transactionForHead headName graph of

224 case transactionForHead headName graph of

219− Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in

225+ Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) NoOperation in

220 Right (disconnectedTrans, graph)

226 Right (disconnectedTrans, graph)

221 Nothing -> Left $ NoSuchHeadNameError headName

227 Nothing -> Left $ NoSuchHeadNameError headName

222

228

@@ -226,7 +232,7 @@ evalGraphOp _ _ discon graph (WalkBackToTime backTime) = do

226 case transactionForId jumpDest graph of

232 case transactionForId jumpDest graph of

227 Left err -> Left err

233 Left err -> Left err

228 Right trans -> do

234 Right trans -> do

229− let disconnectedTrans = DisconnectedTransaction (transactionId trans) (schemas trans) False

235+ let disconnectedTrans = Discon.freshTransaction (transactionId trans) (schemas trans)

230 Right (disconnectedTrans, graph)

236 Right (disconnectedTrans, graph)

231

237

232-- add new head pointing to branchPoint

238-- add new head pointing to branchPoint

@@ -245,7 +251,7 @@ evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph

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

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

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

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

247evalGraphOp stamp newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do

253evalGraphOp stamp newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do

248− let newDiscon = DisconnectedTransaction newId schemas' False

254+ let newDiscon = Discon.freshTransaction newId schemas'

249 case addBranch stamp newId newBranchName parentId graph of

255 case addBranch stamp newId newBranchName parentId graph of

250 Left err -> Left err

256 Left err -> Left err

251 Right (_, newGraph) -> Right (newDiscon, newGraph)

257 Right (_, newGraph) -> Right (newDiscon, newGraph)

@@ -260,7 +266,7 @@ evalGraphOp stamp newTransId discon@(DisconnectedTransaction parentId schemas' _

260 Left err-> Left err

266 Left err-> Left err

261 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

267 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

262 where

268 where

263− newDisconnectedTrans = DisconnectedTransaction newTransId schemas' False

269+ newDisconnectedTrans = Discon.freshTransaction newTransId schemas'

264 maybeUpdatedGraph = addDisconnectedTransaction stamp newTransId headName discon graph

270 maybeUpdatedGraph = addDisconnectedTransaction stamp newTransId headName discon graph

265

271

266-- refresh the disconnected transaction, return the same graph

272-- refresh the disconnected transaction, return the same graph

@@ -268,7 +274,7 @@ evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case tra

268 Left err -> Left err

274 Left err -> Left err

269 Right parentTransaction -> Right (newDiscon, graph)

275 Right parentTransaction -> Right (newDiscon, graph)

270 where

276 where

271− newDiscon = DisconnectedTransaction parentId (schemas parentTransaction) False

277+ newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)

272

278

273evalGraphOp stamp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph

279evalGraphOp stamp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph

274

280

@@ -322,7 +328,7 @@ evalROGraphOp discon graph ShowGraph = do

322createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

328createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

323createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

329createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

324 let selectedTrans = validateHeadName selectedBranch graph t2

330 let selectedTrans = validateHeadName selectedBranch graph t2

325− Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) . schemas <$> selectedTrans

331+ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) TD.empty stamp) . schemas <$> selectedTrans

326

332

327-- merge functions, relvars, individually

333-- merge functions, relvars, individually

328createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2

334createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2

@@ -410,7 +416,7 @@ mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) grap

410 Right _ -> case headNameForTransaction disconParent graph of

416 Right _ -> case headNameForTransaction disconParent graph of

411 Nothing -> Left (TransactionIsNotAHeadError parentId)

417 Nothing -> Left (TransactionIsNotAHeadError parentId)

412 Just headName -> do

418 Just headName -> do

413− (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph

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

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

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

415 newDiscon = DisconnectedTransaction newId (schemas newTrans) False

421 newDiscon = DisconnectedTransaction newId (schemas newTrans) False

416 pure (newDiscon, newGraph')

422 pure (newDiscon, newGraph')

@@ -468,7 +474,7 @@ createUnionMergeTransaction stamp newId strategy graph (t1,t2) = do

468 typeConstructorMapping = types

474 typeConstructorMapping = types

469 }

475 }

470 newSchemas = Schemas newContext (subschemas t1)

476 newSchemas = Schemas newContext (subschemas t1)

471− pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty stamp) newSchemas)

477+ pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) TD.empty stamp) newSchemas)

472

478

473lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

479lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

474lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

480lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

@@ -542,4 +548,4 @@ autoMergeToHead stamp (tempBranchTransId, tempCommitTransId, mergeTransId) disco

542

548

543 pure (discon''''', graph''''')

549 pure (discon''''', graph''''')

544

550

545−

551+

src/lib/ProjectM36/TransactionGraph/Types.hsnew file+12

@@ -0,0 +1,12 @@

1+module ProjectM36.TransactionGraph.Types where

2+import ProjectM36.Base

4+transactions :: TransactionGraph -> S.Set Transaction

5+transactions (TransactionGraph _ t) = t

7+transactionHeads :: TransactionGraph -> TransactionHeads

8+transactionHeads (TransactionGraph heads _) = heads

10+transactionInfoDiffs :: TransactionInfo -> TransactionDiffs

11+transactionInfoDiffs (TransactionInfo _ d _) = d

12+transactionInfoDiffs (MergeTransactionInfo _ _ d _ ) = d

src/lib/ProjectM36/TransactionInfo.hsnew file+19

@@ -0,0 +1,19 @@

1+module ProjectM36.TransactionInfo where

2+import ProjectM36.Base

3+import qualified Data.Set as S

4+import Data.Time.Clock.POSIX

6+parentTids :: TransactionInfo -> S.Set TransactionId

7+parentTids (TransactionInfo tid _ _) = S.singleton tid

8+parentTids (MergeTransactionInfo tid1 tid2 _ _) = S.fromList [tid1, tid2]

10+diffs :: TransactionInfo -> TransactionDiffs

11+diffs (TransactionInfo _ diffs _) = diffs

12+diffs (MergeTransactionInfo _ _ diffs _) = diffs

13+

14+children :: TransactionInfo -> S.Set TransactionId

15+children ti = S.fromList (map snd (diffs ti))

16+

17+stamp :: TransactionInfo -> UTCTime

18+stamp (TransactionInfo _ _ t) = t

19+stamp (MergeTransactionInfo _ _ _ t) = t