{-# LANGUAGE FlexibleInstances #-}
module ProjectM36.ReferencedTransactionIds where
import ProjectM36.Base
import ProjectM36.Error
import qualified ProjectM36.Transaction as T
import ProjectM36.RelationalExpression
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad (foldM)

type TransactionIds = S.Set TransactionId

-- return all transactionIds referenced recursively- can be used to create subgraph of transaction dependencies
class ReferencedTransactionIds a where
  referencedTransactionIds :: a -> TransactionIds

instance ReferencedTransactionIds a => ReferencedTransactionIds (RelationalExprBase a) where
  referencedTransactionIds :: RelationalExprBase a -> TransactionIds
referencedTransactionIds RelationalExprBase a
x = case RelationalExprBase a
x of
    MakeRelationFromExprs (Just [AttributeExprBase a]
attrExprs) TupleExprsBase a
tupleExprs ->
      forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds TupleExprsBase a
tupleExprs forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds [AttributeExprBase a]
attrExprs)
    MakeRelationFromExprs Maybe [AttributeExprBase a]
Nothing TupleExprsBase a
tupleExprs ->
      forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds TupleExprsBase a
tupleExprs
    MakeStaticRelation{} -> forall a. Set a
S.empty
    ExistingRelation{} -> forall a. Set a
S.empty
    RelationVariable RelVarName
_ a
marker -> forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds a
marker
    RelationValuedAttribute RelVarName
_ -> forall a. Set a
S.empty
    Project AttributeNamesBase a
attrNames RelationalExprBase a
expr -> forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AttributeNamesBase a
attrNames) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
expr)
    Union RelationalExprBase a
exprA RelationalExprBase a
exprB -> forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprA) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprB)
    Join RelationalExprBase a
exprA RelationalExprBase a
exprB -> forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprA) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprB)
    Rename Set (RelVarName, RelVarName)
_ RelationalExprBase a
expr -> forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
expr
    Difference RelationalExprBase a
exprA RelationalExprBase a
exprB -> forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprA) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprB)
    Group AttributeNamesBase a
attrNames RelVarName
_ RelationalExprBase a
expr -> forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AttributeNamesBase a
attrNames) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
expr)
    Ungroup RelVarName
_ RelationalExprBase a
expr -> forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
expr
    Restrict RestrictionPredicateExprBase a
pred' RelationalExprBase a
expr -> forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RestrictionPredicateExprBase a
pred') (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
expr)
    Equals RelationalExprBase a
exprA RelationalExprBase a
exprB -> forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprA) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprB)
    NotEquals RelationalExprBase a
exprA RelationalExprBase a
exprB -> forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprA) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
exprB)
    Extend ExtendTupleExprBase a
extendTupleExpr RelationalExprBase a
expr -> forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds ExtendTupleExprBase a
extendTupleExpr) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
expr)
    With WithNamesAssocsBase a
assocs RelationalExprBase a
expr -> forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
expr forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}.
(ReferencedTransactionIds a, ReferencedTransactionIds a) =>
(a, a) -> TransactionIds
tAssocs WithNamesAssocsBase a
assocs)
      where
        tAssocs :: (a, a) -> TransactionIds
tAssocs (a
withNameExpr, a
rExpr) = forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds a
withNameExpr) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds a
rExpr)

instance ReferencedTransactionIds a => ReferencedTransactionIds (AttributeExprBase a) where
  referencedTransactionIds :: AttributeExprBase a -> TransactionIds
referencedTransactionIds NakedAttributeExpr{} = forall a. Set a
S.empty
  referencedTransactionIds (AttributeAndTypeNameExpr RelVarName
_ TypeConstructor
_ a
marker) = forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds a
marker

instance ReferencedTransactionIds a => ReferencedTransactionIds (TupleExprBase a) where
  referencedTransactionIds :: TupleExprBase a -> TransactionIds
referencedTransactionIds (TupleExpr Map RelVarName (AtomExprBase a)
tMap) =
    forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [a]
M.elems Map RelVarName (AtomExprBase a)
tMap)

instance ReferencedTransactionIds a => ReferencedTransactionIds (TupleExprsBase a) where
  referencedTransactionIds :: TupleExprsBase a -> TransactionIds
referencedTransactionIds (TupleExprs a
marker [TupleExprBase a]
tupleExprs) =
    forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds a
marker forall a. a -> [a] -> [a]
: (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TupleExprBase a]
tupleExprs))

instance ReferencedTransactionIds GraphRefTransactionMarker where
  referencedTransactionIds :: GraphRefTransactionMarker -> TransactionIds
referencedTransactionIds (TransactionMarker UUID
tid) = forall a. a -> Set a
S.singleton UUID
tid
  referencedTransactionIds GraphRefTransactionMarker
UncommittedContextMarker = forall a. Set a
S.empty -- we have other methods to determine if there is an uncommitted transaction marker in the expr

instance ReferencedTransactionIds a => ReferencedTransactionIds (AttributeNamesBase a) where
  referencedTransactionIds :: AttributeNamesBase a -> TransactionIds
referencedTransactionIds AttributeNamesBase a
names =
    case AttributeNamesBase a
names of
      AttributeNames{} -> forall a. Set a
S.empty
      InvertedAttributeNames{} -> forall a. Set a
S.empty
      UnionAttributeNames AttributeNamesBase a
exprA AttributeNamesBase a
exprB ->
        forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AttributeNamesBase a
exprA) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AttributeNamesBase a
exprB)
      IntersectAttributeNames AttributeNamesBase a
exprA AttributeNamesBase a
exprB ->
        forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AttributeNamesBase a
exprA) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AttributeNamesBase a
exprB)
      RelationalExprAttributeNames RelationalExprBase a
rExpr ->
        forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
rExpr

