38cee47 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP merge transaction treatment

commit38cee478fec818aff14e005087347bef832c8225 authorAgentM <agentm@themactionfaction.com> dateSun 3 May 2020, 13:46 (6 years ago) parent584b01d

3 files changed+29−22

compare with master

unifiedsplit

src/lib/ProjectM36/RelationalExpression.hs+1−1 src/lib/ProjectM36/TransactionGraph.hs+23−17 src/lib/ProjectM36/TransactionGraph/Merge.hs+5−4

src/lib/ProjectM36/RelationalExpression.hs+1−1

@@ -186,7 +186,7 @@ gfDatabaseContextForMarker (TransactionMarker transId) = concreteDatabaseContext

186186gfDatabaseContextForMarker UncommittedContextMarker = do

187187 mctx <- gre_context <$> askEnv

188188 case mctx of

189− Nothing -> throwError (traceStack "relexpr" NoUncommittedContextInEvalError)

189+ Nothing -> throwError NoUncommittedContextInEvalError

190190 Just ctx -> pure ctx

191191

192192runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a

src/lib/ProjectM36/TransactionGraph.hs+23−17

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleContexts #-}

22module ProjectM36.TransactionGraph where

33import ProjectM36.Base

44import ProjectM36.Error

@@ -10,14 +10,14 @@ import ProjectM36.Tuple

1010import ProjectM36.RelationalExpression

1111import ProjectM36.TransactionGraph.Merge

1212import qualified ProjectM36.DisconnectedTransaction as Discon

13+import qualified ProjectM36.Attribute as A

1314

15+import Control.Monad.Except hiding (join)

1416import qualified Data.Vector as V

15−import qualified ProjectM36.Attribute as A

1617import qualified Data.UUID as U

1718import qualified Data.Set as S

1819import qualified Data.Map as M

1920import qualified Data.List.NonEmpty as NE

20−import Control.Monad

2121import Data.Time.Clock

2222import qualified Data.Text as T

2323import GHC.Generics

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

264264 where

265265 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)

266266

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

267+evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = runGraphRefRelationalExprM env (mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB))

268+ where

269+ env = freshGraphRefRelationalExprEnv Nothing graph

268270

269271evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of

270272 Nothing -> Left (NoSuchHeadNameError branchName)

@@ -388,26 +390,30 @@ pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

388390 else --we have some paths!

389391 Right (S.unions paths)

390392

391−mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

392−mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph = do

393+mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> GraphRefRelationalExprM (DisconnectedTransaction, TransactionGraph)

394+mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = do

395+ graph <- gfGraph

393396 let transactionForHeadErr name = case transactionForHead name graph of

394− Nothing -> Left (NoSuchHeadNameError name)

395− Just t -> Right t

396− transA <- transactionForHeadErr headNameA

397− transB <- transactionForHeadErr headNameB

398− disconParent <- transactionForId parentId graph

397+ Nothing -> throwError (NoSuchHeadNameError name)

398+ Just t -> pure t

399+ runE e = case e of

400+ Left e' -> throwError e'

401+ Right v -> pure v

402+ transA <- transactionForHeadErr headNameA

403+ transB <- transactionForHeadErr headNameB

404+ disconParent <- gfTransForId parentId

399405 let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)

400− subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty

401− subGraph' <- filterSubGraph subGraph subHeads

406+ subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty

407+ subGraph' <- runE $ filterSubGraph subGraph subHeads

402408 case createMergeTransaction stamp' newId mergeStrategy subGraph' (transA, transB) of

403− Left err -> Left (MergeTransactionError err)

409+ Left err -> throwError (MergeTransactionError err)

404410 Right mergedTrans ->

405411 case headNameForTransaction disconParent graph of

406− Nothing -> Left (TransactionIsNotAHeadError parentId)

412+ Nothing -> throwError (TransactionIsNotAHeadError parentId)

407413 Just headName -> do

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

414+ (newTrans, newGraph) <- runE $ addTransactionToGraph headName mergedTrans graph

409415 case checkConstraints (concreteDatabaseContext mergedTrans) newId graph of

410− Left err -> Left err

416+ Left err -> throwError err

411417 Right _ -> do

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

413419 newDiscon = Discon.freshTransaction newId (schemas newTrans)

src/lib/ProjectM36/TransactionGraph/Merge.hs+5−4

@@ -2,6 +2,7 @@

22module ProjectM36.TransactionGraph.Merge where

33import ProjectM36.Base

44import ProjectM36.Error

5+import ProjectM36.RelationalExpression

56import qualified Data.Set as S

67import qualified Data.Map as M

78import qualified ProjectM36.TypeConstructorDef as TCD

@@ -34,8 +35,8 @@ unionMergeRelation prefer relA relB = case relA `union` relB of

3435 PreferNeither -> Left StrategyViolatesRelationVariableMergeError

3536

3637--try to execute unions against the relvars contents -- if a relvar only appears in one context, include it

37−unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> Either MergeError RelationVariables

38−unionMergeRelVars _ relvarsA relvarsB = do

38+unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> GraphRefRelationalExprM RelationVariables

39+unionMergeRelVars prefer relvarsA relvarsB = do

3940 let allNames = S.toList (S.union (M.keysSet relvarsA) (M.keysSet relvarsB))

4041 foldM (\acc name -> do

4142 mergedRel <- do

@@ -43,8 +44,8 @@ unionMergeRelVars _ relvarsA relvarsB = do

4344 lookupA = findRel relvarsA

4445 lookupB = findRel relvarsB

4546 case (lookupA, lookupB) of

46− (Just _, Just _) -> unimplemented

47− --unionMergeRelation prefer relA relB

47+ (Just relA, Just relB) ->

48+ unionMergeRelation prefer relA relB

4849 (Nothing, Just relB) -> pure relB

4950 (Just relA, Nothing) -> pure relA

5051 (Nothing, Nothing) -> error "impossible relvar naming lookup"