--Transaction Merge Engines
module ProjectM36.TransactionGraph.Merge where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.RelationalExpression
import Control.Monad.Except hiding (join)
import qualified Data.Set as S
import qualified Data.Map as M
import qualified ProjectM36.TypeConstructorDef as TCD
import qualified Data.HashSet as HS
import qualified Data.Text as T

data MergePreference = PreferFirst | PreferSecond | PreferNeither

-- Check for overlapping keys. If the values differ, try a preference resolution
unionMergeMaps :: (Ord k, Eq a) => MergePreference -> M.Map k a -> M.Map k a -> Either MergeError (M.Map k a)
unionMergeMaps :: MergePreference
-> Map k a -> Map k a -> Either MergeError (Map k a)
unionMergeMaps MergePreference
prefer Map k a
mapA Map k a
mapB = case MergePreference
prefer of
  MergePreference
PreferFirst -> Map k a -> Either MergeError (Map k a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map k a -> Either MergeError (Map k a))
-> Map k a -> Either MergeError (Map k a)
forall a b. (a -> b) -> a -> b
$ Map k a -> Map k a -> Map k a
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map k a
mapA Map k a
mapB
  MergePreference
PreferSecond -> Map k a -> Either MergeError (Map k a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map k a -> Either MergeError (Map k a))
-> Map k a -> Either MergeError (Map k a)
forall a b. (a -> b) -> a -> b
$ Map k a -> Map k a -> Map k a
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map k a
mapB Map k a
mapA
  MergePreference
PreferNeither -> if Map k a -> Map k a -> Map k a
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.intersection Map k a
mapA Map k a
mapB Map k a -> Map k a -> Bool
forall a. Eq a => a -> a -> Bool
== Map k a -> Map k a -> Map k a
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.intersection Map k a
mapA Map k a
mapB then
                     Map k a -> Either MergeError (Map k a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map k a -> Either MergeError (Map k a))
-> Map k a -> Either MergeError (Map k a)
forall a b. (a -> b) -> a -> b
$ Map k a -> Map k a -> Map k a
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map k a
mapA Map k a
mapB
                   else
                     MergeError -> Either MergeError (Map k a)
forall a b. a -> Either a b
Left MergeError
StrategyViolatesComponentMergeError
                     
-- perform the merge even if the attributes are different- is this what we want? Obviously, we need finer-grained merge options.
unionMergeRelation :: MergePreference -> GraphRefRelationalExpr -> GraphRefRelationalExpr -> GraphRefRelationalExprM GraphRefRelationalExpr
unionMergeRelation :: MergePreference
-> GraphRefRelationalExpr
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM GraphRefRelationalExpr
unionMergeRelation MergePreference
prefer GraphRefRelationalExpr
relA GraphRefRelationalExpr
relB = do
  let unioned :: GraphRefRelationalExpr
unioned = GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union GraphRefRelationalExpr
relA GraphRefRelationalExpr
relB
      mergeErr :: RelationalError
mergeErr = MergeError -> RelationalError
MergeTransactionError MergeError
StrategyViolatesRelationVariableMergeError
      preferredRelVar :: GraphRefRelationalExprM GraphRefRelationalExpr
preferredRelVar =
        case MergePreference
prefer of
          MergePreference
PreferFirst -> GraphRefRelationalExpr
-> GraphRefRelationalExprM GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
relA
          MergePreference
PreferSecond -> GraphRefRelationalExpr
-> GraphRefRelationalExprM GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
relB
          MergePreference
PreferNeither -> RelationalError -> GraphRefRelationalExprM GraphRefRelationalExpr
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
mergeErr
      handler :: RelationalError -> GraphRefRelationalExprM GraphRefRelationalExpr
handler AttributeNamesMismatchError{} = GraphRefRelationalExprM GraphRefRelationalExpr
preferredRelVar
      handler RelationalError
_err' = RelationalError -> GraphRefRelationalExprM GraphRefRelationalExpr
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
mergeErr
  --typecheck first?
  (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
unioned GraphRefRelationalExprM Relation
-> GraphRefRelationalExprM GraphRefRelationalExpr
-> GraphRefRelationalExprM GraphRefRelationalExpr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GraphRefRelationalExpr
-> GraphRefRelationalExprM GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union GraphRefRelationalExpr
relA GraphRefRelationalExpr
relB)) GraphRefRelationalExprM GraphRefRelationalExpr
-> (RelationalError
    -> GraphRefRelationalExprM GraphRefRelationalExpr)