instance ReferencedTransactionIds a => ReferencedTransactionIds (RestrictionPredicateExprBase a) where
  referencedTransactionIds :: RestrictionPredicateExprBase a -> TransactionIds
referencedTransactionIds RestrictionPredicateExprBase a
expr =
    case RestrictionPredicateExprBase a
expr of
      RestrictionPredicateExprBase a
TruePredicate -> forall a. Monoid a => a
mempty
      AndPredicate RestrictionPredicateExprBase a
exprA RestrictionPredicateExprBase a
exprB ->
        forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RestrictionPredicateExprBase a
exprA) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RestrictionPredicateExprBase a
exprB)
      OrPredicate RestrictionPredicateExprBase a
exprA RestrictionPredicateExprBase a
exprB ->
        forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RestrictionPredicateExprBase a
exprA) (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RestrictionPredicateExprBase a
exprB)
      NotPredicate RestrictionPredicateExprBase a
exprA ->
        forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RestrictionPredicateExprBase a
exprA
      RelationalExprPredicate RelationalExprBase a
rExpr ->
        forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
rExpr
      AtomExprPredicate AtomExprBase a
aExpr ->
        forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AtomExprBase a
aExpr
      AttributeEqualityPredicate RelVarName
_ AtomExprBase a
aExpr ->
        forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AtomExprBase a
aExpr

instance ReferencedTransactionIds a => ReferencedTransactionIds (ExtendTupleExprBase a) where
  referencedTransactionIds :: ExtendTupleExprBase a -> TransactionIds
referencedTransactionIds (AttributeExtendTupleExpr RelVarName
_ AtomExprBase a
aExpr) =
    forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AtomExprBase a
aExpr

instance ReferencedTransactionIds a => ReferencedTransactionIds (WithNameExprBase a) where
  referencedTransactionIds :: WithNameExprBase a -> TransactionIds
referencedTransactionIds (WithNameExpr RelVarName
_ a
marker) = forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds a
marker

instance ReferencedTransactionIds a => ReferencedTransactionIds (AtomExprBase a) where
  referencedTransactionIds :: AtomExprBase a -> TransactionIds
referencedTransactionIds AtomExprBase a
expr =
    case AtomExprBase a
expr of
      AttributeAtomExpr{} -> forall a. Monoid a => a
mempty
      NakedAtomExpr{} -> forall a. Monoid a => a
mempty
      SubrelationAttributeAtomExpr{} -> forall a. Monoid a => a
mempty
      FunctionAtomExpr RelVarName
_ [AtomExprBase a]
args a
marker ->
        forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds a
marker forall a. a -> [a] -> [a]
: (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AtomExprBase a]
args))
      RelationAtomExpr RelationalExprBase a
rExpr ->
        forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds RelationalExprBase a
rExpr
      ConstructedAtomExpr RelVarName
_ [AtomExprBase a]
args a
marker ->
        forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds a
marker forall a. a -> [a] -> [a]
: (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AtomExprBase a]
args))
      IfThenAtomExpr AtomExprBase a
ifE AtomExprBase a
thenE AtomExprBase a
elseE ->
        forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AtomExprBase a
ifE,
                  forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AtomExprBase a
thenE,
                  forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds AtomExprBase a
elseE]

-- only the relvars can reference other transactions
instance ReferencedTransactionIds DatabaseContext where
  referencedTransactionIds :: DatabaseContext -> TransactionIds
referencedTransactionIds DatabaseContext
dbc =
    forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [
    --referencedTransactionIds (inclusionDependencies dbc),
    forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds (DatabaseContext -> RelationVariables
relationVariables DatabaseContext
dbc)
    --referencedTransactionIds (atomFunctions dbc),
    --referencedTransactionIds (dbcFunctions dbc),
    --referencedTransactionIds (notifications dbc),
    --referencedTransactionIds (typeConstructorMapping dbc),
    --referencedTransactionIds (registeredQueries dbc)
    ]

instance ReferencedTransactionIds RelationVariables where
  referencedTransactionIds :: RelationVariables -> TransactionIds
referencedTransactionIds RelationVariables
relVars =
    forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a. ReferencedTransactionIds a => a -> TransactionIds
referencedTransactionIds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [a]
M.elems RelationVariables
relVars)

-- | Recurse relvars references and transaction parents to extract a subset of relevant transactions.
-- probably could do some trimming of transactions that are not referenced by relvars, but that is rare, so probably of not much benefit
-- should be trim merge parents that don't contribute to the relvars? maybe
referencedTransactionIdsForTransaction :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
referencedTransactionIdsForTransaction :: Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
referencedTransactionIdsForTransaction Transaction
trans TransactionGraph
graph
  | TransactionParents
parentIds forall a. Eq a => a -> a -> Bool
== TransactionParents
T.rootParent = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Set a
S.singleton Transaction
trans)
  | Bool
otherwise = 
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Set Transaction -> UUID -> Either RelationalError (Set Transaction)
folder (forall a. a -> Set a
S.singleton Transaction
trans) TransactionParents
parentIds
  where
    parentIds :: TransactionParents
parentIds = TransactionInfo -> TransactionParents
parents (Transaction -> TransactionInfo
transactionInfo Transaction
trans)
    folder :: Set Transaction -> UUID -> Either RelationalError (Set Transaction)
folder Set Transaction
acc UUID
transId' = do
      Transaction
trans' <- UUID -> TransactionGraph -> Either RelationalError Transaction
transactionForId UUID
transId' TransactionGraph
graph
      Set Transaction
transSet <- Transaction
-> TransactionGraph -> Either RelationalError (Set Transaction)
referencedTransactionIdsForTransaction Transaction
trans' TransactionGraph
graph
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => Set a -> Set a -> Set a
S.union Set Transaction
acc Set Transaction
transSet)