project-m36-0.8.1: src/lib/ProjectM36/RelationalExpression.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
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 Test.QuickCheck
#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 e =
e{ gre_extra = new_elems }
where
new_elems = Just (Left newTuple)
mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))
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 }
{-
--full evaluation down the graph
eval :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
eval expr = do
env <- askEnv
eGfExpr <- processRelationalExpr expr
case eGfExpr of
Left err -> pure (Left err)
Right gfExpr -> pure $ evalGraphRefRelationalExpr gfExpr (re_graph env)
-}
{-
--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)
evalRelationalExpr (RelationVariable name _) = do
relvarTable <- fmap (relationVariables . envContext) askEnv
return $ case M.lookup name relvarTable of
Just res -> Right res
Nothing -> Left $ RelVarNotDefinedError name
evalRelationalExpr (Project attrNames expr) = do
eAttrNameSet <- evalAttributeNames attrNames expr
case eAttrNameSet of
Left err -> pure (Left err)
Right attrNameSet -> do
rel <- evalRelationalExpr expr
case rel of
Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)
Left err -> pure $ Left err
evalRelationalExpr (Union exprA exprB) = do
relA <- evalRelationalExpr exprA
relB <- evalRelationalExpr exprB
case relA of
Left err -> return $ Left err
Right relA2 -> case relB of
Left err -> return $ Left err
Right relB2 -> return $ Right (Union relA2 relB2)
evalRelationalExpr (Join exprA exprB) = do
relA <- evalRelationalExpr exprA
relB <- evalRelationalExpr exprB
case relA of
Left err -> return $ Left err
Right relA2 -> case relB of
Left err -> return $ Left err
Right relB2 -> return $ Right (Join relA2 relB2)
evalRelationalExpr (Difference exprA exprB) = do
relA <- evalRelationalExpr exprA
relB <- evalRelationalExpr exprB
case relA of
Left err -> return $ Left err
Right relA2 -> case relB of
Left err -> return $ Left err
Right relB2 -> return $ Right (Difference relA2 relB2)
evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
case mkRelation attributeSet tupleSet of
Right rel -> return $ Right (ExistingRelation rel)
Left err -> return $ Left err
evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
currentContext <- fmap envContext askEnv
let tConss = typeConstructorMapping currentContext
-- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible
runExceptT $ do
mAttrs <- case mAttrExprs of
Just _ ->
Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)
Nothing -> pure Nothing
tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
let attrs = fromMaybe firstTupleAttrs mAttrs
firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)
expr <- either throwE pure (mkRelation attrs (RelationTupleSet tuples))
pure (ExistingRelation expr)
evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))
evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
evald <- evalRelationalExpr relExpr
case evald of
Right expr -> return $ Right (Rename oldAttrName newAttrName expr)
Left err -> return $ Left err
evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
eOldAttrNameSet <- evalAttributeNames oldAttrNames relExpr
case eOldAttrNameSet of
Left err -> pure (Left err)
Right oldAttrNameSet -> do
evald <- evalRelationalExpr relExpr
case evald of
Right expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)
Left err -> return $ Left err
evalRelationalExpr (Ungroup attrName relExpr) = do
evald <- evalRelationalExpr relExpr
case evald of
Right expr -> return $ Right (Ungroup attrName expr)
Left err -> return $ Left err
evalRelationalExpr (Restrict predicateExpr relExpr) = do
evald <- evalRelationalExpr relExpr
pred <- processRestrictionPredicateExpr predicateExpr
case evald of
Left err -> return $ Left err
Right expr ->
pure $ Right (Restrict pred expr)
evalRelationalExpr (Equals relExprA relExprB) = do
evaldA <- evalRelationalExpr relExprA
evaldB <- evalRelationalExpr relExprB
case evaldA of
Left err -> return $ Left err
Right exprA -> case evaldB of
Left err -> return $ Left err
Right exprB -> return $ Right (Equals exprA exprB)
{-
evalRelationalExpr (With views mainExpr) = do
rstate <- ask
let addScopedView ctx (vname,vexpr) = if vname `M.member` relationVariables ctx then
Left (RelVarAlreadyDefinedError vname)
else
case runState (evalDatabaseContextExpr (Assign vname vexpr)) (freshDatabaseState ctx) of
(Left err,_) -> Left err
(Right (), (ctx',_,_)) -> Right ctx'
case foldM addScopedView (stateElemsContext rstate) views of
Left err -> return $ Left err
Right ctx'' -> do
let evalMainExpr expr = runReader (evalRelationalExpr expr) (RelationalExprEnv ctx'')
case evalMainExpr mainExpr of
Left err -> return $ Left err
Right rel -> return $ Right rel
-}
--warning: copy-pasta from above- refactor
evalRelationalExpr (NotEquals relExprA relExprB) = do
evaldA <- evalRelationalExpr relExprA
evaldB <- evalRelationalExpr relExprB
case evaldA of
Left err -> return $ Left err
Right exprA -> case evaldB of
Left err -> return $ Left err
Right exprB -> return $ Right (NotEquals exprA exprB)
-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
evalRelationalExpr (Extend tupleExpression relExpr) = do
eExpr <- evalRelationalExpr relExpr
case eExpr of
Left err -> pure (Left err)
Right expr -> do
tupProc <- processExtendTupleExpr tupleExpression
pure (Right (Extend tupProc expr))
-}
--helper function to process relation variable creation/assignment
setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar relVarName relExpr = do
currentContext <- getStateContext
--prevent recursive relvar definition
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
-- 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 }
putStateContext newContext
pure ()
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
evalGraphRefDatabaseContextExpr (Assign relVarName
(Union
gfExpr
relExpr))
evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do
gfExpr <- relVarByName relVarName
setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)
--union of restricted+updated portion and the unrestricted+unupdated portion
evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do
rvExpr <- relVarByName relVarName
let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr
tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict
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 (dbcFuncType 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)
(dbcFuncType 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
}
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 = AtomFunction { atomFuncName = funcName,
atomFuncType = funcAtomType,
atomFuncBody = AtomFunctionBody (Just script) compiledFunc }
-- check if the name is already in use
if HS.member funcName (HS.map atomFuncName 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 = DatabaseContextFunction {
dbcFuncName = funcName,
dbcFuncType = funcAtomType,
dbcFuncBody = DatabaseContextFunctionBody (Just script) compiledFunc
}
-- check if the name is already in use
if HS.member funcName (HS.map dbcFuncName 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 funcName modPath) = do
currentContext <- getDBCIOContext
eLoadFunc <- liftIO $ loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
case eLoadFunc of
Left LoadSymbolError -> pure (Left LoadFunctionError)
Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
in putDBCIOContext newContext
evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName modPath) = do
currentContext <- getDBCIOContext
eLoadFunc <- liftIO $ loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
case eLoadFunc of
Left LoadSymbolError -> pure (Left LoadFunctionError)
Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList 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')
{-
updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple
updateTupleWithAtomExprs exprMap context graph tupIn = do
--resolve all atom exprs
let
atomsAssoc <- mapM (\(attrName, atomExpr) -> do
let atom = unimplemented
--atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)
pure (attrName, atom)
) (M.toList exprMap)
pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
-}
--run verification on all constraints
checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
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 = runGraphRefRelationalExprM gfEnv
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)
-- 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
--returns a database context with all tuples removed
--this is useful for type checking and optimization
{-
contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
where
relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)
-}
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 (atomFuncType 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 (atomFuncType 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 (atomFuncType 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)
{-
evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom
evalAtomExpr tupIn expr =
-}
{-
evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
Right atom -> pure (Right atom)
err@(Left (NoSuchAttributeNamesError _)) -> do
rstate <- ask
let stateTup = stateTuple rstate
pure (atomForAttributeName attrName stateTup)
Left err -> pure (Left err)
evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments
context <- fmap stateElemsContext ask
runExceptT $ do
let functions = atomFunctions context
func <- either throwE pure (atomFunctionForName funcName functions)
let expectedArgCount = length (atomFuncType func) - 1
actualArgCount = length argTypes
safeInit [] = [] -- different behavior from normal init
safeInit xs = init xs
if expectedArgCount /= actualArgCount then
throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
else do
let zippedArgs = zip (safeInit (atomFuncType func)) argTypes
mapM_ (\(expType, eActType) -> do
actType <- either throwE pure eActType
either throwE pure (atomTypeVerify expType actType)) zippedArgs
evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments
case evalAtomFunction func evaldArgs of
Left err -> throwE (AtomFunctionUserError err)
Right result -> do
--validate that the result matches the expected type
_ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))
pure result
evalAtomExpr 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
rstate <- ask
runExceptT $ do
let newState = mergeTuplesIntoRelationalExprState tupIn rstate
relAtom <- either throwE pure (runReader (evalRelationalExpr relExpr) newState)
pure (RelationAtom relAtom)
evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do
rstate <- lift ask
let newState = mergeTuplesIntoRelationalExprState tupIn rstate
aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) 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 (atomFuncType func)
funcArgTypes = init (atomFuncType 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 = atomFuncType 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 e = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) e
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 $ 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 $ 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'
{-
evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))
evalAttributeNames attrNames expr = do
eExprType <- typeForRelationalExpr expr
case eExprType of
Left err -> throwError err
Right exprTyp -> do
let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
case attrNames of
AttributeNames names ->
case A.projectionAttributesForNames names (attributes exprTyp) of
Left err -> pure (Left err)
Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))
InvertedAttributeNames names -> do
let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
if not (S.null nonExistentAttributeNames) then
pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))
else
pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))
UnionAttributeNames namesA namesB -> do
eNameSetA <- evalAttributeNames namesA expr
case eNameSetA of
Left err -> pure (Left err)
Right nameSetA -> do
eNameSetB <- evalAttributeNames namesB expr
case eNameSetB of
Left err -> pure (Left err)
Right nameSetB ->
pure (Right (S.union nameSetA nameSetB))
IntersectAttributeNames namesA namesB -> do
eNameSetA <- evalAttributeNames namesA expr
case eNameSetA of
Left err -> pure (Left err)
Right nameSetA -> do
eNameSetB <- evalAttributeNames namesB expr
case eNameSetB of
Left err -> pure (Left err)
Right nameSetB ->
pure (Right (S.intersection nameSetA nameSetB))
RelationalExprAttributeNames attrExpr -> do
eAttrExprType <- typeForRelationalExpr attrExpr
case eAttrExprType of
Left err -> pure (Left err)
Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
-}
--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 (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
{-
relVarByName :: RelVarName -> GraphRefRelationalExprM GraphRefRelationalExpr
relVarByName = do
relvars <- relationVariables <$> getStateContext
case M.lookup relVarName relvars of
Nothing -> dbErr (RelVarNotDefinedError relVarName)
Just gfexpr -> pure gfExpr
-}
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