git.iko.soy/project-m36
on 62_python_dbapi help sign in
project-m36/src/lib/ProjectM36/TransactionGraph/Merge.hs
85 lines 4.6 kB history raw
1--Transaction Merge Engines
2module ProjectM36.TransactionGraph.Merge where
3import ProjectM36.Base
4import ProjectM36.Error
5import qualified Data.Set as S
6import qualified Data.Map as M
7import qualified ProjectM36.TypeConstructorDef as TCD
8import ProjectM36.Relation
9import Control.Monad (foldM)
10import qualified Data.HashSet as HS
12data MergePreference = PreferFirst | PreferSecond | PreferNeither
14-- Check for overlapping keys. If the values differ, try a preference resolution
15unionMergeMaps :: (Ord k, Eq a) => MergePreference -> M.Map k a -> M.Map k a -> Either MergeError (M.Map k a)
16unionMergeMaps prefer mapA mapB = case prefer of
17 PreferFirst -> pure $ M.union mapA mapB
18 PreferSecond -> pure $ M.union mapB mapA
19 PreferNeither -> if M.intersection mapA mapB == M.intersection mapA mapB then
20 pure $ M.union mapA mapB
21 else
22 Left $ StrategyViolatesComponentMergeError
24-- perform the merge even if the attributes are different- is this what we want? Obviously, we need finer-grained merge options.
25unionMergeRelation :: MergePreference -> Relation -> Relation -> Either MergeError Relation
26unionMergeRelation prefer relA relB = case union relA relB of
27 Right unionRel -> pure unionRel
28 Left (AttributeNamesMismatchError _) -> preferredRelVar
29 Left _ -> Left StrategyViolatesRelationVariableMergeError
30 where
31 preferredRelVar = case prefer of
32 PreferFirst -> Right relA
33 PreferSecond -> Right relB
34 PreferNeither -> Left StrategyViolatesRelationVariableMergeError
36--try to execute unions against the relvars contents -- if a relvar only appears in one context, include it
37unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> Either MergeError RelationVariables
38unionMergeRelVars prefer relvarsA relvarsB = do
39 let allNames = S.toList (S.union (M.keysSet relvarsA) (M.keysSet relvarsB))
40 foldM (\acc name -> do
41 mergedRel <- do
42 let findRel = M.lookup name
43 lookupA = findRel relvarsA
44 lookupB = findRel relvarsB
45 case (lookupA, lookupB) of
46 (Just relA, Just relB) -> do
47 unionMergeRelation prefer relA relB
48 (Nothing, Just relB) -> pure relB
49 (Just relA, Nothing) -> pure relA
50 (Nothing, Nothing) -> error "impossible relvar naming lookup"
51 pure $ M.insert name mergedRel acc
52 ) M.empty allNames
54-- if two functions have the same name, ensure that the functions are identical, otherwise, conflict or prefer
55--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.
56unionMergeAtomFunctions :: MergePreference -> AtomFunctions -> AtomFunctions -> Either MergeError AtomFunctions
57unionMergeAtomFunctions prefer funcsA funcsB = case prefer of
58 PreferFirst -> pure $ HS.union funcsA funcsB
59 PreferSecond -> pure $ HS.union funcsB funcsA
60 PreferNeither -> pure $ HS.union funcsA funcsB
62unionMergeTypeConstructorMapping :: MergePreference -> TypeConstructorMapping -> TypeConstructorMapping -> Either MergeError TypeConstructorMapping
63unionMergeTypeConstructorMapping prefer typesA typesB = do
64 let allFuncNames = S.fromList $ map (\(tc,_) -> TCD.name tc) (typesA ++ typesB)
65 foldM (\acc name -> do
66 let findType tcm = case filter (\(t,_) -> TCD.name t == name) tcm of
67 [] -> Nothing
68 x:[] -> Just x
69 _ -> error "multiple names matching in TypeConstructorMapping"
70 lookupA = findType typesA
71 lookupB = findType typesB
72 cat t = pure (t : acc)
73 case (lookupA, lookupB) of
74 (Nothing, Nothing) -> error "type name lookup failure"
75 (Just typeA, Nothing) -> cat typeA
76 (Nothing, Just typeB) -> cat typeB
77 (Just typeA, Just typeB) -> if typeA == typeB then
78 cat typeA
79 else --merge conflict
80 case prefer of
81 PreferFirst -> cat typeA
82 PreferSecond -> cat typeB
83 PreferNeither -> Left StrategyViolatesTypeConstructorMergeError
84 ) [] (S.toList allFuncNames)