@@ -7,7 +7,6 @@ import Control.Monad.Except hiding (join)
77import qualified Data.Set as S
88import qualified Data.Map as M
99import qualified ProjectM36.TypeConstructorDef as TCD
10−import ProjectM36.Relation
1110import Control.Monad (foldM)
1211import qualified Data.HashSet as HS
1312
@@ -24,16 +23,19 @@ unionMergeMaps prefer mapA mapB = case prefer of
2423 Left StrategyViolatesComponentMergeError
2524
2625-- 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
28−unionMergeRelation prefer relA relB = case relA `union` relB of
29− Right unionRel -> pure unionRel
30− Left (AttributeNamesMismatchError _) -> preferredRelVar
31− Left _ -> Left StrategyViolatesRelationVariableMergeError
32− where
33− preferredRelVar = case prefer of
34− PreferFirst -> Right relA
35− PreferSecond -> Right relB
36− PreferNeither -> Left StrategyViolatesRelationVariableMergeError
26+unionMergeRelation :: MergePreference -> GraphRefRelationalExpr -> GraphRefRelationalExpr -> GraphRefRelationalExprM GraphRefRelationalExpr
27+unionMergeRelation prefer relA relB = do
28+ let unioned = Union relA relB
29+ mergeErr = MergeTransactionError StrategyViolatesRelationVariableMergeError
30+ preferredRelVar =
31+ case prefer of
32+ PreferFirst -> pure relA
33+ PreferSecond -> pure relB
34+ PreferNeither -> throwError mergeErr
35+ handler AttributeNamesMismatchError{} = preferredRelVar
36+ handler _err' = throwError mergeErr
37+ --typecheck first?
38+ (evalGraphRefRelationalExpr unioned >> pure (Union relA relB)) `catchError` handler
3739
3840--try to execute unions against the relvars contents -- if a relvar only appears in one context, include it
3941unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> GraphRefRelationalExprM RelationVariables
@@ -46,11 +48,7 @@ unionMergeRelVars prefer relvarsA relvarsB = do
4648 lookupB = findRel relvarsB
4749 case (lookupA, lookupB) of
4850 (Just relA, Just relB) -> do
49− relA' <- evalGraphRefRelationalExpr relA
50− relB' <- evalGraphRefRelationalExpr relB
51− case unionMergeRelation prefer relA' relB' of
52− Left err -> throwError (MergeTransactionError err)
53− Right _merged -> pure (Union relA relB)
51+ unionMergeRelation prefer relA relB
5452 (Nothing, Just relB) -> pure relB
5553 (Just relA, Nothing) -> pure relA
5654 (Nothing, Nothing) -> error "impossible relvar naming lookup"