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
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
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
(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
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
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
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