-> GraphRefRelationalExprM GraphRefRelationalExpr
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` RelationalError -> GraphRefRelationalExprM GraphRefRelationalExpr
handler

--try to execute unions against the relvars contents -- if a relvar only appears in one context, include it
unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> GraphRefRelationalExprM RelationVariables
unionMergeRelVars :: MergePreference
-> RelationVariables
-> RelationVariables
-> GraphRefRelationalExprM RelationVariables
unionMergeRelVars MergePreference
prefer RelationVariables
relvarsA RelationVariables
relvarsB = do
  let allNames :: [RelVarName]
allNames = Set RelVarName -> [RelVarName]
forall a. Set a -> [a]
S.toList (Set RelVarName -> Set RelVarName -> Set RelVarName
forall a. Ord a => Set a -> Set a -> Set a
S.union (RelationVariables -> Set RelVarName
forall k a. Map k a -> Set k
M.keysSet RelationVariables
relvarsA) (RelationVariables -> Set RelVarName
forall k a. Map k a -> Set k
M.keysSet RelationVariables
relvarsB))
  (RelationVariables
 -> RelVarName -> GraphRefRelationalExprM RelationVariables)
-> RelationVariables
-> [RelVarName]
-> GraphRefRelationalExprM RelationVariables
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\RelationVariables
acc RelVarName
name -> do
            GraphRefRelationalExpr
mergedRel <- do
              let findRel :: Map RelVarName a -> Maybe a
findRel = RelVarName -> Map RelVarName a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RelVarName
name
                  lookupA :: Maybe GraphRefRelationalExpr
lookupA = RelationVariables -> Maybe GraphRefRelationalExpr
forall a. Map RelVarName a -> Maybe a
findRel RelationVariables
relvarsA
                  lookupB :: Maybe GraphRefRelationalExpr
lookupB = RelationVariables -> Maybe GraphRefRelationalExpr
forall a. Map RelVarName a -> Maybe a
findRel RelationVariables
relvarsB
              case (Maybe GraphRefRelationalExpr
lookupA, Maybe GraphRefRelationalExpr
lookupB) of
                (Just GraphRefRelationalExpr
relA, Just GraphRefRelationalExpr
relB) -> 
                  MergePreference
-> GraphRefRelationalExpr
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM GraphRefRelationalExpr
unionMergeRelation MergePreference
prefer GraphRefRelationalExpr
relA GraphRefRelationalExpr
relB
                (Maybe GraphRefRelationalExpr
Nothing, Just GraphRefRelationalExpr
relB) -> GraphRefRelationalExpr
-> GraphRefRelationalExprM GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
relB 
                (Just GraphRefRelationalExpr
relA, Maybe GraphRefRelationalExpr
Nothing) -> GraphRefRelationalExpr
-> GraphRefRelationalExprM GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
relA 
                (Maybe GraphRefRelationalExpr
Nothing, Maybe GraphRefRelationalExpr
Nothing) -> [Char] -> GraphRefRelationalExprM GraphRefRelationalExpr
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible relvar naming lookup"
            RelationVariables -> GraphRefRelationalExprM RelationVariables
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationVariables -> GraphRefRelationalExprM RelationVariables)
-> RelationVariables -> GraphRefRelationalExprM RelationVariables
forall a b. (a -> b) -> a -> b
$ RelVarName
-> GraphRefRelationalExpr -> RelationVariables -> RelationVariables
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RelVarName
name GraphRefRelationalExpr
mergedRel RelationVariables
acc
            ) RelationVariables
forall k a. Map k a
M.empty [RelVarName]
allNames

-- if two functions have the same name, ensure that the functions are identical, otherwise, conflict or prefer
--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.
unionMergeAtomFunctions :: MergePreference -> AtomFunctions -> AtomFunctions -> Either MergeError AtomFunctions  
unionMergeAtomFunctions :: MergePreference
-> AtomFunctions
-> AtomFunctions
-> Either MergeError AtomFunctions
unionMergeAtomFunctions MergePreference
prefer AtomFunctions
funcsA AtomFunctions
funcsB = case MergePreference
prefer of
  MergePreference
PreferFirst -> AtomFunctions -> Either MergeError AtomFunctions
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomFunctions -> Either MergeError AtomFunctions)
-> AtomFunctions -> Either MergeError AtomFunctions
forall a b. (a -> b) -> a -> b
$ AtomFunctions -> AtomFunctions -> AtomFunctions
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union AtomFunctions
funcsA AtomFunctions
funcsB
  MergePreference
PreferSecond -> AtomFunctions -> Either MergeError AtomFunctions
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomFunctions -> Either MergeError AtomFunctions)
-> AtomFunctions -> Either MergeError AtomFunctions
forall a b. (a -> b) -> a -> b
$ AtomFunctions -> AtomFunctions -> AtomFunctions
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union AtomFunctions
funcsB AtomFunctions
funcsA
  MergePreference
PreferNeither -> AtomFunctions -> Either MergeError AtomFunctions
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomFunctions -> Either MergeError AtomFunctions)
-> AtomFunctions -> Either MergeError AtomFunctions
forall a b. (a -> b) -> a -> b
$ AtomFunctions -> AtomFunctions -> AtomFunctions
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union AtomFunctions
funcsA AtomFunctions
funcsB
  
unionMergeTypeConstructorMapping :: MergePreference -> TypeConstructorMapping -> TypeConstructorMapping -> Either MergeError TypeConstructorMapping  
unionMergeTypeConstructorMapping :: MergePreference
-> TypeConstructorMapping
-> TypeConstructorMapping
-> Either MergeError TypeConstructorMapping
unionMergeTypeConstructorMapping MergePreference
prefer TypeConstructorMapping
typesA TypeConstructorMapping
typesB = do
  let allFuncNames :: Set RelVarName
allFuncNames = [RelVarName] -> Set RelVarName
forall a. Ord a => [a] -> Set a
S.fromList ([RelVarName] -> Set RelVarName) -> [RelVarName] -> Set RelVarName
forall a b. (a -> b) -> a -> b
$ ((TypeConstructorDef, DataConstructorDefs) -> RelVarName)
-> TypeConstructorMapping -> [RelVarName]
forall a b. (a -> b) -> [a] -> [b]
map (\(TypeConstructorDef
tc,DataConstructorDefs
_) -> TypeConstructorDef -> RelVarName
TCD.name TypeConstructorDef
tc) (TypeConstructorMapping
typesA TypeConstructorMapping
-> TypeConstructorMapping -> TypeConstructorMapping
forall a. [a] -> [a] -> [a]
++ TypeConstructorMapping
typesB)
  (TypeConstructorMapping
 -> RelVarName -> Either MergeError TypeConstructorMapping)
-> TypeConstructorMapping
-> [RelVarName]
-> Either MergeError TypeConstructorMapping
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\TypeConstructorMapping
acc RelVarName
name -> do
            let findType :: [(TypeConstructorDef, b)] -> Maybe (TypeConstructorDef, b)
findType [(TypeConstructorDef, b)]
tcm = case ((TypeConstructorDef, b) -> Bool)
-> [(TypeConstructorDef, b)] -> [(TypeConstructorDef, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TypeConstructorDef
t,b
_) -> TypeConstructorDef -> RelVarName
TCD.name TypeConstructorDef
t RelVarName -> RelVarName -> Bool
forall a. Eq a => a -> a -> Bool
== RelVarName
name) [(TypeConstructorDef, b)]
tcm of
                  [] -> Maybe (TypeConstructorDef, b)
forall a. Maybe a
Nothing
                  [(TypeConstructorDef, b)
x] -> (TypeConstructorDef, b) -> Maybe (TypeConstructorDef, b)
forall a. a -> Maybe a
Just (TypeConstructorDef, b)
x
                  [(TypeConstructorDef, b)]
_ -> [Char] -> Maybe (TypeConstructorDef, b)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe (TypeConstructorDef, b))
-> [Char] -> Maybe (TypeConstructorDef, b)
forall a b. (a -> b) -> a -> b
$ [Char]
"multiple names matching in TypeConstructorMapping for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> RelVarName -> [Char]
T.unpack RelVarName
name
                lookupA :: Maybe (TypeConstructorDef, DataConstructorDefs)
lookupA = TypeConstructorMapping
-> Maybe (TypeConstructorDef, DataConstructorDefs)
forall b.
[(TypeConstructorDef, b)] -> Maybe (TypeConstructorDef, b)
findType TypeConstructorMapping
typesA
                lookupB :: Maybe (TypeConstructorDef, DataConstructorDefs)
lookupB = TypeConstructorMapping
-> Maybe (TypeConstructorDef, DataConstructorDefs)
forall b.
[(TypeConstructorDef, b)] -> Maybe (TypeConstructorDef, b)
findType TypeConstructorMapping
typesB
                cat :: (TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
t = TypeConstructorMapping -> f TypeConstructorMapping
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TypeConstructorDef, DataConstructorDefs)
t (TypeConstructorDef, DataConstructorDefs)
-> TypeConstructorMapping -> TypeConstructorMapping
forall a. a -> [a] -> [a]
: TypeConstructorMapping
acc)
            case (Maybe (TypeConstructorDef, DataConstructorDefs)
lookupA, Maybe (TypeConstructorDef, DataConstructorDefs)
lookupB) of
               (Maybe (TypeConstructorDef, DataConstructorDefs)
Nothing, Maybe (TypeConstructorDef, DataConstructorDefs)
Nothing) -> [Char] -> Either MergeError TypeConstructorMapping
forall a. HasCallStack => [Char] -> a
error [Char]
"type name lookup failure"
               (Just (TypeConstructorDef, DataConstructorDefs)
typeA, Maybe (TypeConstructorDef, DataConstructorDefs)
Nothing) -> (TypeConstructorDef, DataConstructorDefs)
-> Either MergeError TypeConstructorMapping
forall (f :: * -> *).
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeA
               (Maybe (TypeConstructorDef, DataConstructorDefs)
Nothing, Just (TypeConstructorDef, DataConstructorDefs)
typeB) -> (TypeConstructorDef, DataConstructorDefs)
-> Either MergeError TypeConstructorMapping
forall (f :: * -> *).
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeB
               (Just (TypeConstructorDef, DataConstructorDefs)
typeA, Just (TypeConstructorDef, DataConstructorDefs)
typeB) -> if (TypeConstructorDef, DataConstructorDefs)
typeA (TypeConstructorDef, DataConstructorDefs)
-> (TypeConstructorDef, DataConstructorDefs) -> Bool
forall a. Eq a => a -> a -> Bool
== (TypeConstructorDef, DataConstructorDefs)
typeB then
                                             (TypeConstructorDef, DataConstructorDefs)
-> Either MergeError TypeConstructorMapping
forall (f :: * -> *).
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeA
                                           else --merge conflict
                                             case MergePreference
prefer of 
                                               MergePreference
PreferFirst -> (TypeConstructorDef, DataConstructorDefs)
-> Either MergeError TypeConstructorMapping
forall (f :: * -> *).
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeA
                                               MergePreference
PreferSecond -> (TypeConstructorDef, DataConstructorDefs)
-> Either MergeError TypeConstructorMapping
forall (f :: * -> *).
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeB
                                               MergePreference
PreferNeither -> MergeError -> Either MergeError TypeConstructorMapping
forall a b. a -> Either a b
Left MergeError
StrategyViolatesTypeConstructorMergeError
            ) [] (Set RelVarName -> [RelVarName]
forall a. Set a -> [a]
S.toList Set RelVarName
allFuncNames)

unionMergeDatabaseContextFunctions :: MergePreference -> DatabaseContextFunctions -> DatabaseContextFunctions -> Either MergeError DatabaseContextFunctions
unionMergeDatabaseContextFunctions :: MergePreference
-> DatabaseContextFunctions
-> DatabaseContextFunctions
-> Either MergeError DatabaseContextFunctions
unionMergeDatabaseContextFunctions MergePreference
prefer DatabaseContextFunctions
funcsA DatabaseContextFunctions
funcsB = case MergePreference
prefer of
  MergePreference
PreferFirst -> DatabaseContextFunctions
-> Either MergeError DatabaseContextFunctions
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatabaseContextFunctions
 -> Either MergeError DatabaseContextFunctions)
-> DatabaseContextFunctions
-> Either MergeError DatabaseContextFunctions
forall a b. (a -> b) -> a -> b
$ DatabaseContextFunctions
-> DatabaseContextFunctions -> DatabaseContextFunctions
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union DatabaseContextFunctions
funcsA DatabaseContextFunctions
funcsB
  MergePreference
PreferSecond -> DatabaseContextFunctions
-> Either MergeError DatabaseContextFunctions
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatabaseContextFunctions
 -> Either MergeError DatabaseContextFunctions)
-> DatabaseContextFunctions
-> Either MergeError DatabaseContextFunctions
forall a b. (a -> b) -> a -> b
$ DatabaseContextFunctions
-> DatabaseContextFunctions -> DatabaseContextFunctions
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union DatabaseContextFunctions
funcsB DatabaseContextFunctions
funcsA
  MergePreference
PreferNeither -> DatabaseContextFunctions
-> Either MergeError DatabaseContextFunctions
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatabaseContextFunctions
 -> Either MergeError DatabaseContextFunctions)
-> DatabaseContextFunctions
-> Either MergeError DatabaseContextFunctions
forall a b. (a -> b) -> a -> b
$ DatabaseContextFunctions
-> DatabaseContextFunctions -> DatabaseContextFunctions
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union DatabaseContextFunctions
funcsA DatabaseContextFunctions
funcsB