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

git.iko.soy/project-m36

refactoring checkpoint

commit3ac630e04a1891f886f65e953bab571646b37978 authorAgentM <agentm@themactionfaction.com> dateSat 13 Apr 2019, 22:47 (8 years ago) parent52182bc

8 files changed+111−49

compare with master

unifiedsplit

src/lib/ProjectM36/Base.hs+22−20 src/lib/ProjectM36/DisconnectedTransaction.hs+11−1 src/lib/ProjectM36/Session.hs+3−2 src/lib/ProjectM36/Transaction.hs+14−7 src/lib/ProjectM36/TransactionDiffs.hs+5 src/lib/ProjectM36/TransactionGraph.hs+25−19 src/lib/ProjectM36/TransactionGraph/Types.hs+12 src/lib/ProjectM36/TransactionInfo.hs+19

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

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

305305--used for returning information about individual expressions

306306type DatabaseContextExprName = StringType

307307

308+type DatabaseContextExpr = DatabaseContextExprBase ()

309+

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

309−data DatabaseContextExpr =

311+data DatabaseContextExprBase a =

310312 NoOperation |

311313 Define RelVarName [AttributeExpr] |

312314 Undefine RelVarName | --forget existence of relvar X

313− Assign RelVarName RelationalExpr |

314− Insert RelVarName RelationalExpr |

315+ Assign RelVarName (RelationalExprBase a) |

316+ Insert RelVarName (RelationalExprBase a) |

315317 Delete RelVarName RestrictionPredicateExpr |

316318 Update RelVarName AttributeNameAtomExprMap RestrictionPredicateExpr |

317319

318320 AddInclusionDependency IncDepName InclusionDependency |

319321 RemoveInclusionDependency IncDepName |

320322

321− AddNotification NotificationName RelationalExpr RelationalExpr RelationalExpr |

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

322324 RemoveNotification NotificationName |

323325

324326 AddTypeConstructor TypeConstructorDef [DataConstructorDef] |

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

331333

332334 ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExpr] |

333335

334− MultipleExpr [DatabaseContextExpr]

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

336+ MultipleExpr [DatabaseContextExprBase a]

337+ deriving (Show, Eq, Generic)

338+

339+instance Binary DatabaseContextExpr

336340

337341type ObjModuleName = StringType

338342type ObjFunctionName = StringType

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

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

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

371375

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

373−transactionsForGraph (TransactionGraph _ t) = t

374−

375−transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

376−transactionHeadsForGraph (TransactionGraph heads _) = heads

377−

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

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

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

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

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

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

381380 deriving(Show, Generic)

382−

381+

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

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

384+

383385instance Binary TransactionInfo

384386

385387-- | 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

387389

388390data Transaction = Transaction TransactionId TransactionInfo Schemas

389391

390−--instance Binary Transaction

391−

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.

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+

392396type DirtyFlag = Bool

393397

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.

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

398+type TransactionDiffExpr = DatabaseContextExpr

397399

398400transactionId :: Transaction -> TransactionId

399401transactionId (Transaction tid _ _) = tid

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

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

88schemas (DisconnectedTransaction _ s _) = s

1010parentId :: 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

33import Data.UUID

44import qualified Data.Map as M

55import ProjectM36.Error

6+import qualified ProjectM36.DisconnectedTransaction as Discon

78type SessionId = UUID

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

1819disconnectedTransaction (Session discon _) = discon

1920

2021isDirty :: Session -> DirtyFlag

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

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

2223

2324concreteDatabaseContext :: Session -> DatabaseContext

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

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

4041 pure (Session (disconnectedTransaction session) sname)

4142 else

4243 Left (SubschemaNameNotInUseError sname)

43−

44+

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

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

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

1414

1515transactionChildIds :: Transaction -> S.Set TransactionId

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

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

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

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

1818

1919-- | 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

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

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

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

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') diffs' = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 diffs' stamp) schemas'

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.

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

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

27−filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB childIds stamp) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB 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 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)

2831

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

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

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

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

4548subschemas :: Transaction -> Subschemas

4649subschemas (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

99import ProjectM36.RelationalExpression

1010import ProjectM36.TransactionGraph.Merge

1111import qualified ProjectM36.DisconnectedTransaction as Discon

12+import qualified ProjectM36.TransactionDiffs as TD

1213

1314import qualified Data.Vector as V

1415import qualified ProjectM36.Attribute as A

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

6667 where

6768 bootstrapHeads = M.singleton "master" freshTransaction

6869 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

7071 bootstrapTransactions = S.singleton freshTransaction

7172

7273emptyTransactionGraph :: TransactionGraph

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

8687 where

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

8889

90+transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

91+transactionHeadsForGraph (TransactionGraph hs _) = hs

92+

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

94+transactionsForGraph (TransactionGraph _ ts) = ts

95+

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

9097transactionForId tid graph

9198 | tid == U.nil =

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

115122

116123

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

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

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

125+childTransactions trans = transactionsForIds (transactionChildIds trans)

120126

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

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

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

124130addBranch stamp newId newBranchName branchPointId graph = do

125131 parentTrans <- transactionForId branchPointId graph

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

127− addTransactionToGraph newBranchName newTrans graph

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

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

128134

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

130136addDisconnectedTransaction :: 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)]

132138

133139

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

135−addTransactionToGraph headName newTrans graph = do

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

141+addTransactionToGraph headName newTrans transDiffs graph = do

136142 let parentIds = transactionParentIds newTrans

137143 childIds = transactionChildIds newTrans

138144 newId = transactionId newTrans

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

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

142148 _ <- validateIds parentIds

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

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

211217 Left err -> Left err

212218 Right parentTrans -> Right (newTrans, graph)

213219 where

214− newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False

220+ newTrans = DisconnectedTransaction jumpId (schemas parentTrans) NoOperation

215221

216222-- switch from one head to another

217223evalGraphOp _ _ _ graph (JumpToHead headName) =

218224 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

220226 Right (disconnectedTrans, graph)

221227 Nothing -> Left $ NoSuchHeadNameError headName

222228

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

226232 case transactionForId jumpDest graph of

227233 Left err -> Left err

228234 Right trans -> do

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

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

230236 Right (disconnectedTrans, graph)

231237

232238-- add new head pointing to branchPoint

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

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

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

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

248− let newDiscon = DisconnectedTransaction newId schemas' False

254+ let newDiscon = Discon.freshTransaction newId schemas'

249255 case addBranch stamp newId newBranchName parentId graph of

250256 Left err -> Left err

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

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

260266 Left err-> Left err

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

262268 where

263− newDisconnectedTrans = DisconnectedTransaction newTransId schemas' False

269+ newDisconnectedTrans = Discon.freshTransaction newTransId schemas'

264270 maybeUpdatedGraph = addDisconnectedTransaction stamp newTransId headName discon graph

265271

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

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

268274 Left err -> Left err

269275 Right parentTransaction -> Right (newDiscon, graph)

270276 where

271− newDiscon = DisconnectedTransaction parentId (schemas parentTransaction) False

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

272278

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

274280

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

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

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

324330 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

326332

327333-- merge functions, relvars, individually

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

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

410416 Right _ -> case headNameForTransaction disconParent graph of

411417 Nothing -> Left (TransactionIsNotAHeadError parentId)

412418 Just headName -> do

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

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

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

415421 newDiscon = DisconnectedTransaction newId (schemas newTrans) False

416422 pure (newDiscon, newGraph')

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

468474 typeConstructorMapping = types

469475 }

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

472478

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

474480lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

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

542548

543549 pure (discon''''', graph''''')

544550

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