@@ -7,7 +7,6 @@ import Control.Monad.Except hiding (join)
7import qualified Data.Set as S
7import qualified Data.Set as S
8import qualified Data.Map as M
8import qualified Data.Map as M
9import qualified ProjectM36.TypeConstructorDef as TCD
9import qualified ProjectM36.TypeConstructorDef as TCD
10−import ProjectM36.Relation
11import Control.Monad (foldM)
10import Control.Monad (foldM)
12import qualified Data.HashSet as HS
11import qualified Data.HashSet as HS
@@ -24,16 +23,19 @@ unionMergeMaps prefer mapA mapB = case prefer of
24 Left StrategyViolatesComponentMergeError
23 Left StrategyViolatesComponentMergeError
26-- perform the merge even if the attributes are different- is this what we want? Obviously, we need finer-grained merge options.
25-- perform the merge even if the attributes are different- is this what we want? Obviously, we need finer-grained merge options.
27−unionMergeRelation :: MergePreference -> Relation -> Relation -> Either MergeError Relation
26+unionMergeRelation :: MergePreference -> GraphRefRelationalExpr -> GraphRefRelationalExpr -> GraphRefRelationalExprM GraphRefRelationalExpr
28−unionMergeRelation prefer relA relB = case relA `union` relB of
27+unionMergeRelation prefer relA relB = do
29− Right unionRel -> pure unionRel
28+ let unioned = Union relA relB
30− Left (AttributeNamesMismatchError _) -> preferredRelVar
31− Left _ -> Left StrategyViolatesRelationVariableMergeError
29+ mergeErr = MergeTransactionError StrategyViolatesRelationVariableMergeError
33− preferredRelVar = case prefer of
30+ preferredRelVar =
34− PreferFirst -> Right relA
32+ PreferFirst -> pure relA
35− PreferSecond -> Right relB
33+ PreferSecond -> pure relB
36− PreferNeither -> Left StrategyViolatesRelationVariableMergeError
34+ PreferNeither -> throwError mergeErr
35+ handler AttributeNamesMismatchError{} = preferredRelVar
36+ handler _err' = throwError mergeErr
38+ (evalGraphRefRelationalExpr unioned >> pure (Union relA relB)) `catchError` handler
38--try to execute unions against the relvars contents -- if a relvar only appears in one context, include it
40--try to execute unions against the relvars contents -- if a relvar only appears in one context, include it
39unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> GraphRefRelationalExprM RelationVariables
41unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> GraphRefRelationalExprM RelationVariables
@@ -46,11 +48,7 @@ unionMergeRelVars prefer relvarsA relvarsB = do
46 lookupB = findRel relvarsB
48 lookupB = findRel relvarsB
47 case (lookupA, lookupB) of
49 case (lookupA, lookupB) of
48 (Just relA, Just relB) -> do
50 (Just relA, Just relB) -> do
49− relA' <- evalGraphRefRelationalExpr relA
50− relB' <- evalGraphRefRelationalExpr relB
51− case unionMergeRelation prefer relA' relB' of
51+ unionMergeRelation prefer relA relB
52− Left err -> throwError (MergeTransactionError err)
53− Right _merged -> pure (Union relA relB)
54 (Nothing, Just relB) -> pure relB
52 (Nothing, Just relB) -> pure relB
55 (Just relA, Nothing) -> pure relA
53 (Just relA, Nothing) -> pure relA
56 (Nothing, Nothing) -> error "impossible relvar naming lookup"
54 (Nothing, Nothing) -> error "impossible relvar naming lookup"