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

git.iko.soy/project-m36

on master help sign in

WIP merge transaction treatment

38cee47AgentM6 years ago

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

compare with master

unifiedsplit

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

186gfDatabaseContextForMarker UncommittedContextMarker = do

187 mctx <- gre_context <$> askEnv

188 case mctx of

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

189+ Nothing -> throwError NoUncommittedContextInEvalError

190 Just ctx -> pure ctx

191

192runGraphRefRelationalExprM :: 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 #-}

2module ProjectM36.TransactionGraph where

3import ProjectM36.Base

4import ProjectM36.Error

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

10import ProjectM36.RelationalExpression

11import ProjectM36.TransactionGraph.Merge

12import qualified ProjectM36.DisconnectedTransaction as Discon

13+import qualified ProjectM36.Attribute as A

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

14import qualified Data.Vector as V

16import qualified Data.Vector as V

15−import qualified ProjectM36.Attribute as A

16import qualified Data.UUID as U

17import qualified Data.UUID as U

17import qualified Data.Set as S

18import qualified Data.Set as S

18import qualified Data.Map as M

19import qualified Data.Map as M

19import qualified Data.List.NonEmpty as NE

20import qualified Data.List.NonEmpty as NE

20−import Control.Monad

21import Data.Time.Clock

22import qualified Data.Text as T

23import GHC.Generics

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

264 where

265 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)

266

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

268

270

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

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

270 Nothing -> Left (NoSuchHeadNameError branchName)

272 Nothing -> Left (NoSuchHeadNameError branchName)

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

388 else --we have some paths!

390 else --we have some paths!

389 Right (S.unions paths)

391 Right (S.unions paths)

390

392

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

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

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

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

395+ graph <- gfGraph

393 let transactionForHeadErr name = case transactionForHead name graph of

396 let transactionForHeadErr name = case transactionForHead name graph of

394− Nothing -> Left (NoSuchHeadNameError name)

397+ Nothing -> throwError (NoSuchHeadNameError name)

395− Just t -> Right t

398+ Just t -> pure t

399+ runE e = case e of

400+ Left e' -> throwError e'

401+ Right v -> pure v

396− transA <- transactionForHeadErr headNameA

402+ transA <- transactionForHeadErr headNameA

397− transB <- transactionForHeadErr headNameB

403+ transB <- transactionForHeadErr headNameB

398− disconParent <- transactionForId parentId graph

404+ disconParent <- gfTransForId parentId

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

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

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

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

401− subGraph' <- filterSubGraph subGraph subHeads

407+ subGraph' <- runE $ filterSubGraph subGraph subHeads

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

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

403− Left err -> Left (MergeTransactionError err)

409+ Left err -> throwError (MergeTransactionError err)

404 Right mergedTrans ->

410 Right mergedTrans ->

405 case headNameForTransaction disconParent graph of

411 case headNameForTransaction disconParent graph of

406− Nothing -> Left (TransactionIsNotAHeadError parentId)

412+ Nothing -> throwError (TransactionIsNotAHeadError parentId)

407 Just headName -> do

413 Just headName -> do

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

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

409 case checkConstraints (concreteDatabaseContext mergedTrans) newId graph of

415 case checkConstraints (concreteDatabaseContext mergedTrans) newId graph of

410− Left err -> Left err

416+ Left err -> throwError err

411 Right _ -> do

417 Right _ -> do

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

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

413 newDiscon = Discon.freshTransaction newId (schemas newTrans)

419 newDiscon = Discon.freshTransaction newId (schemas newTrans)

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

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

2module ProjectM36.TransactionGraph.Merge where

3import ProjectM36.Base

4import ProjectM36.Error

5+import ProjectM36.RelationalExpression

5import qualified Data.Set as S

6import qualified Data.Set as S

6import qualified Data.Map as M

7import qualified Data.Map as M

7import qualified ProjectM36.TypeConstructorDef as TCD

8import qualified ProjectM36.TypeConstructorDef as TCD

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

34 PreferNeither -> Left StrategyViolatesRelationVariableMergeError

35 PreferNeither -> Left StrategyViolatesRelationVariableMergeError

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

37--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 :: MergePreference -> RelationVariables -> RelationVariables -> GraphRefRelationalExprM RelationVariables

38−unionMergeRelVars _ relvarsA relvarsB = do

39+unionMergeRelVars prefer relvarsA relvarsB = do

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

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

40 foldM (\acc name -> do

41 foldM (\acc name -> do

41 mergedRel <- do

42 mergedRel <- do

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

43 lookupA = findRel relvarsA

44 lookupA = findRel relvarsA

44 lookupB = findRel relvarsB

45 lookupB = findRel relvarsB

45 case (lookupA, lookupB) of

46 case (lookupA, lookupB) of

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

47+ (Just relA, Just relB) ->

47− --unionMergeRelation prefer relA relB

48+ unionMergeRelation prefer relA relB

48 (Nothing, Just relB) -> pure relB

49 (Nothing, Just relB) -> pure relB

49 (Just relA, Nothing) -> pure relA

50 (Just relA, Nothing) -> pure relA

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

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