--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 :: forall k a.
(Ord k, Eq a) =>
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 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 forall a. Eq a => a -> a -> Bool
== 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
                     forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
                     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 = 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
relA
          MergePreference
PreferSecond -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
relB
          MergePreference
PreferNeither -> 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' = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
mergeErr
  --typecheck first?
  (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
unioned forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union GraphRefRelationalExpr
relA GraphRefRelationalExpr
relB)) 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 :: [RegisteredQueryName]
allNames = forall a. Set a -> [a]
S.toList (forall a. Ord a => Set a -> Set a -> Set a
S.union (forall k a. Map k a -> Set k
M.keysSet RelationVariables
relvarsA) (forall k a. Map k a -> Set k
M.keysSet RelationVariables
relvarsB))
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\RelationVariables
acc RegisteredQueryName
name -> do
            GraphRefRelationalExpr
mergedRel <- do
              let findRel :: Map RegisteredQueryName a -> Maybe a
findRel = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RegisteredQueryName
name
                  lookupA :: Maybe GraphRefRelationalExpr
lookupA = forall {a}. Map RegisteredQueryName a -> Maybe a
findRel RelationVariables
relvarsA
                  lookupB :: Maybe GraphRefRelationalExpr
lookupB = forall {a}. Map RegisteredQueryName 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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
relB 
                (Just GraphRefRelationalExpr
relA, Maybe GraphRefRelationalExpr
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
relA 
                (Maybe GraphRefRelationalExpr
Nothing, Maybe GraphRefRelationalExpr
Nothing) -> forall a. HasCallStack => [Char] -> a
error [Char]
"impossible relvar naming lookup"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RegisteredQueryName
name GraphRefRelationalExpr
mergedRel RelationVariables
acc
            ) forall k a. Map k a
M.empty [RegisteredQueryName]
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union AtomFunctions
funcsA AtomFunctions
funcsB
  MergePreference
PreferSecond -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union AtomFunctions
funcsB AtomFunctions
funcsA
  MergePreference
PreferNeither -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 RegisteredQueryName
allFuncNames = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(TypeConstructorDef
tc,DataConstructorDefs
_) -> TypeConstructorDef -> RegisteredQueryName
TCD.name TypeConstructorDef
tc) (TypeConstructorMapping
typesA forall a. [a] -> [a] -> [a]
++ TypeConstructorMapping
typesB)
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\TypeConstructorMapping
acc RegisteredQueryName
name -> do
            let findType :: [(TypeConstructorDef, b)] -> Maybe (TypeConstructorDef, b)
findType [(TypeConstructorDef, b)]
tcm = case forall a. (a -> Bool) -> [a] -> [a]
filter (\(TypeConstructorDef
t,b
_) -> TypeConstructorDef -> RegisteredQueryName
TCD.name TypeConstructorDef
t forall a. Eq a => a -> a -> Bool
== RegisteredQueryName
name) [(TypeConstructorDef, b)]
tcm of
                  [] -> forall a. Maybe a
Nothing
                  [(TypeConstructorDef, b)
x] -> forall a. a -> Maybe a
Just (TypeConstructorDef, b)
x
                  [(TypeConstructorDef, b)]
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"multiple names matching in TypeConstructorMapping for " forall a. Semigroup a => a -> a -> a
<> RegisteredQueryName -> [Char]
T.unpack RegisteredQueryName
name
                lookupA :: Maybe (TypeConstructorDef, DataConstructorDefs)
lookupA = forall {b}.
[(TypeConstructorDef, b)] -> Maybe (TypeConstructorDef, b)
findType TypeConstructorMapping
typesA
                lookupB :: Maybe (TypeConstructorDef, DataConstructorDefs)
lookupB = forall {b}.
[(TypeConstructorDef, b)] -> Maybe (TypeConstructorDef, b)
findType TypeConstructorMapping
typesB
                cat :: (TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
t = forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TypeConstructorDef, DataConstructorDefs)
t 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) -> forall a. HasCallStack => [Char] -> a
error [Char]
"type name lookup failure"
               (Just (TypeConstructorDef, DataConstructorDefs)
typeA, Maybe (TypeConstructorDef, DataConstructorDefs)
Nothing) -> forall {f :: * -> *}.
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeA
               (Maybe (TypeConstructorDef, DataConstructorDefs)
Nothing, Just (TypeConstructorDef, DataConstructorDefs)
typeB) -> forall {f :: * -> *}.
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeB
               (Just (TypeConstructorDef, DataConstructorDefs)
typeA, Just (TypeConstructorDef, DataConstructorDefs)
typeB) -> if (TypeConstructorDef, DataConstructorDefs)
typeA forall a. Eq a => a -> a -> Bool
== (TypeConstructorDef, DataConstructorDefs)
typeB then
                                             forall {f :: * -> *}.
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeA
                                           else --merge conflict
                                             case MergePreference
prefer of 
                                               MergePreference
PreferFirst -> forall {f :: * -> *}.
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeA
                                               MergePreference
PreferSecond -> forall {f :: * -> *}.
Applicative f =>
(TypeConstructorDef, DataConstructorDefs)
-> f TypeConstructorMapping
cat (TypeConstructorDef, DataConstructorDefs)
typeB
                                               MergePreference
PreferNeither -> forall a b. a -> Either a b
Left MergeError
StrategyViolatesTypeConstructorMergeError
            ) [] (forall a. Set a -> [a]
S.toList Set RegisteredQueryName
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union DatabaseContextFunctions
funcsA DatabaseContextFunctions
funcsB
  MergePreference
PreferSecond -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union DatabaseContextFunctions
funcsB DatabaseContextFunctions
funcsA
  MergePreference
PreferNeither -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union DatabaseContextFunctions
funcsA DatabaseContextFunctions
funcsB

unionMergeRegisteredQueries :: MergePreference -> RegisteredQueries -> RegisteredQueries -> Either MergeError RegisteredQueries
unionMergeRegisteredQueries :: MergePreference
-> RegisteredQueries
-> RegisteredQueries
-> Either MergeError RegisteredQueries
unionMergeRegisteredQueries MergePreference
prefer RegisteredQueries
regQsA RegisteredQueries
regQsB =
  case MergePreference
prefer of
    MergePreference
PreferFirst -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union RegisteredQueries
regQsA RegisteredQueries
regQsB)
    MergePreference
PreferSecond -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union RegisteredQueries
regQsB RegisteredQueries
regQsA)
    MergePreference
PreferNeither -> do
      let isect :: Map RegisteredQueryName Bool
isect = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey (\RegisteredQueryName
qname RelationalExpr
val -> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RegisteredQueryName
qname RegisteredQueries
regQsB forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just RelationalExpr
val) (forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.intersection RegisteredQueries
regQsA RegisteredQueries
regQsB)
      --if the values in the intersection are the same, we can merge them      
      if forall k a. Map k a -> Bool
M.null Map RegisteredQueryName Bool
isect then
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union RegisteredQueries
regQsA RegisteredQueries
regQsB)
        else
        forall a b. a -> Either a b
Left ([RegisteredQueryName] -> MergeError
StrategyViolatesRegisteredQueryMergeError (forall k a. Map k a -> [k]
M.keys Map RegisteredQueryName Bool
isect))