a76ee6f · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

test-tutoriald passes

a76ee6fAgentM6 years ago

src/lib/ProjectM36/StaticOptimizer.hs+2

compare with master

unifiedsplit

@@ -23,6 +23,8 @@ import qualified Data.Set as S

24-- the static optimizer performs optimizations which need not take any specific-relation statistics into account

26+--import Debug.Trace

27+

26data GraphRefSOptRelationalExprEnv =

28data GraphRefSOptRelationalExprEnv =

27 GraphRefSOptRelationalExprEnv

29 GraphRefSOptRelationalExprEnv

28 {

30 {

src/lib/ProjectM36/TransactionGraph.hs+52−29

@@ -13,6 +13,7 @@ import qualified ProjectM36.DisconnectedTransaction as Discon

13import qualified ProjectM36.Attribute as A

15import Control.Monad.Except hiding (join)

16+import Control.Monad.Reader hiding (join)

16import qualified Data.Vector as V

17import qualified Data.Vector as V

17import qualified Data.UUID as U

18import qualified Data.UUID as U

18import qualified Data.Set as S

19import qualified Data.Set as S

@@ -30,6 +31,8 @@ import Data.UUID.V4

30import Data.Monoid

31import Data.Monoid

31#endif

32#endif

34+--import Debug.Trace

35+

33-- | Record a lookup for a specific transaction in the graph.

36-- | Record a lookup for a specific transaction in the graph.

34data TransactionIdLookup = TransactionIdLookup TransactionId |

37data TransactionIdLookup = TransactionIdLookup TransactionId |

35 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]

38 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]

@@ -145,10 +148,24 @@ addTransactionToGraph headName newTrans graph = do

145 unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)

148 unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)

146 --validate that the trasaction's id is unique

149 --validate that the trasaction's id is unique

147 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))

150 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))

151+ --replace all references to UncommittedTransactionMarker to new transaction id

152+ let newTrans' = newTransUncommittedReplace newTrans

153+ updatedTransSet = S.insert newTrans' (transactionsForGraph graph)

154+ updatedHeads = M.insert headName newTrans' (transactionHeadsForGraph graph)

155+ pure (newTrans', TransactionGraph updatedHeads updatedTransSet)

156+

157+--replace all occurrences of the uncommitted context marker

158+newTransUncommittedReplace :: Transaction -> Transaction

159+newTransUncommittedReplace trans@(Transaction tid tinfo (Schemas ctx sschemas)) =

160+ Transaction tid tinfo (Schemas fixedContext sschemas)

161+ where

162+ uncommittedReplace UncommittedContextMarker = TransactionMarker tid

163+ uncommittedReplace marker = marker

164+ relvars = relationVariables (concreteDatabaseContext trans)

165+ fixedRelvars = M.map (fmap uncommittedReplace) relvars

166+ fixedContext = ctx { relationVariables = traceShow ("newReplace", M.lookup "conflictrv" fixedRelvars) fixedRelvars }

167+

148

168

149− let updatedTransSet = S.insert newTrans (transactionsForGraph graph)

150− updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)

151− pure (newTrans, TransactionGraph updatedHeads updatedTransSet)

152

169

153validateGraph :: TransactionGraph -> Maybe [RelationalError]

170validateGraph :: TransactionGraph -> Maybe [RelationalError]

154validateGraph graph@(TransactionGraph _ transSet) = do

171validateGraph graph@(TransactionGraph _ transSet) = do

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

264 where

281 where

265 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)

282 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)

266

283

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

284+evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) =

285+ runGraphRefRelationalExprM env $ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB)

268 where

286 where

269 env = freshGraphRefRelationalExprEnv Nothing graph

287 env = freshGraphRefRelationalExprEnv Nothing graph

270

288

@@ -315,29 +333,32 @@ evalROGraphOp discon graph ShowGraph = do

315-}

333-}

316

334

317-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

335-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

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

336+createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction

319−createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

337+createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) t2@(trans1, trans2) = do

338+ graph <- gfGraph

320− let selectedTrans = validateHeadName selectedBranch graph t2

339+ selectedTrans <- validateHeadName selectedBranch graph t2

