project-m36-0.9.4: src/lib/ProjectM36/RelationalExpression.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module ProjectM36.RelationalExpression where
import ProjectM36.Relation
import ProjectM36.Tuple
import ProjectM36.TupleSet
import ProjectM36.Base
import qualified Data.UUID as U
import ProjectM36.Error
import ProjectM36.AtomType
import ProjectM36.Attribute (emptyAttributes, attributesFromList)
import ProjectM36.ScriptSession
import ProjectM36.DataTypes.Primitive
import ProjectM36.AtomFunction
import ProjectM36.DatabaseContextFunction
import ProjectM36.Arbitrary
import ProjectM36.GraphRefRelationalExpr
import ProjectM36.Transaction
import qualified ProjectM36.Attribute as A
import qualified Data.Map as M
import qualified Data.HashSet as HS
import qualified Data.Set as S
import Control.Monad.State hiding (join)
import Data.Bifunctor (second)
import Data.Maybe
import Data.Either
import Data.Char (isUpper)
import Data.Time
import qualified Data.List.NonEmpty as NE
import Data.Functor.Identity
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified ProjectM36.TypeConstructorDef as TCD
import qualified Control.Monad.RWS.Strict as RWS
import Control.Monad.RWS.Strict (RWST, execRWST, runRWST)
import Control.Monad.Except hiding (join)
import Control.Monad.Trans.Except (except)
import Control.Monad.Reader as R hiding (join)
import ProjectM36.NormalizeExpr
import ProjectM36.WithNameExpr
import ProjectM36.Function
import Test.QuickCheck
import qualified Data.Functor.Foldable as Fold
import Control.Applicative
#ifdef PM36_HASKELL_SCRIPTING
import GHC hiding (getContext)
import Control.Exception
import GHC.Paths
#endif
data DatabaseContextExprDetails = CountUpdatedTuples
databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc
databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTups
where
attrs = A.attributesFromList [Attribute "count" IntAtomType]
existingTuple = fromMaybe (error "impossible counting error in singletonTuple") (singletonTuple relIn)
existingCount = case V.head (tupleAtoms existingTuple) of
IntAtom v -> v
_ -> error "impossible counting error in tupleAtoms"
newTups = case mkTupleSetFromList attrs [[IntAtom (existingCount + 1)]] of
Left err -> error ("impossible counting error in " ++ show err)
Right ts -> ts
-- | Used to start a fresh database state for a new database context expression.
mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
mkDatabaseContextEvalState context = DatabaseContextEvalState {
dbc_context = context,
dbc_accum = M.empty,
dbc_dirty = False
} --future work: propagate return accumulator
-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
data RelationalExprEnv = RelationalExprEnv {
re_context :: DatabaseContext,
re_graph :: TransactionGraph,
re_extra :: Maybe (Either RelationTuple Attributes)
}
envTuple :: GraphRefRelationalExprEnv -> RelationTuple
envTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (gre_extra e))
envAttributes :: GraphRefRelationalExprEnv -> Attributes
envAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (gre_extra e))
instance Show RelationalExprEnv where
show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)
--used to eval relationalexpr
type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a
runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either RelationalError a
runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))
reGraph :: RelationalExprM TransactionGraph
reGraph = asks re_graph
reContext :: RelationalExprM DatabaseContext
reContext = asks re_context
mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv
mkRelationalExprEnv ctx graph =
RelationalExprEnv
{ re_context = ctx,
re_graph = graph,
re_extra = Nothing }
askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv = R.ask
mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeTuplesIntoGraphRefRelationalExprEnv tupIn env =
env { gre_extra = new_elems }
where
new_elems = Just (Left newTuple)
mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple env))
newTuple = mkRelationTupleFromMap mergedTupMap
mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeAttributesIntoGraphRefRelationalExprEnv attrsIn e = e { gre_extra = newattrs }
where
newattrs = Just (Right (A.union attrsIn (envAttributes e)))
type ResultAccumName = StringType
type ResultAccumFunc = (RelationTuple -> Relation -> Relation) -> Relation -> Relation
data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,
resultAccumResult :: Relation
}
data DatabaseContextEvalState = DatabaseContextEvalState {
dbc_context :: DatabaseContext, --new, alterable context for a new transaction
dbc_accum :: M.Map ResultAccumName ResultAccum,
dbc_dirty :: DirtyFlag
}
data DatabaseContextEvalEnv = DatabaseContextEvalEnv
{ dce_transId :: TransactionId,
dce_graph :: TransactionGraph
}
mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
mkDatabaseContextEvalEnv = DatabaseContextEvalEnv
type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a
runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState
runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> execRWST m env freshEnv))
where
freshEnv = mkDatabaseContextEvalState ctx
dbcTransId :: DatabaseContextEvalMonad TransactionId
dbcTransId = dce_transId <$> RWS.ask
dbcGraph :: DatabaseContextEvalMonad TransactionGraph
dbcGraph = dce_graph <$> RWS.ask
dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv =
mkRelationalExprEnv <$> getStateContext <*> dbcGraph
getStateContext :: DatabaseContextEvalMonad DatabaseContext
getStateContext = gets dbc_context
putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext ctx' = do
s <- get
put (s {dbc_context = ctx', dbc_dirty = True})
-- | The context is optionally passed down along in cases where the current context is uncommitted.
data GraphRefRelationalExprEnv =
GraphRefRelationalExprEnv {
gre_context :: Maybe DatabaseContext,
gre_graph :: TransactionGraph,
gre_extra :: Maybe (Either RelationTuple Attributes)
}
type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a
gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction
gfTransForId tid = do
graph <- gfGraph
lift $ except $ transactionForId tid graph
gfDatabaseContextForMarker :: GraphRefTransactionMarker -> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker (TransactionMarker transId) = concreteDatabaseContext <$> gfTransForId transId
gfDatabaseContextForMarker UncommittedContextMarker = do
mctx <- gre_context <$> askEnv
case mctx of
Nothing -> throwError NoUncommittedContextInEvalError
Just ctx -> pure ctx
runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))
freshGraphRefRelationalExprEnv :: Maybe DatabaseContext -> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv mctx graph = GraphRefRelationalExprEnv {
gre_context = mctx,
gre_graph = graph,
gre_extra = Nothing
}
gfGraph :: GraphRefRelationalExprM TransactionGraph
gfGraph = asks gre_graph
envContext :: RelationalExprEnv -> DatabaseContext
envContext = re_context
setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv
setEnvContext e ctx = e { re_context = ctx }
--helper function to process relation variable creation/assignment
setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar relVarName relExpr = do
currentContext <- getStateContext
--prevent recursive relvar definition by resolving references to relvars in previous states
relExpr' <- resolve relExpr
let newRelVars = M.insert relVarName relExpr' $ relationVariables currentContext
potentialContext = currentContext { relationVariables = newRelVars }
--optimization: if the relexpr is unchanged, skip the update
if M.lookup relVarName (relationVariables currentContext) == Just relExpr then
pure ()
else do
--determine when to check constraints
graph <- dbcGraph
tid <- dbcTransId
case checkConstraints potentialContext tid graph of
Left err -> dbErr err
Right _ -> putStateContext potentialContext
--fast-path insertion- we already know that the previous relvar validated correctly, so we can validate just the relation that is being inserted for attribute matches- without this, even a single tuple relation inserted causes the entire relation to be re-validated unnecessarily
--insertIntoRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation
deleteRelVar :: RelVarName -> DatabaseContextEvalMonad ()
deleteRelVar relVarName = do
currContext <- getStateContext
let relVars = relationVariables currContext
if M.notMember relVarName relVars then
pure ()
else do
let newRelVars = M.delete relVarName relVars
newContext = currContext { relationVariables = newRelVars }
graph <- dbcGraph
tid <- dbcTransId
case checkConstraints newContext tid graph of
Left err -> dbErr err
Right _ ->
putStateContext newContext
evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
evalGraphRefDatabaseContextExpr NoOperation = pure ()
evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do
context <- getStateContext
relvars <- fmap relationVariables getStateContext
tConss <- fmap typeConstructorMapping getStateContext
graph <- dbcGraph
let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)
gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
case eAttrs of
Left err -> dbErr err
Right attrsList -> do
lift $ except $ validateAttributes tConss (A.attributesFromList attrsList)
case M.member relVarName relvars of
True -> dbErr (RelVarAlreadyDefinedError relVarName)
False -> setRelVar relVarName (ExistingRelation emptyRelation)
where
attrs = A.attributesFromList attrsList
emptyRelation = Relation attrs emptyTupleSet
evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do
graph <- re_graph <$> dbcRelationalExprEnv
context <- getStateContext
let existingRelVar = M.lookup relVarName (relationVariables context)
reEnv = freshGraphRefRelationalExprEnv (Just context) graph
eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)
case existingRelVar of
Nothing -> do
case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of
Left err -> dbErr err
Right reltype -> do
lift $ except $ validateAttributes (typeConstructorMapping context) (attributes reltype)
setRelVar relVarName expr
Just existingRel -> do
let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)
case eExpectedType of
Left err -> dbErr err
Right expectedType ->
case eNewExprType of
Left err -> dbErr err
Right newExprType -> do
if newExprType == expectedType then do
lift $ except $ validateAttributes (typeConstructorMapping context) (attributes newExprType)
setRelVar relVarName expr
else
dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))
evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do
gfExpr <- relVarByName relVarName
let optExpr = applyUnionCollapse (Union
relExpr
gfExpr)
evalGraphRefDatabaseContextExpr (Assign relVarName optExpr)
evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do
gfExpr <- relVarByName relVarName
let optExpr = applyRestrictionCollapse (Restrict (NotPredicate predicate) gfExpr)
setRelVar relVarName optExpr
--union of restricted+updated portion and the unrestricted+unupdated portion
evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do
rvExpr <- relVarByName relVarName
graph <- re_graph <$> dbcRelationalExprEnv
context <- getStateContext
let reEnv = freshGraphRefRelationalExprEnv (Just context) graph
--get the current attributes name in the relvar to ensure that we don't conflict when renaming
eExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr rvExpr)
exprType' <- case eExprType of
Left err -> throwError err
Right t -> pure t
let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr
tmpAttr = tmpAttrC 1
tmpAttrC :: Int -> AttributeName -> AttributeName
tmpAttrC c attr =
let tmpAttrName = "_tmp_" <> T.pack (show c) <> attr in
if tmpAttrName `S.member` A.attributeNameSet (attributes exprType') then
tmpAttrC (c+1) attr
else
tmpAttrName
updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)
projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
restrictedPortion = Restrict pred' rvExpr
updated = foldr (\(oldname, atomExpr) accum ->
let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in
updateAttr oldname procAtomExpr accum
) restrictedPortion (M.toList atomExprMap)
-- the atomExprMap could reference other attributes, so we must perform multi-pass folds
updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)
setRelVar relVarName (Union unrestrictedPortion updatedPortion)
evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
currContext <- getStateContext
transId <- dbcTransId
graph <- dbcGraph
let currDeps = inclusionDependencies currContext
newDeps = M.insert newDepName newDep currDeps
if M.member newDepName currDeps then
dbErr (InclusionDependencyNameInUseError newDepName)
else do
let potentialContext = currContext { inclusionDependencies = newDeps }
-- if the potential context passes all constraints, then save it
-- potential optimization: validate only the new constraint- all old constraints must already hold
case checkConstraints potentialContext transId graph of
Left err -> dbErr err
Right _ ->
putStateContext potentialContext
evalGraphRefDatabaseContextExpr (RemoveInclusionDependency depName) = do
currContext <- getStateContext
let currDeps = inclusionDependencies currContext
newDeps = M.delete depName currDeps
if M.notMember depName currDeps then
dbErr (InclusionDependencyNameNotInUseError depName)
else
putStateContext $ currContext {inclusionDependencies = newDeps }
-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
evalGraphRefDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do
currentContext <- getStateContext
let nots = notifications currentContext
if M.member notName nots then
dbErr (NotificationNameInUseError notName)
else do
let newNotifications = M.insert notName newNotification nots
newNotification = Notification { changeExpr = triggerExpr,
reportOldExpr = resultOldExpr,
reportNewExpr = resultNewExpr}
putStateContext $ currentContext { notifications = newNotifications }
evalGraphRefDatabaseContextExpr (RemoveNotification notName) = do
currentContext <- getStateContext
let nots = notifications currentContext
if M.notMember notName nots then
dbErr (NotificationNameNotInUseError notName)
else do
let newNotifications = M.delete notName nots
putStateContext $ currentContext { notifications = newNotifications }
-- | Adds type and data constructors to the database context.
-- validate that the type *and* constructor names are unique! not yet implemented!
evalGraphRefDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
currentContext <- getStateContext
let oldTypes = typeConstructorMapping currentContext
tConsName = TCD.name tConsDef
-- validate that the constructor's types exist
case validateTypeConstructorDef tConsDef dConsDefList oldTypes of
Left err -> throwError err
Right () | T.null tConsName || not (isUpper (T.head tConsName)) -> dbErr (InvalidAtomTypeName tConsName)
| isJust (findTypeConstructor tConsName oldTypes) -> dbErr (AtomTypeNameInUseError tConsName)
| otherwise -> do
let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
putStateContext $ currentContext { typeConstructorMapping = newTypes }
-- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.
evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do
currentContext <- getStateContext
let oldTypes = typeConstructorMapping currentContext
if isNothing (findTypeConstructor tConsName oldTypes) then
dbErr (AtomTypeNameNotInUseError tConsName)
else do
let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
putStateContext $ currentContext { typeConstructorMapping = newTypes }
evalGraphRefDatabaseContextExpr (MultipleExpr exprs) =
--the multiple expressions must pass the same context around- not the old unmodified context
mapM_ evalGraphRefDatabaseContextExpr exprs
evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName') = do
currentContext <- getStateContext
let atomFuncs = atomFunctions currentContext
case atomFunctionForName funcName' atomFuncs of
Left err -> dbErr err
Right realFunc ->
if isScriptedAtomFunction realFunc then do
let updatedFuncs = HS.delete realFunc atomFuncs
putStateContext (currentContext {atomFunctions = updatedFuncs })
else
dbErr (PrecompiledFunctionRemoveError funcName')
evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName') = do
context <- getStateContext
let dbcFuncs = dbcFunctions context
case databaseContextFunctionForName funcName' dbcFuncs of
Left err -> dbErr err
Right realFunc ->
if isScriptedDatabaseContextFunction realFunc then do
let updatedFuncs = HS.delete realFunc dbcFuncs
putStateContext (context { dbcFunctions = updatedFuncs })
else
dbErr (PrecompiledFunctionRemoveError funcName')
evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName' atomArgExprs) = do
context <- getStateContext
graph <- dbcGraph
--resolve atom arguments
let eAtomTypes = mapM (runGraphRefRelationalExprM gfEnv . typeForGraphRefAtomExpr emptyAttributes) atomArgExprs
eFunc = databaseContextFunctionForName funcName' (dbcFunctions context)
gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
case eFunc of
Left err -> dbErr err
Right func -> do
let expectedArgCount = length (funcType func)
actualArgCount = length atomArgExprs
if expectedArgCount /= actualArgCount then
dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
else
--check that the atom types are valid
case eAtomTypes of
Left err -> dbErr err
Right atomTypes -> do
let mValidTypes = zipWith (\ expType actType
-> case atomTypeVerify expType actType of
Left err -> Just err
Right _ -> Nothing)
(funcType func) atomTypes
typeErrors = catMaybes mValidTypes
eAtomArgs = map (runGraphRefRelationalExprM gfEnv . evalGraphRefAtomExpr emptyTuple) atomArgExprs
if length (lefts eAtomArgs) > 1 then
dbErr (someErrors (lefts eAtomArgs))
else if not (null typeErrors) then
dbErr (someErrors typeErrors)
else
case evalDatabaseContextFunction func (rights eAtomArgs) context of
Left err -> dbErr err
Right newContext -> putStateContext newContext
data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv
{ dbcio_transId :: TransactionId,
dbcio_graph :: TransactionGraph,
dbcio_mScriptSession :: Maybe ScriptSession,
dbcio_mModulesDirectory :: Maybe FilePath -- ^ when running in persistent mode, this must be a Just value to a directory containing .o/.so/.dynlib files which the user has placed there for access to compiled functions
}
type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a
runDatabaseContextIOEvalMonad :: DatabaseContextIOEvalEnv -> DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ()) -> IO (Either RelationalError DatabaseContextEvalState)
runDatabaseContextIOEvalMonad env ctx m = do
res <- runRWST m env freshState
case res of
(Left err,_,_) -> pure (Left err)
(Right (),s,_) -> pure (Right s)
where
freshState = mkDatabaseContextEvalState ctx
requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)
requireScriptSession = do
env <- RWS.ask
case dbcio_mScriptSession env of
Nothing -> pure $ Left $ ScriptError ScriptCompilationDisabledError
Just ss -> pure (Right ss)
putDBCIOContext :: DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext ctx = do
RWS.modify (\dbstate -> dbstate { dbc_context = ctx})
pure (Right ())
getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext = dbc_context <$> RWS.get
getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv
getDBCIORelationalExprEnv = do
context <- getDBCIOContext
mkRelationalExprEnv context . dbcio_graph <$> RWS.ask
evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())
#if !defined(PM36_HASKELL_SCRIPTING)
evalGraphRefDatabaseContextIOExpr AddAtomFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
evalGraphRefDatabaseContextIOExpr AddDatabaseContextFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
evalGraphRefDatabaseContextIOExpr LoadAtomFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
evalGraphRefDatabaseContextIOExpr LoadDatabaseContextFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
#else
evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName' funcType' script) = do
eScriptSession <- requireScriptSession
currentContext <- getDBCIOContext
case eScriptSession of
Left err -> pure (Left err)
Right scriptSession -> do
res <- liftIO $ try $ runGhc (Just libdir) $ do
setSession (hscEnv scriptSession)
let atomFuncs = atomFunctions currentContext
case extractAtomFunctionType funcType' of
Left err -> pure (Left err)
Right adjustedAtomTypeCons -> do
--compile the function
eCompiledFunc <- compileScript (atomFunctionBodyType scriptSession) script
pure $ case eCompiledFunc of
Left err -> Left (ScriptError err)
Right compiledFunc -> do
funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructorValidate False funcTypeArg (typeConstructorMapping currentContext) M.empty) adjustedAtomTypeCons
let updatedFuncs = HS.insert newAtomFunc atomFuncs
newContext = currentContext { atomFunctions = updatedFuncs }
newAtomFunc = Function { funcName = funcName',
funcType = funcAtomType,
funcBody = FunctionScriptBody script compiledFunc }
-- check if the name is already in use
if HS.member funcName' (HS.map funcName atomFuncs) then
Left (FunctionNameInUseError funcName')
else
Right newContext
case res of
Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
Right eContext -> case eContext of
Left err -> pure (Left err)
Right context' -> putDBCIOContext context'
evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName' funcType' script) = do
eScriptSession <- requireScriptSession
currentContext <- getDBCIOContext
case eScriptSession of
Left err -> pure (Left err)
Right scriptSession -> do
--validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
let last2Args = reverse (take 2 (reverse funcType'))
atomArgs = take (length funcType' - 2) funcType'
dbContextTypeCons = ADTypeConstructor "Either" [ADTypeConstructor "DatabaseContextFunctionError" [], ADTypeConstructor "DatabaseContext" []]
expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"
actualType = show funcType'
if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
else do
res <- liftIO $ try $ runGhc (Just libdir) $ do
setSession (hscEnv scriptSession)
eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
pure $ case eCompiledFunc of
Left err -> Left (ScriptError err)
Right compiledFunc -> do
--if we are here, we have validated that the written function type is X -> DatabaseContext -> DatabaseContext, so we need to munge the first elements into an array
funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) atomArgs
let updatedDBCFuncs = HS.insert newDBCFunc (dbcFunctions currentContext)
newContext = currentContext { dbcFunctions = updatedDBCFuncs }
dbcFuncs = dbcFunctions currentContext
newDBCFunc = Function {
funcName = funcName',
funcType = funcAtomType,
funcBody = FunctionScriptBody script compiledFunc
}
-- check if the name is already in use
if HS.member funcName' (HS.map funcName dbcFuncs) then
Left (FunctionNameInUseError funcName')
else
Right newContext
case res of
Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
Right eContext -> case eContext of
Left err -> pure (Left err)
Right context' -> putDBCIOContext context'
evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName entrypointName modPath) = do
-- when running an in-memory database, we are willing to load object files from any path- when running in persistent mode, we load modules only from the modules directory so that we can be reasonbly sure that these same modules will exist when the database is restarted from the same directory
mModDir <- dbcio_mModulesDirectory <$> ask
currentContext <- getDBCIOContext
let sModName = T.unpack modName
sEntrypointName = T.unpack entrypointName
eLoadFunc <- liftIO $ loadFunctions sModName sEntrypointName mModDir modPath
case eLoadFunc of
Left LoadSymbolError -> pure (Left LoadFunctionError)
Left SecurityLoadSymbolError -> pure (Left SecurityLoadFunctionError)
Right atomFunctionListFunc -> do
let newContext = currentContext { atomFunctions = mergedFuncs }
processedAtomFunctions = processObjectLoadedFunctions sModName sEntrypointName modPath atomFunctionListFunc
mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList processedAtomFunctions)
putDBCIOContext newContext
evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName entrypointName modPath) = do
currentContext <- getDBCIOContext
let sModName = T.unpack modName
sEntrypointName = T.unpack entrypointName
mModDir <- dbcio_mModulesDirectory <$> ask
eLoadFunc <- liftIO $ loadFunctions sModName sEntrypointName mModDir modPath
case eLoadFunc of
Left LoadSymbolError -> pure (Left LoadFunctionError)
Left SecurityLoadSymbolError -> pure (Left SecurityLoadFunctionError)
Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList processedDBCFuncs)
processedDBCFuncs = processObjectLoadedFunctions sModName sEntrypointName modPath dbcListFunc
in putDBCIOContext newContext
#endif
evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do
--Define
currentContext <- getDBCIOContext
env <- RWS.ask
--create graph ref expr
let gfExpr = Define relVarName attrExprs
evalEnv = mkDatabaseContextEvalEnv (dbcio_transId env) (dbcio_graph env)
graph = dbcio_graph env
case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of
Left err -> pure (Left err)
Right dbstate -> do
--Assign
let existingRelVar = M.lookup relVarName relVarTable
relVarTable = relationVariables (dbc_context dbstate)
case existingRelVar of
Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
Just existingRel -> do
let gfEnv = freshGraphRefRelationalExprEnv (Just currentContext) graph
case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of
Left err -> pure (Left err)
Right relType -> do
let expectedAttributes = attributes relType
tcMap = typeConstructorMapping (dbc_context dbstate)
eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
case eitherRel of
Left err -> pure $ Left err
Right rel ->
case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of
Left err -> pure (Left err)
Right dbstate' -> putDBCIOContext (dbc_context dbstate')
--run verification on all constraints
checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do
mapM_ (uncurry checkIncDep) (M.toList deps)
where
potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)
tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,
utctDayTime = secondsToDiffTime 0 }
tempSchemas = Schemas context M.empty
tempTrans = Transaction U.nil tempTransInfo tempSchemas
tempTransInfo = TransactionInfo { parents = transId NE.:| [],
stamp = tempStamp,
merkleHash = mempty
}
deps = inclusionDependencies context
-- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment
checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
let process = runProcessExprM UncommittedContextMarker
gfSubsetExpr = process (processRelationalExpr subsetExpr)
gfSupersetExpr = process (processRelationalExpr supersetExpr)
--if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear.
let gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
runGfRel e = case runGraphRefRelationalExprM gfEnv e of
Left err -> Left (InclusionDependencyCheckError depName (Just err))
Right v -> Right v
typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)
typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)
when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)
gfEnv' = freshGraphRefRelationalExprEnv (Just context) potentialGraph
case gfEvald of
Left err -> Left err
Right resultRel -> if resultRel == relationTrue then
pure ()
else
Left (InclusionDependencyCheckError depName Nothing)
-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing
-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation
typeForRelationalExpr expr = do
--replace the relationVariables context element with a cloned set of relation devoid of tuples
--evalRelationalExpr could still return an existing relation with tuples, so strip them
graph <- reGraph
context <- reContext
let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)
gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
lift $ except runGf
liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
liftE v = do
y <- lift v
case y of
Left err -> throwError err
Right val -> pure val
{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
predicateRestrictionFilter :: Attributes -> GraphRefRestrictionPredicateExpr -> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do
expr1v <- predicateRestrictionFilter attrs expr1
expr2v <- predicateRestrictionFilter attrs expr2
pure (\x -> do
ev1 <- expr1v x
ev2 <- expr2v x
pure (ev1 && ev2))
predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do
expr1v <- predicateRestrictionFilter attrs expr1
expr2v <- predicateRestrictionFilter attrs expr2
pure (\x -> do
ev1 <- expr1v x
ev2 <- expr2v x
pure (ev1 || ev2))
predicateRestrictionFilter _ TruePredicate = pure (\_ -> pure True)
predicateRestrictionFilter attrs (NotPredicate expr) = do
exprv <- predicateRestrictionFilter attrs expr
pure (fmap not . exprv)
--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here
predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do
renv <- askEnv
let eval :: RelationTuple -> Either RelationalError Relation
eval tup =
let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in
runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)
pure (\tup -> case eval tup of
Left err -> Left err
Right rel -> if arity rel /= 0 then
Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
else
pure (rel == relationTrue))
predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
env <- askEnv
let attrs' = A.union attrs (envAttributes env)
ctxtup' = envTuple env
atomExprType <- typeForGraphRefAtomExpr attrs' atomExpr
attr <- lift $ except $ case A.attributeForName attrName attrs of
Right attr -> Right attr
Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of
Right ctxattr -> Right ctxattr
Left err2@(NoSuchAttributeNamesError _) -> Left err2
Left err -> Left err
Left err -> Left err
if atomExprType /= A.atomType attr then
throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
else
pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of
Right atomCmp -> atomCmp == atomIn
Left _ -> False
atomEvald = runGraphRefRelationalExprM env (evalGraphRefAtomExpr tupleIn atomExpr)
in
pure $ case atomForAttributeName attrName tupleIn of
Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of
Left _ -> False
Right ctxatom -> evalAndCmp ctxatom
Left _ -> False
Right atomIn -> evalAndCmp atomIn
-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
--merge attrs into the state attributes
renv <- askEnv
aType <- typeForGraphRefAtomExpr attrs atomExpr
if aType /= BoolAtomType then
throwError (AtomTypeMismatchError aType BoolAtomType)
else
pure (\tupleIn ->
case runGraphRefRelationalExprM renv (evalGraphRefAtomExpr tupleIn atomExpr) of
Left err -> Left err
Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))
tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then
Left (AttributeNameInUseError attrName)
else
Right rel
extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)
extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) =
-- renv <- askEnv
-- check that the attribute name is not in use
case tupleExprCheckNewAttrName newAttrName relIn of
Left err -> throwError err
Right _ -> do
atomExprType <- typeForGraphRefAtomExpr (attributes relIn) atomExpr
atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType
let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
env <- ask
pure (newAndOldAttrs, \tup -> do
let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup env
atom <- runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr tup atomExpr)
Right (tupleAtomExtend newAttrName atom tup)
)
evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr tupIn (AttributeAtomExpr attrName) =
case atomForAttributeName attrName tupIn of
Right atom -> pure atom
Left err@(NoSuchAttributeNamesError _) -> do
env <- askEnv
case gre_extra env of
Nothing -> throwError err
Just (Left ctxtup) -> lift $ except $ atomForAttributeName attrName ctxtup
Just (Right _) -> throwError err
Left err -> throwError err
evalGraphRefAtomExpr _ (NakedAtomExpr atom) = pure atom
evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName' arguments tid) = do
argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments
context <- gfDatabaseContextForMarker tid
let functions = atomFunctions context
func <- lift $ except (atomFunctionForName funcName' functions)
let expectedArgCount = length (funcType func) - 1
actualArgCount = length argTypes
safeInit [] = [] -- different behavior from normal init
safeInit xs = init xs
if expectedArgCount /= actualArgCount then
throwError (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
else do
let zippedArgs = zip (safeInit (funcType func)) argTypes
mapM_ (\(expType, actType) ->
lift $ except (atomTypeVerify expType actType)) zippedArgs
evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments
case evalAtomFunction func evaldArgs of
Left err -> throwError (AtomFunctionUserError err)
Right result -> do
--validate that the result matches the expected type
_ <- lift $ except (atomTypeVerify (last (funcType func)) (atomTypeForAtom result))
pure result
evalGraphRefAtomExpr tupIn (RelationAtomExpr relExpr) = do
--merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes
env <- ask
let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env
relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)
pure (RelationAtom relAtom)
evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do --why is the tid unused here? suspicious
let mergeEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn
aType <- local mergeEnv (typeForGraphRefAtomExpr (tupleAttributes tupIn) cons)
argAtoms <- local mergeEnv $
mapM (evalGraphRefAtomExpr tupIn) dConsArgs
pure (ConstructedAtom dConsName aType argAtoms)
typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do
renv <- askEnv
case A.atomTypeForAttributeName attrName attrs of
Right aType -> pure aType
Left err@(NoSuchAttributeNamesError _) ->
let envTup = envTuple renv
envAttrs = envAttributes renv in
case A.attributeForName attrName envAttrs of
Right attr -> pure (A.atomType attr)
Left _ -> case atomForAttributeName attrName envTup of
Right atom -> pure (atomTypeForAtom atom)
Left _ -> --throwError (traceStack (show ("typeForGRAtomExpr", attrs, envTup)) err)
throwError err
Left err -> throwError err
typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)
typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName' atomArgs transId) = do
funcs <- atomFunctions <$> gfDatabaseContextForMarker transId
case atomFunctionForName funcName' funcs of
Left err -> throwError err
Right func -> do
let funcRetType = last (funcType func)
funcArgTypes = init (funcType func)
argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs
let eTvMap = resolveTypeVariables funcArgTypes argTypes
case eTvMap of
Left err -> throwError err
Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName' tvMap funcRetType
typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do
relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)
pure (RelationAtomType (attributes relType))
-- grab the type of the data constructor, then validate that the args match the expected types
typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =
do
argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs
tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid
lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes
-- | Validate that the type of the AtomExpr matches the expected type.
verifyGraphRefAtomExprTypes :: Relation -> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do
env <- askEnv
case A.atomTypeForAttributeName attrName (attributes relIn) of
Right aType -> lift $ except $ atomTypeVerify expectedType aType
(Left err@(NoSuchAttributeNamesError _)) ->
let attrs' = envAttributes env in
if attrs' == emptyAttributes then
throwError err
else
case A.attributeForName attrName attrs' of
Left err' -> throwError err'
Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)
Left err -> throwError err
verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =
lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)
verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName' funcArgExprs tid) expectedType = do
context <- gfDatabaseContextForMarker tid
let functions = atomFunctions context
func <- lift $ except $ atomFunctionForName funcName' functions
let expectedArgTypes = funcType func
funcArgVerifier (atomExpr, expectedType2, argCount) = do
let handler :: RelationalError -> GraphRefRelationalExprM AtomType
handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType)
handler err = throwError err
verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler
funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]
if length funcArgTypes /= length expectedArgTypes - 1 then
throwError (AtomTypeCountError funcArgTypes expectedArgTypes)
else
lift $ except $ atomTypeVerify expectedType (last expectedArgTypes)
verifyGraphRefAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType =
do
let mergedAttrsEnv = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn)
relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)
lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType))
verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do
cType <- typeForGraphRefAtomExpr (attributes rel) cons
lift $ except $ atomTypeVerify expectedType cType
-- | Look up the type's name and create a new attribute.
evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do
tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker transId
aType <- lift $ except $ atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
lift $ except $ validateAtomType aType tConsMap
pure $ Attribute attrName aType
evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure attr
-- for tuple type concrete resolution (Nothing ==> Maybe Int) when the attributes hint is Nothing, we need to first process all the tuples, then extract the concrete types on a per-attribute basis, then reprocess the tuples to include the concrete types
evalGraphRefTupleExprs :: Maybe Attributes -> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs _ (TupleExprs _ []) = pure []
evalGraphRefTupleExprs mAttrs (TupleExprs fixedMarker tupleExprL) = do
tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprL
finalAttrs <- case mAttrs of
Just attrs -> pure attrs
Nothing ->
case tuples of
[] -> pure emptyAttributes
(headTuple:tailTuples) -> do
--gather up resolved atom types or throw an error if an attribute cannot be made concrete from the inferred types- this could still fail if the type cannot be inferred (e.g. from [Nothing, Nothing])
let
processTupleAttrs (tupAttr, accAttr) =
--if the attribute is a constructedatomtype, we can recurse into it to potentially resolve type variables
if isResolvedAttribute accAttr && tupAttr == accAttr then
pure accAttr
else
lift $ except $ resolveAttributes accAttr tupAttr
mostResolvedTypes <-
foldM (\acc tup -> do
let zipped = zip (V.toList . attributesVec $ tupleAttributes tup) acc
accNames = S.fromList $ map A.attributeName acc
tupNames = A.attributeNameSet (tupleAttributes tup)
attrNamesDiff = S.union (S.difference accNames tupNames) (S.difference tupNames accNames)
unless (null attrNamesDiff) (throwError (AttributeNamesMismatchError attrNamesDiff))
nextTupleAttrs <- mapM processTupleAttrs zipped
let diff = A.attributesDifference (A.attributesFromList nextTupleAttrs) (A.attributesFromList acc)
if diff == A.emptyAttributes then
pure nextTupleAttrs
else
throwError (TupleAttributeTypeMismatchError diff)
) (V.toList . attributesVec $ tupleAttributes headTuple) tailTuples
pure (A.attributesFromList mostResolvedTypes)
--strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same
tConsMap <- case singularTransactions tupleExprL of
SingularTransactionRef commonTransId ->
typeConstructorMapping <$> gfDatabaseContextForMarker commonTransId
NoTransactionsRef ->
typeConstructorMapping <$> gfDatabaseContextForMarker fixedMarker
-- if there are multiple transaction markers in the TupleExprs, then we can't assume a single type constructor mapping- this could be improved in the future, but if all the tuples are fully resolved, then we don't need further resolution
_ -> throwError TupleExprsReferenceMultipleMarkersError
lift $ except $ validateAttributes tConsMap finalAttrs
mapM (lift . except . resolveTypesInTuple finalAttrs tConsMap) tuples
--resolveAttributes (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",IntegerAtomType),("b",TypeVariableType "b")]))) (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",TypeVariableType "a"),("b",TextAtomType)])))
evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple
evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do
-- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority
-- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed
let attrs = fromMaybe A.emptyAttributes mAttrs
resolveOneAtom (attrName, aExpr) =
do
--provided when the relation header is available
let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs
unresolvedType <- typeForGraphRefAtomExpr attrs aExpr
resolvedType <- case eExpectedAtomType of
Left _ -> pure unresolvedType
Right typeHint -> lift $ except $ resolveAtomType typeHint unresolvedType
--resolve atom typevars based on resolvedType?
newAtom <- evalGraphRefAtomExpr emptyTuple aExpr
pure (attrName, newAtom, resolvedType)
attrAtoms <- mapM resolveOneAtom (M.toList tupMap)
let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
tup = mkRelationTuple tupAttrs atoms
finalAttrs = fromMaybe tupAttrs mAttrs
--verify that the attributes match
when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)
--we can't resolve types here- they have to be resolved at the atom level where the graph ref is held
--tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))
let tup' = reorderTuple finalAttrs tup
--TODO: restore type resolution
-- _ <- lift $ except (validateTuple tup' tConss)
pure tup'
--temporary implementation until we have a proper planner+executor
evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
mAttrs <- case mAttrExprs of
Just _ ->
Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)
Nothing -> pure Nothing
tuples <- evalGraphRefTupleExprs mAttrs tupleExprs
let attrs = fromMaybe firstTupleAttrs mAttrs
firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)
lift $ except $ mkRelation attrs (RelationTupleSet tuples)
evalGraphRefRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
lift $ except $ mkRelation attributeSet tupleSet
evalGraphRefRelationalExpr (ExistingRelation rel) = pure rel
evalGraphRefRelationalExpr (RelationVariable name tid) = do
ctx <- gfDatabaseContextForMarker tid
case M.lookup name (relationVariables ctx) of
Nothing -> throwError (RelVarNotDefinedError name)
Just rv -> evalGraphRefRelationalExpr rv
evalGraphRefRelationalExpr (Project attrNames expr) = do
attrNameSet <- evalGraphRefAttributeNames attrNames expr
rel <- evalGraphRefRelationalExpr expr
lift $ except $ project attrNameSet rel
evalGraphRefRelationalExpr (Union exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
lift $ except $ union relA relB
evalGraphRefRelationalExpr (Join exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
lift $ except $ join relA relB
evalGraphRefRelationalExpr (Rename oldName newName expr) = do
rel <- evalGraphRefRelationalExpr expr
lift $ except $ rename oldName newName rel
evalGraphRefRelationalExpr (Difference exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
lift $ except $ difference relA relB
evalGraphRefRelationalExpr (Group groupAttrNames newAttrName expr) = do
groupNames <- evalGraphRefAttributeNames groupAttrNames expr
rel <- evalGraphRefRelationalExpr expr
lift $ except $ group groupNames newAttrName rel
evalGraphRefRelationalExpr (Ungroup groupAttrName expr) = do
rel <- evalGraphRefRelationalExpr expr
lift $ except $ ungroup groupAttrName rel
evalGraphRefRelationalExpr (Restrict predExpr expr) = do
rel <- evalGraphRefRelationalExpr expr
filt <- predicateRestrictionFilter (attributes rel) predExpr
lift $ except $ restrict filt rel
evalGraphRefRelationalExpr (Equals exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
pure $ if relA == relB then relationTrue else relationFalse
evalGraphRefRelationalExpr (NotEquals exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
pure $ if relA == relB then relationFalse else relationTrue
evalGraphRefRelationalExpr (Extend extendTupleExpr expr) = do
rel <- evalGraphRefRelationalExpr expr
(newAttrs, tupProc) <- extendGraphRefTupleExpressionProcessor rel extendTupleExpr
lift $ except $ relMogrify tupProc newAttrs rel
evalGraphRefRelationalExpr expr@With{} =
--strategy A: add relation variables to the contexts in the graph
--strategy B: drop in macros in place (easier programmatically)
--strategy B implementation
evalGraphRefRelationalExpr (substituteWithNameMacros [] expr)
dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext
dbContextForTransId tid graph = do
trans <- transactionForId tid graph
pure (concreteDatabaseContext trans)
transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
transactionForId tid graph
| tid == U.nil =
Left RootTransactionTraversalError
| S.null matchingTrans =
Left $ NoSuchTransactionError tid
| otherwise =
Right $ head (S.toList matchingTrans)
where
matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet
typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))
typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
mAttrs <- case mAttrExprs of
Just attrExprs -> do
attrs <- mapM evalGraphRefAttributeExpr attrExprs
pure (Just (attributesFromList attrs))
Nothing -> pure Nothing
tuples <- evalGraphRefTupleExprs mAttrs tupleExprs
let retAttrs = case tuples of
(tup:_) -> tupleAttributes tup
[] -> fromMaybe A.emptyAttributes mAttrs
pure $ emptyRelationWithAttrs retAttrs
typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do
relVars <- relationVariables <$> gfDatabaseContextForMarker tid
case M.lookup rvName relVars of
Nothing -> throwError (RelVarNotDefinedError rvName)
Just rvExpr ->
typeForGraphRefRelationalExpr rvExpr
typeForGraphRefRelationalExpr (Project attrNames expr) = do
exprType' <- typeForGraphRefRelationalExpr expr
projectionAttrs <- evalGraphRefAttributeNames attrNames expr
lift $ except $ project projectionAttrs exprType'
typeForGraphRefRelationalExpr (Union exprA exprB) = do
exprA' <- typeForGraphRefRelationalExpr exprA
exprB' <- typeForGraphRefRelationalExpr exprB
lift $ except $ union exprA' exprB'
typeForGraphRefRelationalExpr (Join exprA exprB) = do
exprA' <- typeForGraphRefRelationalExpr exprA
exprB' <- typeForGraphRefRelationalExpr exprB
lift $ except $ join exprA' exprB'
typeForGraphRefRelationalExpr (Rename oldAttr newAttr expr) = do
expr' <- typeForGraphRefRelationalExpr expr
lift $ except $ rename oldAttr newAttr expr'
typeForGraphRefRelationalExpr (Difference exprA exprB) = do
exprA' <- typeForGraphRefRelationalExpr exprA
exprB' <- typeForGraphRefRelationalExpr exprB
lift $ except $ difference exprA' exprB'
typeForGraphRefRelationalExpr (Group groupNames attrName expr) = do
expr' <- typeForGraphRefRelationalExpr expr
groupNames' <- evalGraphRefAttributeNames groupNames expr
lift $ except $ group groupNames' attrName expr'
typeForGraphRefRelationalExpr (Ungroup groupAttrName expr) = do
expr' <- typeForGraphRefRelationalExpr expr
lift $ except $ ungroup groupAttrName expr'
typeForGraphRefRelationalExpr (Restrict pred' expr) = do
expr' <- typeForGraphRefRelationalExpr expr
filt <- predicateRestrictionFilter (attributes expr') pred'
lift $ except $ restrict filt expr'
typeForGraphRefRelationalExpr Equals{} =
pure relationFalse
typeForGraphRefRelationalExpr NotEquals{} =
pure relationFalse
typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do
rel <- typeForGraphRefRelationalExpr expr
evalGraphRefRelationalExpr (Extend extendTupleExpr (ExistingRelation rel))
typeForGraphRefRelationalExpr expr@(With withs _) = do
let expr' = substituteWithNameMacros [] expr
checkMacroName (WithNameExpr macroName tid) = do
rvs <- relationVariables <$> gfDatabaseContextForMarker tid
case M.lookup macroName rvs of
Just _ -> lift $ except $ Left (RelVarAlreadyDefinedError macroName) --this error does not include the transaction marker, but should be good enough to identify the cause
Nothing -> pure ()
mapM_ (checkMacroName . fst) withs
typeForGraphRefRelationalExpr expr'
evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)
evalGraphRefAttributeNames attrNames expr = do
exprType' <- typeForGraphRefRelationalExpr expr
let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType')))
case attrNames of
AttributeNames names ->
case A.projectionAttributesForNames names (attributes exprType') of
Left err -> throwError err
Right attrs -> pure (S.fromList (V.toList (A.attributeNames attrs)))
InvertedAttributeNames names -> do
let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
if not (S.null nonExistentAttributeNames) then
throwError $ AttributeNamesMismatchError nonExistentAttributeNames
else
pure (A.nonMatchingAttributeNameSet names typeNameSet)
UnionAttributeNames namesA namesB -> do
nameSetA <- evalGraphRefAttributeNames namesA expr
nameSetB <- evalGraphRefAttributeNames namesB expr
pure (S.union nameSetA nameSetB)
IntersectAttributeNames namesA namesB -> do
nameSetA <- evalGraphRefAttributeNames namesA expr
nameSetB <- evalGraphRefAttributeNames namesB expr
pure (S.intersection nameSetA nameSetB)
RelationalExprAttributeNames attrExpr -> do
attrExprType <- typeForGraphRefRelationalExpr attrExpr
pure (A.attributeNameSet (attributes attrExprType))
evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid
case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of
Left err -> throwError err
Right aType -> do
case validateAtomType aType tConsMap of
Left err -> throwError err
Right _ -> pure (Attribute attrName aType)
evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr
mkEmptyRelVars :: RelationVariables -> RelationVariables
mkEmptyRelVars = M.map mkEmptyRelVar
where
mkEmptyRelVar expr@MakeRelationFromExprs{} = expr --do not truncate here because we might lose essential type information in emptying the tuples
mkEmptyRelVar (MakeStaticRelation attrs _) = MakeStaticRelation attrs emptyTupleSet
mkEmptyRelVar (ExistingRelation rel) = ExistingRelation (emptyRelationWithAttrs (attributes rel))
mkEmptyRelVar rv@RelationVariable{} = Restrict (NotPredicate TruePredicate) rv
mkEmptyRelVar (Project attrNames expr) = Project attrNames (mkEmptyRelVar expr)
mkEmptyRelVar (Union exprA exprB) = Union (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (Join exprA exprB) = Join (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (Rename nameA nameB expr) = Rename nameA nameB (mkEmptyRelVar expr)
mkEmptyRelVar (Difference exprA exprB) = Difference (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (Group attrNames attrName expr) = Group attrNames attrName (mkEmptyRelVar expr)
mkEmptyRelVar (Ungroup attrName expr) = Ungroup attrName (mkEmptyRelVar expr)
mkEmptyRelVar (Restrict pred' expr) = Restrict pred' (mkEmptyRelVar expr)
mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)
mkEmptyRelVar (With macros expr) = With (map (second mkEmptyRelVar) macros) (mkEmptyRelVar expr)
dbErr :: RelationalError -> DatabaseContextEvalMonad ()
dbErr err = lift (except (Left err))
-- | Return a Relation describing the relation variables.
relationVariablesAsRelation :: DatabaseContext -> TransactionGraph -> Either RelationalError Relation
relationVariablesAsRelation ctx graph = do
let subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]
attrs = A.attributesFromList [Attribute "name" TextAtomType,
Attribute "attributes" (RelationAtomType subrelAttrs)]
relVars = relationVariables ctx
mkRvDesc (rvName, gfExpr) = do
let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph
gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
pure (rvName, gfType)
relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributesVec (attributes rel))]
attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]
attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of
Left err -> error ("relationVariablesAsRelation pooped " ++ show err)
Right rel -> RelationAtom rel
rvs <- mapM mkRvDesc (M.toList relVars)
let tups = map relVarToAtomList rvs
mkRelationFromList attrs tups
-- | An unoptimized variant of evalGraphRefRelationalExpr for testing.
evalRelationalExpr :: RelationalExpr -> RelationalExprM Relation
evalRelationalExpr expr = do
graph <- reGraph
context <- reContext
let expr' = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)
gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
case runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr expr') of
Left err -> throwError err
Right rel -> pure rel
class (MonadError RelationalError m, Monad m) => DatabaseContextM m where
getContext :: m DatabaseContext
instance DatabaseContextM (ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity)) where
getContext = gfDatabaseContextForMarker UncommittedContextMarker
instance DatabaseContextM (RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity)) where
getContext = getStateContext
relVarByName :: DatabaseContextM m => RelVarName -> m GraphRefRelationalExpr
relVarByName rvName = do
relvars <- relationVariables <$> getContext
case M.lookup rvName relvars of
Nothing -> throwError (RelVarNotDefinedError rvName)
Just gfexpr -> pure gfexpr
-- | resolve UncommittedTransactionMarker whenever possible- this is important in the DatabaseContext in order to mitigate self-referencing loops for updates
class ResolveGraphRefTransactionMarker a where
resolve :: a -> DatabaseContextEvalMonad a
-- s := s union t
instance ResolveGraphRefTransactionMarker GraphRefRelationalExpr where
resolve (MakeRelationFromExprs mAttrs tupleExprs) =
MakeRelationFromExprs mAttrs <$> resolve tupleExprs
resolve orig@MakeStaticRelation{} = pure orig
resolve orig@ExistingRelation{} = pure orig
resolve orig@(RelationVariable rvName UncommittedContextMarker) = do
rvMap <- relationVariables <$> getStateContext
case M.lookup rvName rvMap of
Nothing -> pure orig
Just resolvedRv -> resolve resolvedRv
resolve orig@RelationVariable{} = pure orig
resolve (Project attrNames relExpr) = Project <$> resolve attrNames <*> resolve relExpr
resolve (Union exprA exprB) = Union <$> resolve exprA <*> resolve exprB
resolve (Join exprA exprB) = Join <$> resolve exprA <*> resolve exprB
resolve (Rename attrA attrB expr) = Rename attrA attrB <$> resolve expr
resolve (Difference exprA exprB) = Difference <$> resolve exprA <*> resolve exprB
resolve (Group namesA nameB expr) = Group <$> resolve namesA <*> pure nameB <*> resolve expr
resolve (Ungroup nameA expr) = Ungroup nameA <$> resolve expr
resolve (Restrict restrictExpr relExpr) = Restrict <$> resolve restrictExpr <*> resolve relExpr
resolve (Equals exprA exprB) = Equals <$> resolve exprA <*> resolve exprB
resolve (NotEquals exprA exprB) = NotEquals <$> resolve exprA <*> resolve exprB
resolve (Extend extendExpr relExpr) = Extend <$> resolve extendExpr <*> resolve relExpr
resolve (With withExprs relExpr) = With <$> mapM (\(nam, expr) -> (,) <$> resolve nam <*> resolve expr) withExprs <*> resolve relExpr
instance ResolveGraphRefTransactionMarker GraphRefTupleExprs where
resolve (TupleExprs marker tupleExprs) =
TupleExprs marker <$> mapM resolve tupleExprs
instance ResolveGraphRefTransactionMarker GraphRefTupleExpr where
resolve (TupleExpr tupMap) = do
tupMap' <- mapM (\(attrName, expr) -> (,) attrName <$> resolve expr ) (M.toList tupMap)
pure (TupleExpr (M.fromList tupMap'))
instance ResolveGraphRefTransactionMarker GraphRefAttributeNames where
resolve orig@AttributeNames{} = pure orig
resolve orig@InvertedAttributeNames{} = pure orig
resolve (UnionAttributeNames namesA namesB) = UnionAttributeNames <$> resolve namesA <*> resolve namesB
resolve (IntersectAttributeNames namesA namesB) = IntersectAttributeNames <$> resolve namesA <*> resolve namesB
resolve (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> resolve expr
instance ResolveGraphRefTransactionMarker GraphRefRestrictionPredicateExpr where
resolve TruePredicate = pure TruePredicate
resolve (AndPredicate exprA exprB) = AndPredicate <$> resolve exprA <*> resolve exprB
resolve (OrPredicate exprA exprB) = OrPredicate <$> resolve exprA <*> resolve exprB
resolve (NotPredicate expr) = NotPredicate <$> resolve expr
resolve (RelationalExprPredicate expr) = RelationalExprPredicate <$> resolve expr
resolve (AtomExprPredicate expr) = AtomExprPredicate <$> resolve expr
resolve (AttributeEqualityPredicate nam expr)= AttributeEqualityPredicate nam <$> resolve expr
instance ResolveGraphRefTransactionMarker GraphRefExtendTupleExpr where
resolve (AttributeExtendTupleExpr nam atomExpr) = AttributeExtendTupleExpr nam <$> resolve atomExpr
instance ResolveGraphRefTransactionMarker GraphRefWithNameExpr where
resolve orig@WithNameExpr{} = pure orig -- match uncommitted marker?
instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where
resolve orig@AttributeAtomExpr{} = pure orig
resolve orig@NakedAtomExpr{} = pure orig
resolve (FunctionAtomExpr nam atomExprs marker) =
FunctionAtomExpr nam <$> mapM resolve atomExprs <*> pure marker
resolve (RelationAtomExpr expr) = RelationAtomExpr <$> resolve expr
resolve (ConstructedAtomExpr dConsName atomExprs marker) =
ConstructedAtomExpr dConsName <$> mapM resolve atomExprs <*> pure marker
--convert series of simple Union queries into MakeStaticRelation
-- this is especially useful for long, nested applications of Union with simple tuples
-- Union (MakeRelation x y) (MakeRelation x y') -> MakeRelation x (y + y')
--MakeRelationFromExprs Nothing (TupleExprs UncommittedContextMarker [TupleExpr (fromList [("name", NakedAtomExpr (TextAtom "steve"))])])
applyUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr
applyUnionCollapse = Fold.cata opt
where
opt :: RelationalExprBaseF GraphRefTransactionMarker GraphRefRelationalExpr -> GraphRefRelationalExpr
opt (UnionF exprA exprB) | exprA == exprB = exprA
opt (UnionF
exprA@(MakeRelationFromExprs mAttrs1 tupExprs1)
exprB@(MakeRelationFromExprs mAttrs2 tupExprs2)) | tupExprs1 == tupExprs2 = MakeRelationFromExprs (mAttrs1 <|> mAttrs2) tupExprs1
| tupExprsNull tupExprs1 = exprB
| tupExprsNull tupExprs2 = exprA
opt x = Fold.embed x
tupExprsNull (TupleExprs _ []) = True
tupExprsNull _ = False
--UPDATE optimization- find matching where clause in "lower" levels of renaming
--update x where y=1 set (x:=5,z:=10); update x where y=1 set(x:=6,z:=11)
-- =>
-- update x where y=1 set (x:=6,z:=11)
-- future opt: match individual attributes update x where y=1 set (x:=5); update x where y=1 set (z:=11) => update x where y=1 set (x:=5,z:=11)
--strategy: try to collapse the top-level update (union (restrict pred MakeRelationFromExpr) expr) if it contains the same predicate and resultant relation
--DELETE optimization
-- if a restriction matches a previous restriction, combine them
-- O(1) since it only scans at the top level, critical in benchmarks generating redundant deletions
applyRestrictionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr
applyRestrictionCollapse orig@(Restrict npred@(NotPredicate _) expr) =
case expr of
orig'@(Restrict npred'@(NotPredicate _) _) | npred == npred' -> orig'
_ -> orig
applyRestrictionCollapse expr = expr