project-m36-1.2.5: src/lib/ProjectM36/RelationalExpression.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module ProjectM36.RelationalExpression where
import ProjectM36.Relation
import ProjectM36.Tuple
import qualified ProjectM36.TupleSet as TS
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.ValueMarker
import ProjectM36.DatabaseContextFunction
import ProjectM36.TransactionGraph.Types
import ProjectM36.Transaction.Types
import ProjectM36.Arbitrary
import ProjectM36.IsomorphicSchema.Types hiding (concreteDatabaseContext, subschemas)
import ProjectM36.DatabaseContext.Types
import ProjectM36.GraphRefRelationalExpr
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 (foldM, unless, when, forM_)
import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError, catchError)
import Control.Monad.Reader (ReaderT, runReaderT, asks, ask, local)
import qualified Control.Monad.Reader as R
import Control.Monad.State (gets, get, put)
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (liftIO)
import Data.Bifunctor (second)
import Data.Maybe
import Data.Either
import Data.List (foldl')
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.Trans.Except (except)
import ProjectM36.NormalizeExpr
import ProjectM36.WithNameExpr
import ProjectM36.Function
import ProjectM36.AccessControlList (RoleId, AccessControlList, SomePermission(..), relvarsACL, dbcFunctionsACL, schemaACL, transGraphACL, aclACL, allPermissionsForRole, addAccess, removeAccess)
import Test.QuickCheck
import Data.Functor (void)
import qualified Data.Functor.Foldable as Fold
import Control.Applicative
#ifdef PM36_HASKELL_SCRIPTING
import System.IO.Temp
import System.IO (hClose)
import qualified Data.Text.IO as TIO
import Data.Default
import ProjectM36.Module
import GHC hiding (getContext)
import Control.Exception
import GHC.Paths
--import System.FilePath
--import GHC.Unit.State (emptyUnitState)
--import GHC.Driver.Ppr (showSDocForUser)
--import GHC.Utils.Outputable (ppr)
--import GHC.Unit.Finder.Types (FindResult(..))
--import GHC.Unit.Finder (findImportedModule)
import GHC.Types.Name.Occurrence (mkVarOcc, mkTcOcc)
import GHC.Iface.Env (lookupOrig)
import GHC.Types.Name (getOccString)
import GHC.Core.Type (mkTyConApp)
import GHC.Builtin.Types (unitTy)
import GHC.Core.TyCo.Compare (eqType)
import Unsafe.Coerce
import Control.Monad (forM)
#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 TS.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
}
-- 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 =
case gre_extra e of
Nothing -> mempty
Just (Left tup) -> tupleAttributes tup
Just (Right attrs) -> attrs
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,
dbc_accum :: M.Map ResultAccumName ResultAccum
}
-- | To break the circular dependency loop between StaticOptimizer and RelationalExpression modules, we pass in the optimizer as a function.
--type DatabaseContextExprOptimizer = TransactionId -> DatabaseContext -> TransactionGraph -> DatabaseContextExpr -> GraphRefDatabaseContextExpr
--type DatabaseContextIOExprOptimizer = TransactionId -> DatabaseContext -> TransactionGraph -> DatabaseContextIOExpr -> GraphRefDatabaseContextIOExpr
data DatabaseContextEvalEnv = DatabaseContextEvalEnv
{ dce_transId :: TransactionId,
dce_graph :: TransactionGraph,
dce_dbcfuncutils :: DatabaseContextFunctionUtils
}
mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextFunctionUtils -> 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'})
-- | 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
graph <- dbcGraph
relVars <- resolveDBC relationVariables
let newRelVars = ValueMarker $ M.insert relVarName relExpr' relVars
potentialContext = currentContext { relationVariables = newRelVars }
--optimization: if the relexpr is unchanged, skip the update
if M.lookup relVarName relVars == Just relExpr then
pure ()
else do
--determine when to check constraints
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
graph <- dbcGraph
relVars <- resolveDBC relationVariables
if M.notMember relVarName relVars then
pure ()
else do
let newRelVars = ValueMarker $ M.delete relVarName relVars
newContext = currContext { relationVariables = newRelVars }
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
graph <- dbcGraph
relVars <- resolveDBC relationVariables
tConss <- resolveDBC typeConstructorMapping
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 TS.empty
evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do
graph <- re_graph <$> dbcRelationalExprEnv
context <- getStateContext
relVars <- resolveDBC relationVariables
tConsMapping <- resolveDBC typeConstructorMapping
let existingRelVar = M.lookup relVarName relVars
reEnv = freshGraphRefRelationalExprEnv (Just context) graph
case existingRelVar of
Nothing -> do
case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of
Left err -> dbErr err
Right reltype -> do
lift $ except $ validateAttributes tConsMapping (attributes reltype)
setRelVar relVarName expr
Just existingRel -> do
let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)
case eExpectedType of
Left err -> dbErr err
Right expectedType -> do
-- if we are targeting an existing rv, we can morph a MakeRelationFromExprs datum to fill in missing type variables'
let eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr' (Just (attributes expectedType)) expr)
case eNewExprType of
Left err -> dbErr err
Right newExprType -> do
if newExprType == expectedType then do
lift $ except $ validateAttributes tConsMapping (attributes newExprType)
setRelVar relVarName expr
else do
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 (S.singleton (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
currDeps <- resolveDBC inclusionDependencies
let newDeps = ValueMarker $ 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
currDeps <- resolveDBC inclusionDependencies
let newDeps = ValueMarker $ 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
nots <- resolveDBC notifications
transId <- dbcTransId
graph <- dbcGraph
if M.member notName nots then
dbErr (NotificationNameInUseError notName)
else do
let newNotifications = ValueMarker $ M.insert notName newNotification nots
newNotification = Notification { changeExpr = triggerExpr,
reportOldExpr = resultOldExpr,
reportNewExpr = resultNewExpr}
potentialContext = currentContext { notifications = newNotifications }
case checkConstraints potentialContext transId graph of
Left err -> dbErr err
Right () -> putStateContext potentialContext
evalGraphRefDatabaseContextExpr (RemoveNotification notName) = do
currentContext <- getStateContext
nots <- resolveDBC notifications
if M.notMember notName nots then
dbErr (NotificationNameNotInUseError notName)
else do
let newNotifications = ValueMarker $ 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
oldTypes <- resolveDBC typeConstructorMapping
let 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 = ValueMarker $ 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
oldTypes <- resolveDBC typeConstructorMapping
if isNothing (findTypeConstructor tConsName oldTypes) then
dbErr (AtomTypeNameNotInUseError tConsName)
else do
let newTypes = ValueMarker $ 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
atomFuncs <- resolveDBC atomFunctions
case atomFunctionForName funcName' atomFuncs of
Left err -> dbErr err
Right realFunc ->
if isScriptedAtomFunction realFunc then do
let updatedFuncs = ValueMarker $ HS.delete realFunc atomFuncs
putStateContext (currentContext { atomFunctions = updatedFuncs })
else
dbErr (PrecompiledFunctionRemoveError funcName')
evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName') = do
context <- getStateContext
dbcFuncs <- resolveDBC dbcFunctions
case databaseContextFunctionForName funcName' dbcFuncs of
Left err -> dbErr err
Right realFunc ->
if isScriptedDatabaseContextFunction realFunc then do
let updatedFuncs = ValueMarker $ HS.delete realFunc dbcFuncs
putStateContext (context { dbcFunctions = updatedFuncs})
else
dbErr (PrecompiledFunctionRemoveError funcName')
evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName' atomArgExprs) = do
context <- getStateContext
graph <- dbcGraph
dbcfuncutils <- dce_dbcfuncutils <$> RWS.ask
funcs <- resolveDBC dbcFunctions
--resolve atom arguments
let eAtomTypes = mapM (runGraphRefRelationalExprM gfEnv . typeForGraphRefAtomExpr emptyAttributes) atomArgExprs
eFunc = databaseContextFunctionForName funcName' funcs
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 dbcfuncutils (rights eAtomArgs) context of
Left err -> dbErr err
Right newContext -> putStateContext newContext
evalGraphRefDatabaseContextExpr (AddRegisteredQuery regName regExpr) = do
context <- getStateContext
tgraph <- dbcGraph
tid <- dbcTransId
regQueries <- resolveDBC registeredQueries
case M.lookup regName regQueries of
Just _ -> dbErr (RegisteredQueryNameInUseError regName)
Nothing -> do
let context' = context { registeredQueries = ValueMarker $ M.insert regName regExpr regQueries }
case checkConstraints context' tid tgraph of
Left err -> dbErr err
Right _ -> putStateContext context'
evalGraphRefDatabaseContextExpr (RemoveRegisteredQuery regName) = do
context <- getStateContext
regQueries <- resolveDBC registeredQueries
case M.lookup regName regQueries of
Nothing -> dbErr (RegisteredQueryNameNotInUseError regName)
Just _ -> putStateContext (context { registeredQueries = ValueMarker $ M.delete regName regQueries})
evalGraphRefDatabaseContextExpr (AlterACL alterACLExpr) = do
evalAlterDBCACLRoleIdExpr alterACLExpr
data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv
{ dbcio_transId :: TransactionId,
dbcio_graph :: TransactionGraph,
dbcio_mScriptSession :: Maybe ScriptSession,
dbcio_roleId :: RoleId,
resolveRoleNameACL :: forall x. AccessControlList RoleName x -> IO (Either RelationalError (AccessControlList RoleId x)),
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
dbcio_dbcfunctionUtils :: DatabaseContextFunctionUtils
}
type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState (ExceptT RelationalError IO) a
runDatabaseContextIOEvalMonad :: DatabaseContextIOEvalEnv -> DatabaseContext -> DatabaseContextIOEvalMonad () -> IO (Either RelationalError DatabaseContextEvalState)
runDatabaseContextIOEvalMonad env ctx m = do
res <- runExceptT $ runRWST m env freshState
case res of
Left err -> pure (Left err)
Right (_,s,_) -> pure (Right s)
where
freshState = mkDatabaseContextEvalState ctx
requireScriptSession :: DatabaseContextIOEvalMonad ScriptSession
requireScriptSession = do
env <- RWS.ask
case dbcio_mScriptSession env of
Nothing -> throwError (ScriptError ScriptCompilationDisabledError)
Just ss -> pure ss
putDBCIOContext :: DatabaseContext -> DatabaseContextIOEvalMonad ()
putDBCIOContext ctx = do
RWS.modify (\dbstate -> dbstate { dbc_context = ctx})
getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext = dbc_context <$> RWS.get
getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv
getDBCIORelationalExprEnv = do
context <- getDBCIOContext
graph <- dbcio_graph <$> RWS.ask
pure (mkRelationalExprEnv context graph)
evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad ()
#if !defined(PM36_HASKELL_SCRIPTING)
evalGraphRefDatabaseContextIOExpr AddAtomFunction{} = throwError (ScriptError ScriptCompilationDisabledError)
evalGraphRefDatabaseContextIOExpr AddDatabaseContextFunction{} = throwError (ScriptError ScriptCompilationDisabledError)
evalGraphRefDatabaseContextIOExpr LoadAtomFunctions{} = throwError (ScriptError ScriptCompilationDisabledError)
evalGraphRefDatabaseContextIOExpr LoadDatabaseContextFunctions{} = throwError (ScriptError ScriptCompilationDisabledError)
#else
evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName' funcType' script) = do
scriptSession <- requireScriptSession
currentContext <- getDBCIOContext
atomFuncs <- resolveIODBC atomFunctions
tConsMap <- resolveIODBC typeConstructorMapping
res <- liftIO $ try $ runGhc (Just libdir) $ do
setSession (hscEnv scriptSession)
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 tConsMap M.empty) adjustedAtomTypeCons
let updatedFuncs = ValueMarker $ HS.insert newAtomFunc atomFuncs
newContext = currentContext { atomFunctions = updatedFuncs }
newAtomFunc = Function { funcName = funcName',
funcType = funcAtomType,
funcBody = FunctionScriptBody script compiledFunc,
funcACL = () }
-- 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) -> throwError (ScriptError (OtherScriptCompilationError (show exc)))
Right eContext -> case eContext of
Left err -> throwError err
Right context' -> putDBCIOContext context'
evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName' funcType' script) = do
scriptSession <- requireScriptSession
currentContext <- getDBCIOContext
myRoleId <- dbcio_roleId <$> RWS.ask
--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 "RelationalError" [], ADTypeConstructor "DatabaseContext" []]
expectedType = "DatabaseContext -> Either RelationalError DatabaseContext"
actualType = show funcType'
if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
throwError (ScriptError (TypeCheckCompilationError expectedType actualType))
else do
tConsMap <- resolveIODBC typeConstructorMapping
dbcFuncs <- resolveIODBC dbcFunctions
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 tConsMap M.empty) atomArgs
let updatedDBCFuncs = ValueMarker $ HS.insert newDBCFunc dbcFuncs
newContext = currentContext { dbcFunctions = updatedDBCFuncs }
newDBCFunc = Function {
funcName = funcName',
funcType = funcAtomType,
funcBody = FunctionScriptBody script compiledFunc,
funcACL = allPermissionsForRole myRoleId
}
-- check if the name is already in use
if HS.member funcName' (HS.map funcName dbcFuncs) then
throwError (FunctionNameInUseError funcName')
else
pure newContext
case res of
Left (exc :: SomeException) -> throwError (ScriptError (OtherScriptCompilationError (show exc)))
Right eContext -> case eContext of
Left err -> throwError 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
atomFuncs <- resolveIODBC atomFunctions
let sModName = T.unpack modName
sEntrypointName = T.unpack entrypointName
eLoadFunc <- liftIO $ loadFunctions sModName sEntrypointName mModDir modPath
case eLoadFunc of
Left LoadSymbolError -> throwError LoadFunctionError
Left SecurityLoadSymbolError -> throwError SecurityLoadFunctionError
Right atomFunctionListFunc -> do
let newContext = currentContext { atomFunctions = mergedFuncs }
processedAtomFunctions = processObjectLoadedFunctions sModName sEntrypointName modPath atomFunctionListFunc
mergedFuncs = ValueMarker $ HS.union atomFuncs (HS.fromList processedAtomFunctions)
putDBCIOContext newContext
evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName entrypointName modPath) = do
currentContext <- getDBCIOContext
dbcFuncs <- resolveIODBC dbcFunctions
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 -> throwError LoadFunctionError
Left SecurityLoadSymbolError -> throwError SecurityLoadFunctionError
Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
mergedFuncs = ValueMarker $ HS.union dbcFuncs (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) (dbcio_dbcfunctionUtils env)
graph = dbcio_graph env
case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of
Left err -> throwError err
Right dbstate -> do
--Assign
let context' = dbc_context dbstate
case resolveDBC' graph context' relationVariables of
Left err -> throwError err
Right relVars -> do
let existingRelVar = M.lookup relVarName relVars
case existingRelVar of
Nothing -> throwError (RelVarNotDefinedError relVarName)
Just existingRel -> do
let gfEnv = freshGraphRefRelationalExprEnv (Just currentContext) graph
case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of
Left err -> throwError err
Right relType -> do
case resolveDBC' graph context' typeConstructorMapping of
Left err -> throwError err
Right tcMap -> do
let expectedAttributes = attributes relType
eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
case eitherRel of
Left err -> throwError err
Right rel ->
case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of
Left err -> throwError err
Right dbstate' -> putDBCIOContext (dbc_context dbstate')
evalGraphRefDatabaseContextIOExpr (LoadModuleWithFunctions moduleBody) = do
scriptSession <- requireScriptSession
importModuleFromPath scriptSession moduleBody
-- copy the module source in the db directory -- ideally this would be written into the transaction directory, but at this point, it does not yet exist
-- load the module using GHC
-- run the entrypoint function to get names of functions to convert to Atom and DBC functions
-- | run verification of all constraints
-- needs DatabaseContext to create dummy Transaction
checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do
deps <- resolveDBC' graph context inclusionDependencies
mapM_ (uncurry checkIncDep) (M.toList deps)
regQueries <- resolveDBC' graph context registeredQueries
mapM_ checkRegisteredQuery (M.toList regQueries)
notifs <- resolveDBC' graph context notifications
mapM_ checkNotification (M.toList notifs)
where
potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)
tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,
utctDayTime = secondsToDiffTime 0 }
tempSchemas = Schemas context emptyValue
tempTrans = Transaction U.nil tempTransInfo tempSchemas
tempTransInfo = TransactionInfo { parents = transId NE.:| [],
stamp = tempStamp,
merkleHash = mempty
}
process = runProcessExprM UncommittedContextMarker
gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
-- 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 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.
runGfRel e = case runGraphRefRelationalExprM gfEnv e of
Left err -> Left (wrapIncDepErr (Just err))
Right v -> Right v
wrapIncDepErr = InclusionDependencyCheckError depName
typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)
typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)
when (typeSub /= typeSuper) (Left (wrapIncDepErr (Just (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 (wrapIncDepErr (Just err))
Right resultRel -> if resultRel == relationTrue then
pure ()
else
Left (wrapIncDepErr Nothing)
--registered queries just need to typecheck- think of them as a constraints on the schema/DDL
checkRegisteredQuery (qName, relExpr) = do
let gfExpr = process (processRelationalExpr relExpr)
case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) of
Left err -> Left (RegisteredQueryValidationError qName err)
Right _ -> pure ()
checkRelExpr relExpr = do
let gfExpr = process (processRelationalExpr relExpr)
runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
checkNotification (notName, notif) = do
forM_ [(NotificationChangeExpression, changeExpr notif),
(NotificationReportOldExpression, reportOldExpr notif),
(NotificationReportNewExpression, reportNewExpr notif)] $
\(typ, relExpr) -> do
case checkRelExpr relExpr of
Left err -> Left (NotificationValidationError notName typ err)
Right _ -> pure ()
-- 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
{- 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 (\tup ctx -> do
ev1 <- expr1v tup ctx
ev2 <- expr2v tup ctx
pure (ev1 && ev2))
predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do
expr1v <- predicateRestrictionFilter attrs expr1
expr2v <- predicateRestrictionFilter attrs expr2
pure (\tup ctx -> do
ev1 <- expr1v tup ctx
ev2 <- expr2v tup ctx
pure (ev1 || ev2))
predicateRestrictionFilter _ TruePredicate = pure (\_ _ -> pure True)
predicateRestrictionFilter attrs (NotPredicate expr) = do
exprv <- predicateRestrictionFilter attrs expr
pure (\tup ctx ->
not <$> exprv tup ctx)
--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 -> ContextTuples -> Either RelationalError Relation
eval tup _ = -- context is ignored because the context is available via a closure
let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in
runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)
pure (\tup ctx -> case eval tup ctx 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 do
throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
else
pure $ \tupIn ctx -> let evalAndCmp atomIn = case atomEvald of
Right atomCmp -> atomCmp == atomIn
Left _ -> False
atomEvald = runGraphRefRelationalExprM env (evalGraphRefAtomExpr tupIn atomExpr)
ctx' = addContextTuple ctx ctxtup'
in
case contextTupleAtomForAttributeName' tupIn ctx' attrName of
Left err -> Left err
Right atomIn -> pure $ 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 (\tupIn _ ->
case runGraphRefRelationalExprM renv (evalGraphRefAtomExpr tupIn atomExpr) of
Left err -> Left err
Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))
tupleExprCheckNewAttrName :: AttributeName -> Attributes -> Either RelationalError Attributes
tupleExprCheckNewAttrName attrName attrs = if isRight (A.attributeForName attrName attrs) then
Left (AttributeNameInUseError attrName)
else
Right attrs
type ExtendTupleProcessor = (Attributes, RelationTuple -> ContextTuples -> Either RelationalError RelationTuple)
-- | Pass in existing attributes of the relational expression and the extend expr, return the new attributes and the function which will add the attribute to each tuples
extendGraphRefTupleExpressionProcessor :: Attributes -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM ExtendTupleProcessor
extendGraphRefTupleExpressionProcessor attrsIn (AttributeExtendTupleExpr newAttrName atomExpr) =
-- renv <- askEnv
-- check that the attribute name is not in use
case tupleExprCheckNewAttrName newAttrName attrsIn of
Left err -> throwError err
Right _ -> do
atomExprType <- typeForGraphRefAtomExpr attrsIn atomExpr
atomExprType' <- verifyGraphRefAtomExprTypes attrsIn atomExpr atomExprType
let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
newAndOldAttrs = A.addAttributes attrsIn newAttrs
env <- ask
pure (newAndOldAttrs, \tupIn (ContextTuples tupsIn) -> do
let gfEnv = foldl' (flip mergeTuplesIntoGraphRefRelationalExprEnv) env tupsIn
atom <- runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr tupIn atomExpr)
Right (tupleAtomExtend newAttrName atom tupIn)
)
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
-- first argumentr is starting value, second argument is relationatom
evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName' arguments tid) = do
argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments
graph <- gfGraph
context <- gfDatabaseContextForMarker tid
functions <- lift $ except $ resolveDBC' graph context atomFunctions
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 (SubrelationAttributeAtomExpr relAttr subAttr) = do
atom <- evalGraphRefAtomExpr tupIn (AttributeAtomExpr relAttr)
case atom of
RelationAtom rel ->
pure (SubrelationFoldAtom rel subAttr)
_ -> throwError (AttributeIsNotRelationValuedError relAttr)
evalGraphRefAtomExpr tupIn (IfThenAtomExpr ifExpr thenExpr elseExpr) = do
conditional <- evalGraphRefAtomExpr tupIn ifExpr
case conditional of
BoolAtom True -> evalGraphRefAtomExpr tupIn thenExpr
BoolAtom False -> evalGraphRefAtomExpr tupIn elseExpr
otherAtom -> throwError (IfThenExprExpectedBooleanError (atomTypeForAtom otherAtom))
evalGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _)
| tOrF == "True" = pure (BoolAtom True)
| tOrF == "False" = pure (BoolAtom False)
evalGraphRefAtomExpr tupIn consE@(ConstructedAtomExpr dConsName dConsArgs _) = do --why is the tid unused here? suspicious
let mergeEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn
aType <- local mergeEnv (typeForGraphRefAtomExpr (tupleAttributes tupIn) consE)
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 err
Left err -> throwError err
typeForGraphRefAtomExpr attrs (SubrelationAttributeAtomExpr relAttr subAttr) = do
relType <- typeForGraphRefAtomExpr attrs (AttributeAtomExpr relAttr)
case relType of
RelationAtomType relAttrs ->
case A.atomTypeForAttributeName subAttr relAttrs of
Left err -> throwError err
Right attrType -> pure (SubrelationFoldAtomType attrType)
_ -> throwError (AttributeIsNotRelationValuedError relAttr)
typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)
typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName' atomArgs transId) = do
ctx <- gfDatabaseContextForMarker transId
graph <- gfGraph
case resolveDBC' graph ctx atomFunctions of
Left err -> throwError err
Right funcs -> do
case atomFunctionForName funcName' funcs of
Left err -> throwError err
Right func -> do
let funcRetType = last (funcType func)
funcArgTypes = init (funcType func)
funArgCount = length funcArgTypes
inArgCount = length atomArgs
when (funArgCount /= inArgCount) (throwError (FunctionArgumentCountMismatchError funArgCount inArgCount))
argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs
mapM_ (\(fArg,arg,argCount) -> do
let handler :: RelationalError -> GraphRefRelationalExprM AtomType
handler (AtomTypeMismatchError expSubType actSubType) = do
throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType)
handler err = throwError err
lift (except $ atomTypeVerify fArg arg) `catchError` handler
) (zip3 funcArgTypes argTypes [1..])
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))
typeForGraphRefAtomExpr attrs (IfThenAtomExpr ifExpr thenExpr elseExpr) = do
-- ifExpr must be BoolAtomType
ifType <- typeForGraphRefAtomExpr attrs ifExpr
when (ifType /= BoolAtomType) $ throwError (IfThenExprExpectedBooleanError ifType)
-- thenExpr and elseExpr must return the same type
thenType <- typeForGraphRefAtomExpr attrs thenExpr
elseType <- typeForGraphRefAtomExpr attrs elseExpr
when (thenType /= elseType) $ throwError (AtomTypeMismatchError thenType elseType)
pure thenType
-- grab the type of the data constructor, then validate that the args match the expected types
typeForGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _) | tOrF `elem` ["True", "False"] =
pure BoolAtomType
typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =
do
argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs
ctx <- gfDatabaseContextForMarker tid
graph <- gfGraph
case resolveDBC' graph ctx typeConstructorMapping of
Left err -> throwError err
Right tConsMap ->
lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes
-- | Validate that the type of the AtomExpr matches the expected type.
verifyGraphRefAtomExprTypes :: Attributes -> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
verifyGraphRefAtomExprTypes attrsIn (AttributeAtomExpr attrName) expectedType = do
env <- askEnv
case A.atomTypeForAttributeName attrName attrsIn 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 attrsIn (SubrelationAttributeAtomExpr relAttr subAttr) expectedType = do
let mergedAttrsEnv = mergeAttributesIntoGraphRefRelationalExprEnv attrsIn
(Relation relAttrs _) <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr (RelationValuedAttribute relAttr))
subAttrType <- lift $ except $ A.atomTypeForAttributeName subAttr relAttrs
lift $ except $ atomTypeVerify expectedType (SubrelationFoldAtomType subAttrType)
verifyGraphRefAtomExprTypes attrsIn (FunctionAtomExpr funcName' funcArgExprs tid) expectedType = do
context <- gfDatabaseContextForMarker tid
graph <- gfGraph
functions <- lift $ except $ resolveDBC' graph context atomFunctions
func <- lift $ except $ atomFunctionForName funcName' functions
let expectedArgTypes = funcType func
funcArgVerifier (atomExpr, expectedType2, argCount) = do
let handler :: RelationalError -> GraphRefRelationalExprM AtomType
handler (AtomTypeMismatchError expSubType actSubType) = do
throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType)
handler err = throwError err
verifyGraphRefAtomExprTypes attrsIn 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 attrsIn (RelationAtomExpr relationExpr) expectedType =
do
let mergedAttrsEnv = mergeAttributesIntoGraphRefRelationalExprEnv attrsIn
relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)
lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType))
verifyGraphRefAtomExprTypes attrsIn consE@ConstructedAtomExpr{} expectedType = do
cType <- typeForGraphRefAtomExpr attrsIn consE
lift $ except $ atomTypeVerify expectedType cType
verifyGraphRefAtomExprTypes attrsIn (IfThenAtomExpr _ifExpr thenExpr elseExpr) expectedType = do
thenType <- typeForGraphRefAtomExpr attrsIn thenExpr
elseType <- typeForGraphRefAtomExpr attrsIn elseExpr
when (thenType /= elseType) $ throwError (AtomTypeMismatchError thenType elseType)
lift $ except $ atomTypeVerify expectedType thenType
-- | Look up the type's name and create a new attribute.
evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do
ctx <- gfDatabaseContextForMarker transId
graph <- gfGraph
case resolveDBC' graph ctx typeConstructorMapping of
Left err -> throwError err
Right tConsMap -> do
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
graph <- gfGraph
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
let getTypeConsMap ctx =
case resolveDBC' graph ctx typeConstructorMapping of
Left err -> throwError err
Right m -> pure m
tConsMap <- case singularTransactions tupleExprL of
SingularTransactionRef commonTransId -> do
ctx <- gfDatabaseContextForMarker commonTransId
getTypeConsMap ctx
NoTransactionsRef -> do
ctx <- gfDatabaseContextForMarker fixedMarker
getTypeConsMap ctx
-- 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) $ do
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 = case tuples of
[] -> A.emptyAttributes
x : _ -> tupleAttributes x
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
graph <- gfGraph
rvs <- lift $ except $ resolveDBC' graph ctx relationVariables
case M.lookup name rvs of
Nothing -> throwError (RelVarNotDefinedError name)
Just rv -> evalGraphRefRelationalExpr rv
evalGraphRefRelationalExpr (RelationValuedAttribute attrName) = do
env <- askEnv
case gre_extra env of
Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName))
Just (Left ctxtup) -> do
atom <- lift $ except $ atomForAttributeName attrName ctxtup
case atom of
RelationAtom rel -> pure rel
other -> throwError (AtomTypeMismatchError (RelationAtomType mempty) (atomTypeForAtom other))
Just (Right _) -> throwError (NoSuchAttributeNamesError (S.singleton attrName))
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 attrsSet expr) = do
rel <- evalGraphRefRelationalExpr expr
lift $ except $ renameMany attrsSet 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 (attributes rel) extendTupleExpr
extraTup <- asks envTuple
let ctx = singletonContextTuple extraTup
lift $ except $ relMogrify (`tupProc` ctx) 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
| otherwise =
let sameTID (Transaction idMatch _ _) = idMatch == tid
matchingTrans = S.filter sameTID $ transactionsForGraph graph
in case S.toList matchingTrans of
[] -> Left $ NoSuchTransactionError tid
x : _ -> Right x
typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr = typeForGraphRefRelationalExpr' Nothing
typeForGraphRefRelationalExpr' :: Maybe Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr' _thints (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs TS.empty
typeForGraphRefRelationalExpr' _thints (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))
typeForGraphRefRelationalExpr' mAttributeTypeHints (MakeRelationFromExprs mAttrExprs tupleExprs) = do
mAttrs <- case mAttributeTypeHints of
Nothing ->
case mAttrExprs of
Just attrExprs -> do
attrs <- mapM evalGraphRefAttributeExpr attrExprs
pure (Just (attributesFromList attrs))
Nothing -> pure Nothing
Just attrTypeHints -> pure (Just attrTypeHints)
retAttrs <- typeForGraphRefTupleExprs mAttrs tupleExprs
case mAttrs of
Nothing ->
pure $ emptyRelationWithAttrs retAttrs
Just attrs ->
case A.reorderAttributes attrs retAttrs of
Left err -> throwError err
Right retAttrs' ->
pure $ emptyRelationWithAttrs retAttrs'
typeForGraphRefRelationalExpr' _th (RelationVariable rvName tid) = do
ctx <- gfDatabaseContextForMarker tid
graph <- gfGraph
case resolveDBC' graph ctx relationVariables of
Left err -> throwError err
Right relVars -> do
case M.lookup rvName relVars of
Nothing -> throwError (RelVarNotDefinedError rvName)
Just rvExpr ->
typeForGraphRefRelationalExpr rvExpr
typeForGraphRefRelationalExpr' _th (RelationValuedAttribute attrName) = do
env <- askEnv
case gre_extra env of
Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) -- or can this be an attribute at the top-level?
Just (Left ctxtup) -> do
atom <- lift $ except $ atomForAttributeName attrName ctxtup
case atom of
RelationAtom rel -> pure (emptyRelationWithAttrs (attributes rel))
other -> throwError (AtomTypeMismatchError (RelationAtomType mempty) (atomTypeForAtom other))
Just (Right attrs) -> do
case A.atomTypeForAttributeName attrName attrs of
Left{} -> throwError (NoSuchAttributeNamesError (S.singleton attrName))
Right typ -> do
case typ of
RelationAtomType relAttrs -> pure $ emptyRelationWithAttrs relAttrs
other -> throwError (AtomTypeMismatchError (RelationAtomType A.emptyAttributes) other)
typeForGraphRefRelationalExpr' _th (Project attrNames expr) = do
exprType' <- typeForGraphRefRelationalExpr expr
projectionAttrs <- evalGraphRefAttributeNames attrNames expr
lift $ except $ project projectionAttrs exprType'
typeForGraphRefRelationalExpr' _th (Union exprA exprB) = do
exprA' <- typeForGraphRefRelationalExpr exprA
exprB' <- typeForGraphRefRelationalExpr exprB
lift $ except $ union exprA' exprB'
typeForGraphRefRelationalExpr' _th (Join exprA exprB) = do
exprA' <- typeForGraphRefRelationalExpr exprA
exprB' <- typeForGraphRefRelationalExpr exprB
lift $ except $ join exprA' exprB'
typeForGraphRefRelationalExpr' _th (Rename attrs expr) = do
expr' <- typeForGraphRefRelationalExpr expr
lift $ except $ renameMany attrs expr'
typeForGraphRefRelationalExpr' _th (Difference exprA exprB) = do
exprA' <- typeForGraphRefRelationalExpr exprA
exprB' <- typeForGraphRefRelationalExpr exprB
lift $ except $ difference exprA' exprB'
typeForGraphRefRelationalExpr' mHints (Group groupNames attrName expr) = do
expr' <- typeForGraphRefRelationalExpr' mHints expr
groupNames' <- evalGraphRefAttributeNames groupNames expr
lift $ except $ group groupNames' attrName expr'
typeForGraphRefRelationalExpr' _th (Ungroup groupAttrName expr) = do
expr' <- typeForGraphRefRelationalExpr expr
lift $ except $ ungroup groupAttrName expr'
typeForGraphRefRelationalExpr' _th (Restrict pred' expr) = do
expr' <- typeForGraphRefRelationalExpr expr
let mergedAttrsEnv = mergeAttributesIntoGraphRefRelationalExprEnv (attributes expr')
R.local mergedAttrsEnv (typeForGraphRefRestrictionPredicateExpr pred')
filt <- predicateRestrictionFilter (attributes expr') pred'
lift $ except $ restrict filt expr'
typeForGraphRefRelationalExpr' _th Equals{} =
pure relationFalse
typeForGraphRefRelationalExpr' _th NotEquals{} =
pure relationFalse
typeForGraphRefRelationalExpr' _th (Extend extendTupleExpr expr) = do
rel <- typeForGraphRefRelationalExpr expr
evalGraphRefRelationalExpr (Extend extendTupleExpr (ExistingRelation rel))
typeForGraphRefRelationalExpr' _th expr@(With withs _) = do
let expr' = substituteWithNameMacros [] expr
checkMacroName (WithNameExpr macroName tid) = do
ctx <- gfDatabaseContextForMarker tid
graph <- gfGraph
case resolveDBC' graph ctx relationVariables of
Left err -> throwError err
Right rvs ->
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'
-- | Typecheck for restriction predicate- predicates always return Bool, so the return value is nominal.
typeForGraphRefRestrictionPredicateExpr :: GraphRefRestrictionPredicateExpr -> GraphRefRelationalExprM ()
typeForGraphRefRestrictionPredicateExpr expr = do
extra <- asks gre_extra
let attrs = case extra of
Nothing -> mempty
Just (Right attrs') -> attrs'
Just (Left _) -> error "never" -- mempty -- should never happen
self = typeForGraphRefRestrictionPredicateExpr
case expr of
TruePredicate -> pure ()
AndPredicate a b -> do
self a
self b
OrPredicate a b -> do
self a
self b
NotPredicate a -> self a
RelationalExprPredicate relExpr -> do
rType <- typeForGraphRefRelationalExpr relExpr
unless (A.null (attributes rType)) $ throwError (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
AtomExprPredicate atomExpr -> do
void $ typeForGraphRefAtomExpr attrs atomExpr
AttributeEqualityPredicate attrName atomExpr -> do
void $ typeForGraphRefAtomExpr attrs atomExpr
unless (A.isAttributeNameContained attrName attrs) $ throwError (NoSuchAttributeNamesError (S.singleton attrName))
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
ctx <- gfDatabaseContextForMarker tid
graph <- gfGraph
case resolveDBC' graph ctx typeConstructorMapping of
Left err -> throwError err
Right tConsMap ->
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' :: TransactionGraph -> ValueMarker RelationVariables -> Either RelationalError (ValueMarker RelationVariables)
mkEmptyRelVars' graph v_rvs = do
rvs <- resolveValueMarker graph relationVariables v_rvs
pure (ValueMarker (mkEmptyRelVars rvs))
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 TS.empty
mkEmptyRelVar (ExistingRelation rel) = ExistingRelation (emptyRelationWithAttrs (attributes rel))
mkEmptyRelVar x@RelationValuedAttribute{} = x
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 attrs expr) = Rename attrs (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
relVars <- resolveDBC' graph ctx relationVariables
let subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]
attrs = A.attributesFromList [Attribute "name" TextAtomType,
Attribute "attributes" (RelationAtomType subrelAttrs)]
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
getGraph :: m TransactionGraph
instance DatabaseContextM (ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity)) where
getContext = gfDatabaseContextForMarker UncommittedContextMarker
getGraph = gfGraph
instance DatabaseContextM (RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity)) where
getContext = getStateContext
getGraph = dbcGraph
relVarByName :: DatabaseContextM m => RelVarName -> m GraphRefRelationalExpr
relVarByName rvName = do
ctx <- getContext
graph <- getGraph
case resolveDBC' graph ctx relationVariables of
Left err -> throwError err
Right relvars ->
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@RelationValuedAttribute{} = pure orig
resolve orig@(RelationVariable rvName UncommittedContextMarker) = do
ctx <- getStateContext
graph <- dbcGraph
case resolveDBC' graph ctx relationVariables of
Left err -> throwError err
Right relVars ->
case M.lookup rvName relVars 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 attrs expr) = Rename attrs <$> 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@SubrelationAttributeAtomExpr{} = 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 (IfThenAtomExpr ifExpr thenExpr elseExpr) = IfThenAtomExpr <$> resolve ifExpr <*> resolve thenExpr <*> resolve elseExpr
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 exprB) | isEmptyRelationExpr exprA = exprB
opt (UnionF exprA exprB) | isEmptyRelationExpr 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
-- determine if the created relation can statically be determined to be empty
isEmptyRelationExpr :: RelationalExprBase a -> Bool
isEmptyRelationExpr (MakeRelationFromExprs _ (TupleExprs _ [])) = True
isEmptyRelationExpr (MakeStaticRelation _ tupSet) = null (asList tupSet)
isEmptyRelationExpr (ExistingRelation rel) = TS.null (tupleSet rel)
isEmptyRelationExpr _ = False
firstAtomForAttributeName :: AttributeName -> [RelationTuple] -> GraphRefRelationalExprM Atom
firstAtomForAttributeName attrName tuples = do
let folder tup acc =
case atomForAttributeName attrName tup of
Left{} -> acc
Right atom -> Just atom
case foldr folder Nothing tuples of
Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName))
Just match -> pure match
resolveDBC :: (DatabaseContext -> ValueMarker a) -> DatabaseContextEvalMonad a
resolveDBC f = do
graph <- dbcGraph
context <- getStateContext
case resolveDBC' graph context f of
Left err -> throwError err
Right v -> pure v
resolveIODBC :: (DatabaseContext -> ValueMarker a) -> DatabaseContextIOEvalMonad a
resolveIODBC f = do
env <- ask
let graph = dbcio_graph env
context <- getDBCIOContext
case resolveDBC' graph context f of
Left err -> throwError err
Right v -> pure v
resolveGR :: (DatabaseContext -> ValueMarker a) ->
GraphRefRelationalExprM a
resolveGR f = do
graph <- gfGraph
mcontext <- gre_context <$> askEnv
case mcontext of
Nothing -> throwError NoUncommittedContextInEvalError
Just context ->
case resolveDBC' graph context f of
Left err -> throwError err
Right v -> pure v
-- | Recursively resolve a property of a database context.
resolveDBC' :: TransactionGraph ->
DatabaseContext ->
(DatabaseContext -> ValueMarker a) ->
Either RelationalError a
resolveDBC' graph ctx f =
case f ctx of
ValueMarker val -> pure val
NotChangedSinceMarker tid -> do
t <- transactionForId tid graph
resolveDBC' graph (concreteDatabaseContext t) f
resolveValueMarker :: TransactionGraph -> (DatabaseContext -> ValueMarker a) -> ValueMarker a -> Either RelationalError a
resolveValueMarker _graph _f (ValueMarker a) = pure a
resolveValueMarker graph f (NotChangedSinceMarker tid) = do
t <- transactionForId tid graph
resolveDBC' graph (concreteDatabaseContext t) f
-- | Ensure that the notification contains valid, type-checkable relational expressions. These relational expressions therefore become registered queries: queries which must remain valid.
validateNotification :: Notification -> DatabaseContext -> TransactionGraph -> Either RelationalError Notification
validateNotification notif context graph = do
let reEnv = mkRelationalExprEnv context graph
runRelationalExprM reEnv $ do
_ <- typeForRelationalExpr (changeExpr notif)
_ <- typeForRelationalExpr (reportOldExpr notif)
_ <- typeForRelationalExpr (reportNewExpr notif)
pure notif
-- | Resolved all fields which link to previous transactions.
toResolvedDatabaseContext :: DatabaseContext -> TransactionGraph -> Either RelationalError ResolvedDatabaseContext
toResolvedDatabaseContext ctx graph = do
incDeps <- resolveDBC' graph ctx inclusionDependencies
relVars <- resolveDBC' graph ctx relationVariables
aFuncs <- resolveDBC' graph ctx atomFunctions
dbcFuncs <- resolveDBC' graph ctx dbcFunctions
nots <- resolveDBC' graph ctx notifications
tConsMap <- resolveDBC' graph ctx typeConstructorMapping
regQs <- resolveDBC' graph ctx registeredQueries
acls <- resolveDBC' graph ctx acl
pure (DatabaseContext {
inclusionDependencies = Identity incDeps,
relationVariables = Identity relVars,
atomFunctions = Identity aFuncs,
dbcFunctions = Identity dbcFuncs,
notifications = Identity nots,
typeConstructorMapping = Identity tConsMap,
registeredQueries = Identity regQs,
acl = Identity acls
})
-- | RoleIds is resolved from the RoleName presented in the DatabaseContextExpr.
evalAlterDBCACLRoleIdExpr :: AlterDBCACLRoleIdExpr -> DatabaseContextEvalMonad ()
evalAlterDBCACLRoleIdExpr expr = do
acl' <- resolveDBC acl
ctx <- getStateContext
case expr of
GrantAccessExpr roleId somePerm mgrant -> do
let newAcl =
case somePerm of
SomeRelVarPermission perm ->
acl' { relvarsACL = addAccess roleId perm mgrant (relvarsACL acl') }
SomeFunctionPermission perm ->
acl' { dbcFunctionsACL = addAccess roleId perm mgrant (dbcFunctionsACL acl') }
SomeAlterSchemaPermission perm ->
acl' { schemaACL = addAccess roleId perm mgrant (schemaACL acl') }
SomeAlterTransGraphPermission perm ->
acl' { transGraphACL = addAccess roleId perm mgrant (transGraphACL acl') }
SomeACLPermission perm ->
acl' { aclACL = addAccess roleId perm mgrant (aclACL acl') }
SomeDBCFunctionPermission{} -> acl'
putStateContext (ctx {
acl = ValueMarker newAcl
})
RevokeAccessExpr roleId somePerm -> do
let newAcl =
case somePerm of
SomeRelVarPermission perm ->
acl' { relvarsACL = removeAccess roleId perm (relvarsACL acl') }
SomeFunctionPermission perm ->
acl' { dbcFunctionsACL = removeAccess roleId perm (dbcFunctionsACL acl') }
SomeAlterSchemaPermission perm ->
acl' { schemaACL = removeAccess roleId perm (schemaACL acl') }
SomeAlterTransGraphPermission perm ->
acl' { transGraphACL = removeAccess roleId perm (transGraphACL acl') }
SomeACLPermission perm ->
acl' { aclACL = removeAccess roleId perm (aclACL acl') }
SomeDBCFunctionPermission{} -> acl'
putStateContext (ctx {
acl = ValueMarker newAcl
})
GrantDBCFunctionAccessExpr roleId funcName' perm mgrant -> do
dbcFuncs <- resolveDBC dbcFunctions
case functionForName funcName' dbcFuncs of
Left err -> dbErr err
Right func -> do
let newCtx = ctx { dbcFunctions = ValueMarker (HS.insert newFunc (HS.delete func dbcFuncs)) }
newFunc = func { funcACL = addAccess roleId perm mgrant (funcACL func) }
putStateContext newCtx
RevokeDBCFunctionAccessExpr roleId funcName' perm -> do
dbcFuncs <- resolveDBC dbcFunctions
case functionForName funcName' dbcFuncs of
Left err -> dbErr err
Right func -> do
let newCtx = ctx { dbcFunctions = ValueMarker (HS.insert newFunc dbcFuncs) }
newFunc = func { funcACL = removeAccess roleId perm (funcACL func) }
putStateContext newCtx
typeForGraphRefTupleExprs :: Maybe Attributes -> GraphRefTupleExprs -> GraphRefRelationalExprM Attributes
typeForGraphRefTupleExprs Nothing (TupleExprs _ []) = pure A.emptyAttributes
typeForGraphRefTupleExprs (Just attrs) (TupleExprs _ []) = pure attrs
typeForGraphRefTupleExprs mAttrs (TupleExprs _ tupExprs) = do
let folder acc tupExpr = do
nextAttrs <- typeForGraphRefTupleExpr mAttrs tupExpr
case acc of
[] -> pure [nextAttrs]
(prevAttrs:_) -> do
let attrsDiff = A.attributesDifference nextAttrs prevAttrs
if attrsDiff == A.emptyAttributes then
pure (nextAttrs:acc)
else
throwError (TupleAttributeTypeMismatchError attrsDiff)
attrsList <- foldM folder [] tupExprs
pure (head attrsList)
typeForGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM Attributes
typeForGraphRefTupleExpr mAttrHints (TupleExpr tupMap) = do
let attrs = fromMaybe A.emptyAttributes mAttrHints
resolveOneAtomType (attrName, atomExpr) = do
let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs
unresolvedType <- typeForGraphRefAtomExpr attrs atomExpr
resolvedType <- case eExpectedAtomType of
Left _ -> pure unresolvedType
Right typeHint ->
lift $ except $ resolveAtomType typeHint unresolvedType
pure (Attribute attrName resolvedType)
attrList <- mapM resolveOneAtomType (M.toList tupMap)
pure (A.attributesFromList attrList)
importModuleFromPath :: ScriptSession -> ModuleBody -> DatabaseContextIOEvalMonad ()
#if !defined(PM36_HASKELL_SCRIPTING)
importModuleFromPath _scriptSession _moduleSource = throwError (ScriptError ScriptCompilationDisabledError)
#else
importModuleFromPath scriptSession moduleSource = do
resolveRoleNameACLF <- resolveRoleNameACL <$> ask
res <- liftIO $ try $ do
withSystemTempFile "pm36module" $ \tempModulePath tempModuleHandle -> do
hClose tempModuleHandle
TIO.writeFile tempModulePath moduleSource
runGhc (Just libdir) $ do
-- GHC needs to see the module on disk, so we write it to a temporary location
setSession (hscEnv scriptSession)
dflags <- getSessionDynFlags
let target = Target {
targetId = TargetFile tempModulePath Nothing,
targetAllowObjCode = False,
targetUnitId = homeUnitId_ dflags,
targetContents = Nothing
}
setTargets [target]
loadSuccess <- load LoadAllTargets
case loadSuccess of
Failed -> pure (Left (ScriptError ModuleLoadError))
Succeeded -> do
{- modRes <- liftIO $ findImportedModule (hscEnv scriptSession) (mkModuleName "ProjectM36.Base") NoPkgQual
liftIO $ case modRes of
Found modLoc _mod -> do
let packageLoc = takeDirectory (takeDirectory (takeDirectory (ml_dyn_obj_file modLoc)))
putStrLn packageLoc
NoPackage{} -> error "no package"
FoundMultiple{} -> error "multiple matches"
NotFound{} -> error "not found"-}
modGraph <- depanal [] False
case mgModSummaries modGraph of
[] -> pure (Left (ScriptError ModuleLoadError))
(modSummary:_) -> do
let modName = ms_mod_name modSummary
modModS = "ProjectM36.Module"
modModName = mkModuleName modModS
pm36FuncName = "projectM36Functions"
occName = mkVarOcc pm36FuncName
occExpectedType = mkTcOcc "EntryPoints"
setContext [IIModule modName,
IIDecl $ safeImportDecl "ProjectM36.Base" Nothing
]
userModule <- findModule modName Nothing
moduleModule <- findModule modModName Nothing
(_msgs, Just (entrypointFunc, entryPointsMonadName)) <- liftIO $ runTcInteractive (hscEnv scriptSession) $ do
pm36Name <- lookupOrig userModule occName
entryPointsName <- lookupOrig moduleModule occExpectedType
pure (pm36Name, entryPointsName)
monadTy <- lookupName entryPointsMonadName
let unexpectedEP s = throw (ScriptError (OtherScriptCompilationError ("expected " <> pm36FuncName <> " signature: " <> s)))
entryPointsTyCon <- case monadTy of
Just (ATyCon tc) -> pure $ mkTyConApp tc [unitTy]
Just (AnId _tc) -> unexpectedEP "AnId"
Just (AConLike _clike) -> unexpectedEP "AConLike"
Just (ACoAxiom _cax) -> unexpectedEP "ACoAxiom"
Nothing -> unexpectedEP "missing"
tyThing <- lookupName entrypointFunc
case tyThing of
Just (ATyCon _iCon) -> unexpectedEP "ATyCon"
Just (ACoAxiom _) -> unexpectedEP "ACoAxoim"
--run the entrypoints monad
Just (AnId aid)
| getOccString aid == pm36FuncName ->
-- typecheck entrypoint function
if idType aid `eqType` entryPointsTyCon then do
-- call entrypoint
result <- compileExpr pm36FuncName
let funcDeclarations = runEntryPoints (unsafeCoerce result)
tyConv <- mkTypeConversions
mkFunctions <- forM funcDeclarations $ \funcDecl -> do
case funcDecl of
DeclareDatabaseContextFunction funcS roleNameACL -> do
--resolve role name ACL into role-id-based ACL
eACL <- liftIO $ resolveRoleNameACLF roleNameACL
case eACL of
Left err -> throw err
Right acl' -> do
fType <- exprType TM_Default (T.unpack funcS)
dbcFuncMonadType <- exprType TM_Default "undefined :: DatabaseContextFunctionMonad ()"
-- extract arguments for dbc function
let eAtomFuncType = convertGhcTypeToDatabaseContextFunctionAtomType dflags tyConv dbcFuncMonadType fType
case eAtomFuncType of
Left err -> throw (OtherScriptCompilationError (show err))
Right dbcFuncType -> do
let interpretedFunc = wrapDatabaseContextFunction dbcFuncType funcS
dbcFunc :: DatabaseContextFunctionBodyType <- unsafeCoerce <$> compileExpr interpretedFunc
let newDBCFunc = Function { funcName = funcS,
funcType = dbcFuncType,
funcBody = FunctionScriptBody (T.pack interpretedFunc) dbcFunc,
funcACL = acl' }
pure (MkDatabaseContextFunction newDBCFunc)
DeclareAtomFunction funcS -> do
--extract type from function in script
fType <- exprType TM_Default (T.unpack funcS)
let eAtomFuncType = convertGhcTypeToFunctionAtomType dflags tyConv fType
liftIO $ print eAtomFuncType
--liftIO $ putStrLn $ showSDocForUser dflags emptyUnitState alwaysQualify (ppr fType)
case eAtomFuncType of
Left err -> error (show err)
Right atomFuncType -> do
let eInterpretedFunc = wrapAtomFunction atomFuncType funcS
--liftIO $ print eInterpretedFunc
case eInterpretedFunc of
Left err -> error (show err)
Right interpretedFunc -> do
atomFunc :: AtomFunctionBodyType <- unsafeCoerce <$> compileExpr interpretedFunc
--todo - return atom functions and dbc functions out of Ghc monad to add them to the context
let newAtomFunc = Function { funcName = funcS,
funcType = atomFuncType,
funcBody = FunctionScriptBody (T.pack interpretedFunc) atomFunc,
funcACL = def }
--let execd = atomFunc [IntegerAtom 10, IntegerAtom 20]
--liftIO $ print execd
pure (MkAtomFunction newAtomFunc)
pure (Right mkFunctions)
else
unexpectedEP "type mismatch"
Just AnId{} -> unexpectedEP "AnId"
Just AConLike{} -> unexpectedEP "AConLike"
Nothing -> unexpectedEP "Nothing"
case res of
Left exc -> throwError exc
Right eMkFunctions ->
case eMkFunctions of
Left err -> throwError err
Right mkFunctions -> do
ctx <- getDBCIOContext
atomFuncs <- resolveIODBC atomFunctions
dbcFuncs <- resolveIODBC dbcFunctions
-- must must delete the function from the hashset in order to replace it
let foldMkFunction (atomFuncHS, dbcFuncHS) (MkAtomFunction atomFunc) =
(addOrReplaceFunction atomFunc atomFuncHS, dbcFuncHS)
foldMkFunction (atomFuncHS, dbcFuncHS) (MkDatabaseContextFunction dbcFunc) =
(atomFuncHS, addOrReplaceFunction dbcFunc dbcFuncHS)
(newAtomFuncs, newDBCFuncs) = foldl' foldMkFunction (atomFuncs, dbcFuncs) mkFunctions
ctx' = ctx { dbcFunctions = ValueMarker newDBCFuncs,
atomFunctions = ValueMarker newAtomFuncs
}
putDBCIOContext ctx'
#endif
data MkFunction = MkAtomFunction AtomFunction |
MkDatabaseContextFunction DatabaseContextFunction