TransGraphRelationalExpression.hs

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--really, a better name for this module could be "TransTransactionGraphRelationalExpr", but that name is too long
module ProjectM36.TransGraphRelationalExpression where
import ProjectM36.Base
import ProjectM36.TransactionGraph.Types
import ProjectM36.TransactionGraph
import ProjectM36.Transaction.Types
import ProjectM36.Error
import qualified Data.Map as M
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Data.Functor.Identity

-- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time).
type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup

type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup

type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup

type TransGraphTupleExpr = TupleExprBase TransactionIdLookup

type TransGraphTupleExprs = TupleExprsBase TransactionIdLookup

type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup

type TransGraphAtomExpr = AtomExprBase TransactionIdLookup

type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup

newtype TransGraphEvalEnv = TransGraphEvalEnv {
  tge_graph :: TransactionGraph
  }

type TransGraphEvalMonad a = ReaderT TransGraphEvalEnv (ExceptT RelationalError Identity) a

process :: TransGraphEvalEnv -> TransGraphRelationalExpr -> Either RelationalError GraphRefRelationalExpr
process env texpr = runIdentity (runExceptT (runReaderT (processTransGraphRelationalExpr texpr) env))

liftE :: Either RelationalError a -> TransGraphEvalMonad a
liftE = lift . except

askGraph :: TransGraphEvalMonad TransactionGraph
askGraph = tge_graph <$> ask

findTransId :: TransactionIdLookup -> TransGraphEvalMonad GraphRefTransactionMarker
findTransId tlook = TransactionMarker . transactionId <$> findTrans tlook

findTrans :: TransactionIdLookup -> TransGraphEvalMonad Transaction
findTrans tlook = do
  graph <- askGraph
  liftE $ lookupTransaction graph tlook

-- OUTDATED a previous attempt at this function attempted to convert TransGraphRelationalExpr to RelationalExpr by resolving the transaction lookups. However, there is no way to resolve a FunctionAtomExpr to an Atom without fully evaluating the higher levels (TupleExpr, etc.). An anonymous function expression cannot be serialized, so that workaround is out. Still, I suspect we can reuse the existing static optimizer logic to work on both structures. The current conversion reduces the chance of whole-query optimization due to full-evaluation on top of full-evaluation, so this function would benefit from some re-design.
processTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr
processTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
  tupleExprs' <- processTransGraphTupleExprs tupleExprs
  case mAttrExprs of
    Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')
    Just attrExprs -> do
      attrExprs' <- mapM processTransGraphAttributeExpr attrExprs
      pure (MakeRelationFromExprs (Just attrExprs') tupleExprs')
processTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)
processTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)
processTransGraphRelationalExpr (RelationValuedAttribute attrName) = pure (RelationValuedAttribute attrName)
processTransGraphRelationalExpr (RelationVariable rvname transLookup) = 
  RelationVariable rvname <$> findTransId transLookup
processTransGraphRelationalExpr (Project transAttrNames expr) = 
  Project <$> processTransGraphAttributeNames transAttrNames <*> processTransGraphRelationalExpr expr
processTransGraphRelationalExpr (Union exprA exprB) =
  Union <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
processTransGraphRelationalExpr (Join exprA exprB) =
  Join <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
processTransGraphRelationalExpr (Rename attrs expr) =
  Rename attrs <$> processTransGraphRelationalExpr expr
processTransGraphRelationalExpr (Difference exprA exprB) =
  Difference <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
processTransGraphRelationalExpr (Group transAttrNames attrName expr) = 
  Group <$>
    processTransGraphAttributeNames transAttrNames <*>
    pure attrName <*>
    processTransGraphRelationalExpr expr
processTransGraphRelationalExpr (Ungroup attrName expr) = 
  Ungroup attrName <$> processTransGraphRelationalExpr expr
processTransGraphRelationalExpr (Restrict predicateExpr expr) =
  Restrict <$> evalTransGraphRestrictionPredicateExpr predicateExpr <*>
    processTransGraphRelationalExpr expr
processTransGraphRelationalExpr (Equals exprA exprB) = do  
  exprA' <- processTransGraphRelationalExpr exprA
  exprB' <- processTransGraphRelationalExpr exprB 
  pure (Equals exprA' exprB')
processTransGraphRelationalExpr (NotEquals exprA exprB) = do  
  exprA' <- processTransGraphRelationalExpr exprA 
  exprB' <- processTransGraphRelationalExpr exprB 
  pure (NotEquals exprA' exprB')
