git.iko.soy/project-m36
on f7fc888 help sign in
project-m36/src/lib/ProjectM36/TransactionGraph/Merge.hs
94 lines 5.2 kB history raw
1--Transaction Merge Engines
2module ProjectM36.TransactionGraph.Merge where
3import ProjectM36.Base
4import ProjectM36.Error
5import ProjectM36.RelationalExpression
6import Control.Monad.Except hiding (join)
7import qualified Data.Set as S
8import qualified Data.Map as M
9import qualified ProjectM36.TypeConstructorDef as TCD
10import Control.Monad (foldM)
11import qualified Data.HashSet as HS
13data MergePreference = PreferFirst | PreferSecond | PreferNeither
15-- Check for overlapping keys. If the values differ, try a preference resolution
16unionMergeMaps :: (Ord k, Eq a) => MergePreference -> M.Map k a -> M.Map k a -> Either MergeError (M.Map k a)
17unionMergeMaps prefer mapA mapB = case prefer of
18 PreferFirst -> pure $ M.union mapA mapB
19 PreferSecond -> pure $ M.union mapB mapA
20 PreferNeither -> if M.intersection mapA mapB == M.intersection mapA mapB then
21 pure $ M.union mapA mapB
22 else
23 Left StrategyViolatesComponentMergeError
25-- perform the merge even if the attributes are different- is this what we want? Obviously, we need finer-grained merge options.
26unionMergeRelation :: MergePreference -> GraphRefRelationalExpr -> GraphRefRelationalExpr -> GraphRefRelationalExprM GraphRefRelationalExpr
27unionMergeRelation 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
40--try to execute unions against the relvars contents -- if a relvar only appears in one context, include it
41unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> GraphRefRelationalExprM RelationVariables
42unionMergeRelVars prefer relvarsA relvarsB = do
43 let allNames = S.toList (S.union (M.keysSet relvarsA) (M.keysSet relvarsB))
44 foldM (\acc name -> do
45 mergedRel <- do
46 let findRel = M.lookup name
47 lookupA = findRel relvarsA
48 lookupB = findRel relvarsB
49 case (lookupA, lookupB) of
50 (Just relA, Just relB) ->
51 unionMergeRelation prefer relA relB
52 (Nothing, Just relB) -> pure relB
53 (Just relA, Nothing) -> pure relA
54 (Nothing, Nothing) -> error "impossible relvar naming lookup"
55 pure $ M.insert name mergedRel acc
56 ) M.empty allNames
58-- if two functions have the same name, ensure that the functions are identical, otherwise, conflict or prefer
59--because we don't have a bytecode, there is no way to verify that function bodies are equal, so if the types match up, just choose the first function. This is a serious bug, but intractable until we have a function bytecode.
60unionMergeAtomFunctions :: MergePreference -> AtomFunctions -> AtomFunctions -> Either MergeError AtomFunctions
61unionMergeAtomFunctions prefer funcsA funcsB = case prefer of
62 PreferFirst -> pure $ HS.union funcsA funcsB
63 PreferSecond -> pure $ HS.union funcsB funcsA
64 PreferNeither -> pure $ HS.union funcsA funcsB
66unionMergeTypeConstructorMapping :: MergePreference -> TypeConstructorMapping -> TypeConstructorMapping -> Either MergeError TypeConstructorMapping
67unionMergeTypeConstructorMapping prefer typesA typesB = do
68 let allFuncNames = S.fromList $ map (\(tc,_) -> TCD.name tc) (typesA ++ typesB)
69 foldM (\acc name -> do
70 let findType tcm = case filter (\(t,_) -> TCD.name t == name) tcm of
71 [] -> Nothing
72 [x] -> Just x
73 _ -> error "multiple names matching in TypeConstructorMapping"
74 lookupA = findType typesA
75 lookupB = findType typesB
76 cat t = pure (t : acc)
77 case (lookupA, lookupB) of
78 (Nothing, Nothing) -> error "type name lookup failure"
79 (Just typeA, Nothing) -> cat typeA
80 (Nothing, Just typeB) -> cat typeB
81 (Just typeA, Just typeB) -> if typeA == typeB then
82 cat typeA
83 else --merge conflict
84 case prefer of
85 PreferFirst -> cat typeA
86 PreferSecond -> cat typeB
87 PreferNeither -> Left StrategyViolatesTypeConstructorMergeError
88 ) [] (S.toList allFuncNames)
90unionMergeDatabaseContextFunctions :: MergePreference -> DatabaseContextFunctions -> DatabaseContextFunctions -> Either MergeError DatabaseContextFunctions
91unionMergeDatabaseContextFunctions prefer funcsA funcsB = case prefer of
92 PreferFirst -> pure $ HS.union funcsA funcsB
93 PreferSecond -> pure $ HS.union funcsB funcsA
94 PreferNeither -> pure $ HS.union funcsA funcsB