321− Transaction newId (TransactionInfo {

340+ pure $ Transaction newId (TransactionInfo {

322 parents = NE.fromList [transactionId trans1,

341 parents = NE.fromList [transactionId trans1,

323 transactionId trans2],

342 transactionId trans2],

324− stamp = stamp' }) . schemas <$> selectedTrans

343+ stamp = stamp' }) (schemas selectedTrans)

325

344

326-- merge functions, relvars, individually

345-- merge functions, relvars, individually

327−createMergeTransaction stamp' newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp' newId strat graph t2

346+createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =

347+ createUnionMergeTransaction stamp' newId strat t2

328

348

329-- merge function, relvars, but, on error, just take the component from the preferred branch

349-- merge function, relvars, but, on error, just take the component from the preferred branch

330−createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp' newId strat graph t2

350+createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) t2 =

351+ createUnionMergeTransaction stamp' newId strat t2

331

352

332-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.

353-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.

333−validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

354+validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction

334validateHeadName headName graph (t1, t2) =

355validateHeadName headName graph (t1, t2) =

335 case transactionForHead headName graph of

356 case transactionForHead headName graph of

336− Nothing -> Left SelectedHeadMismatchMergeError

357+ Nothing -> throwError (MergeTransactionError SelectedHeadMismatchMergeError)

337 Just trans -> if trans /= t1 && trans /= t2 then

358 Just trans -> if trans /= t1 && trans /= t2 then

338− Left SelectedHeadMismatchMergeError

359+ throwError (MergeTransactionError SelectedHeadMismatchMergeError)

339 else

360 else

340− Right trans

361+ pure trans

341

362

342-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal.

363-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal.

343subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph

364subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph

@@ -405,10 +426,8 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d

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

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

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

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

407 subGraph' <- runE $ filterSubGraph subGraph subHeads

428 subGraph' <- runE $ filterSubGraph subGraph subHeads

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

429+ mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ createMergeTransaction stamp' newId mergeStrategy (transA, transB)

409− Left err -> throwError (MergeTransactionError err)

410− Right mergedTrans ->

411− case headNameForTransaction disconParent graph of

430+ case headNameForTransaction disconParent graph of

412 Nothing -> throwError (TransactionIsNotAHeadError parentId)

431 Nothing -> throwError (TransactionIsNotAHeadError parentId)

413 Just headName -> do

432 Just headName -> do

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

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

@@ -443,25 +462,29 @@ filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet

443 newHeads = M.map (filterTransaction validIds) heads

462 newHeads = M.map (filterTransaction validIds) heads

444

463

445--helper function for commonalities in union merge

464--helper function for commonalities in union merge

446−createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

465+createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction

447−createUnionMergeTransaction stamp' newId strategy graph (t1,t2) = do

466+createUnionMergeTransaction stamp' newId strategy (t1,t2) = do

448 let contextA = concreteDatabaseContext t1

467 let contextA = concreteDatabaseContext t1

449 contextB = concreteDatabaseContext t2

468 contextB = concreteDatabaseContext t2

450−

469+ liftMergeE x = case x of

470+ Left e -> throwError (MergeTransactionError e)

471+ Right t -> pure t

472+

473+ graph <- gfGraph

451 preference <- case strategy of

474 preference <- case strategy of

452 UnionMergeStrategy -> pure PreferNeither

475 UnionMergeStrategy -> pure PreferNeither

453 UnionPreferMergeStrategy preferBranch ->

476 UnionPreferMergeStrategy preferBranch ->

454 case transactionForHead preferBranch graph of

477 case transactionForHead preferBranch graph of

455− Nothing -> Left (PreferredHeadMissingMergeError preferBranch)

478+ Nothing -> throwError (MergeTransactionError (PreferredHeadMissingMergeError preferBranch))

456 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond

479 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond

457− badStrat -> Left (InvalidMergeStrategyError badStrat)

480+ badStrat -> throwError (MergeTransactionError (InvalidMergeStrategyError badStrat))

458

481

459− incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)

482+ incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)

460 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)

483 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)

461− atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)

484+ atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)

462− notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)

485+ notifs <- liftMergeE $ unionMergeMaps preference (notifications contextA) (notifications contextB)

463− types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)

486+ types <- liftMergeE $ unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)

464− dbcFuncs <- unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)

487+ dbcFuncs <- liftMergeE $ unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)

465 -- TODO: add merge of subschemas

488 -- TODO: add merge of subschemas

466 let newContext = DatabaseContext {

489 let newContext = DatabaseContext {

467 inclusionDependencies = incDeps,

490 inclusionDependencies = incDeps,

src/lib/ProjectM36/TransactionGraph/Merge.hs+8−2

@@ -3,6 +3,7 @@ module ProjectM36.TransactionGraph.Merge where

3import ProjectM36.Base

4import ProjectM36.Error

5import ProjectM36.RelationalExpression

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

6import qualified Data.Set as S

7import qualified Data.Set as S

7import qualified Data.Map as M

8import qualified Data.Map as M

8import qualified ProjectM36.TypeConstructorDef as TCD

9import qualified ProjectM36.TypeConstructorDef as TCD

@@ -44,8 +45,13 @@ unionMergeRelVars prefer relvarsA relvarsB = do

44 lookupA = findRel relvarsA

45 lookupA = findRel relvarsA

45 lookupB = findRel relvarsB

46 lookupB = findRel relvarsB

46 case (lookupA, lookupB) of

47 case (lookupA, lookupB) of

47− (Just relA, Just relB) ->

48+ (Just relA, Just relB) -> do

49+ traceShowM ("unionMerge", relA, relB)

50+ relA' <- evalGraphRefRelationalExpr relA

51+ relB' <- evalGraphRefRelationalExpr relB

48− unionMergeRelation prefer relA relB

52+ case unionMergeRelation prefer relA' relB' of

53+ Left err -> throwError (MergeTransactionError err)

54+ Right _merged -> pure (Union relA relB)

49 (Nothing, Just relB) -> pure relB

55 (Nothing, Just relB) -> pure relB

50 (Just relA, Nothing) -> pure relA

56 (Just relA, Nothing) -> pure relA

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

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