processTransGraphRelationalExpr (Extend extendExpr expr) = do
  extendExpr' <- processTransGraphExtendTupleExpr extendExpr 
  expr' <- processTransGraphRelationalExpr expr 
  pure (Extend extendExpr' expr')
processTransGraphRelationalExpr (With views expr) = do
  evaldViews <- mapM (\(wnexpr, vexpr) -> do
                         wnexpr' <- processTransGraphWithNameExpr wnexpr
                         vexpr' <- processTransGraphRelationalExpr vexpr 
                         pure (wnexpr', vexpr')
                     ) views
  expr' <- processTransGraphRelationalExpr expr 
  pure (With evaldViews expr')

processTransGraphTupleExprs :: TransGraphTupleExprs -> TransGraphEvalMonad GraphRefTupleExprs
processTransGraphTupleExprs (TupleExprs marker texprs) =
  TupleExprs <$> findTransId marker <*> mapM processTransGraphTupleExpr texprs

processTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr
processTransGraphTupleExpr (TupleExpr attrMap) = do
  let attrAssoc = mapM (\(attrName, atomExpr) -> do 
                        aExpr <- processTransGraphAtomExpr atomExpr
                        pure (attrName, aExpr)
                    ) (M.toList attrMap)
  TupleExpr . M.fromList <$> attrAssoc
  
processTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr
processTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname
processTransGraphAtomExpr (SubrelationAttributeAtomExpr relAttr subAttr) = pure $ SubrelationAttributeAtomExpr relAttr subAttr
processTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
processTransGraphAtomExpr (FunctionAtomExpr funcName' args tLookup) =
  FunctionAtomExpr funcName' <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup
processTransGraphAtomExpr (RelationAtomExpr expr) =
  RelationAtomExpr <$> processTransGraphRelationalExpr expr
processTransGraphAtomExpr (IfThenAtomExpr ifE thenE elseE) =
  IfThenAtomExpr <$> processTransGraphAtomExpr ifE <*> processTransGraphAtomExpr thenE <*> processTransGraphAtomExpr elseE
processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =
  ConstructedAtomExpr dConsName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup
evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr
evalTransGraphRestrictionPredicateExpr TruePredicate = pure TruePredicate
evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) = do
  exprA' <- evalTransGraphRestrictionPredicateExpr exprA
  exprB' <- evalTransGraphRestrictionPredicateExpr exprB
  pure (AndPredicate exprA' exprB')
evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) = do  
  exprA' <- evalTransGraphRestrictionPredicateExpr exprA 
  exprB' <- evalTransGraphRestrictionPredicateExpr exprB
  pure (OrPredicate exprA' exprB')
evalTransGraphRestrictionPredicateExpr (NotPredicate expr) = do
  let expr' = evalTransGraphRestrictionPredicateExpr expr
  NotPredicate <$> expr'
evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) = do  
  let expr' = processTransGraphRelationalExpr expr
  RelationalExprPredicate <$> expr'
evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) = do
  let expr' = processTransGraphAtomExpr expr
  AtomExprPredicate <$> expr'
evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) = do  
  let expr' = processTransGraphAtomExpr expr
  AttributeEqualityPredicate attrName <$> expr'
  
processTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr
processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) =
  AttributeExtendTupleExpr attrName <$> processTransGraphAtomExpr expr

processTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr
processTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =
  AttributeAndTypeNameExpr attrName tCons <$> findTransId tLookup
processTransGraphAttributeExpr (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)  

processTransGraphAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames
processTransGraphAttributeNames (AttributeNames names) = pure (AttributeNames names)
processTransGraphAttributeNames (InvertedAttributeNames names) = pure (InvertedAttributeNames names)
processTransGraphAttributeNames (UnionAttributeNames namesA namesB) = do
  nA <- processTransGraphAttributeNames namesA 
  nB <- processTransGraphAttributeNames namesB
  pure (UnionAttributeNames nA nB)
processTransGraphAttributeNames (IntersectAttributeNames namesA namesB) = do
  nA <- processTransGraphAttributeNames namesA 
  nB <- processTransGraphAttributeNames namesB 
  pure (IntersectAttributeNames nA nB)
processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do
  evaldExpr <- processTransGraphRelationalExpr expr 
  pure (RelationalExprAttributeNames evaldExpr)

processTransGraphWithNameExpr :: TransGraphWithNameExpr -> TransGraphEvalMonad GraphRefWithNameExpr
processTransGraphWithNameExpr (WithNameExpr rvname tlookup) =
  WithNameExpr rvname <$> findTransId tlookup