{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module ProjectM36.RelationalExpression where
import ProjectM36.Relation
import ProjectM36.Tuple
import ProjectM36.TupleSet
import ProjectM36.Base
import qualified Data.UUID as U
import ProjectM36.Error
import ProjectM36.AtomType
import ProjectM36.Attribute (emptyAttributes, attributesFromList)
import ProjectM36.ScriptSession
import ProjectM36.DataTypes.Primitive
import ProjectM36.AtomFunction
import ProjectM36.DatabaseContextFunction
import ProjectM36.Arbitrary
import ProjectM36.GraphRefRelationalExpr
import ProjectM36.Transaction
import qualified ProjectM36.Attribute as A
import qualified Data.Map as M
import qualified Data.HashSet as HS
import qualified Data.Set as S
import Control.Monad.State hiding (join)
import Data.Bifunctor (second)
import Data.Maybe
import Data.Either
import Data.Char (isUpper)
import Data.Time
import qualified Data.List.NonEmpty as NE
import Data.Functor.Identity
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified ProjectM36.TypeConstructorDef as TCD
import qualified Control.Monad.RWS.Strict as RWS
import Control.Monad.RWS.Strict (RWST, execRWST, runRWST)
import Control.Monad.Except hiding (join)
import Control.Monad.Trans.Except (except)
import Control.Monad.Reader as R hiding (join)
import ProjectM36.NormalizeExpr
import ProjectM36.WithNameExpr
import Test.QuickCheck
#ifdef PM36_HASKELL_SCRIPTING
import GHC hiding (getContext)
import Control.Exception
import GHC.Paths
#endif
data DatabaseContextExprDetails = CountUpdatedTuples
databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc
databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTups
where
attrs = A.attributesFromList [Attribute "count" IntAtomType]
existingTuple = fromMaybe (error "impossible counting error in singletonTuple") (singletonTuple relIn)
existingCount = case V.head (tupleAtoms existingTuple) of
IntAtom v -> v
_ -> error "impossible counting error in tupleAtoms"
newTups = case mkTupleSetFromList attrs [[IntAtom (existingCount + 1)]] of
Left err -> error ("impossible counting error in " ++ show err)
Right ts -> ts
mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
mkDatabaseContextEvalState context = DatabaseContextEvalState {
dbc_context = context,
dbc_accum = M.empty,
dbc_dirty = False
}
data RelationalExprEnv = RelationalExprEnv {
re_context :: DatabaseContext,
re_graph :: TransactionGraph,
re_extra :: Maybe (Either RelationTuple Attributes)
}
envTuple :: GraphRefRelationalExprEnv -> RelationTuple
envTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (gre_extra e))
envAttributes :: GraphRefRelationalExprEnv -> Attributes
envAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (gre_extra e))
instance Show RelationalExprEnv where
show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)
type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a
runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either RelationalError a
runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))
reGraph :: RelationalExprM TransactionGraph
reGraph = asks re_graph
reContext :: RelationalExprM DatabaseContext
reContext = asks re_context
mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv
mkRelationalExprEnv ctx graph =
RelationalExprEnv
{ re_context = ctx,
re_graph = graph,
re_extra = Nothing }
askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv = R.ask
mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =
e{ gre_extra = new_elems }
where
new_elems = Just (Left newTuple)
mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))
newTuple = mkRelationTupleFromMap mergedTupMap
mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeAttributesIntoGraphRefRelationalExprEnv attrsIn e = e { gre_extra = newattrs }
where
newattrs = Just (Right (A.union attrsIn (envAttributes e)))
type ResultAccumName = StringType
type ResultAccumFunc = (RelationTuple -> Relation -> Relation) -> Relation -> Relation
data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,
resultAccumResult :: Relation
}
data DatabaseContextEvalState = DatabaseContextEvalState {
dbc_context :: DatabaseContext,
dbc_accum :: M.Map ResultAccumName ResultAccum,
dbc_dirty :: DirtyFlag
}
data DatabaseContextEvalEnv = DatabaseContextEvalEnv
{ dce_transId :: TransactionId,
dce_graph :: TransactionGraph
}
mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
mkDatabaseContextEvalEnv = DatabaseContextEvalEnv
type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a
runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState
runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> execRWST m env freshEnv))
where
freshEnv = mkDatabaseContextEvalState ctx
dbcTransId :: DatabaseContextEvalMonad TransactionId
dbcTransId = dce_transId <$> RWS.ask
dbcGraph :: DatabaseContextEvalMonad TransactionGraph
dbcGraph = dce_graph <$> RWS.ask
dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv =
mkRelationalExprEnv <$> getStateContext <*> dbcGraph
getStateContext :: DatabaseContextEvalMonad DatabaseContext
getStateContext = gets dbc_context
putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext ctx' = do
s <- get
put (s {dbc_context = ctx', dbc_dirty = True})
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 }
setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar relVarName relExpr = do
currentContext <- getStateContext
let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext
potentialContext = currentContext { relationVariables = newRelVars }
if M.lookup relVarName (relationVariables currentContext) == Just relExpr then
pure ()
else do
graph <- dbcGraph
tid <- dbcTransId
case checkConstraints potentialContext tid graph of
Left err -> dbErr err
Right _ -> putStateContext potentialContext
deleteRelVar :: RelVarName -> DatabaseContextEvalMonad ()
deleteRelVar relVarName = do
currContext <- getStateContext
let relVars = relationVariables currContext
if M.notMember relVarName relVars then
pure ()
else do
let newRelVars = M.delete relVarName relVars
newContext = currContext { relationVariables = newRelVars }
putStateContext newContext
pure ()
evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
evalGraphRefDatabaseContextExpr NoOperation = pure ()
evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do
context <- getStateContext
relvars <- fmap relationVariables getStateContext
tConss <- fmap typeConstructorMapping getStateContext
graph <- dbcGraph
let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)
gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
case eAttrs of
Left err -> dbErr err
Right attrsList -> do
lift $ except $ validateAttributes tConss (A.attributesFromList attrsList)
case M.member relVarName relvars of
True -> dbErr (RelVarAlreadyDefinedError relVarName)
False -> setRelVar relVarName (ExistingRelation emptyRelation)
where
attrs = A.attributesFromList attrsList
emptyRelation = Relation attrs emptyTupleSet
evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do
graph <- re_graph <$> dbcRelationalExprEnv
context <- getStateContext
let existingRelVar = M.lookup relVarName (relationVariables context)
reEnv = freshGraphRefRelationalExprEnv (Just context) graph
eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)
case existingRelVar of
Nothing -> do
case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of
Left err -> dbErr err
Right reltype -> do
lift $ except $ validateAttributes (typeConstructorMapping context) (attributes reltype)
setRelVar relVarName expr
Just existingRel -> do
let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)
case eExpectedType of
Left err -> dbErr err
Right expectedType ->
case eNewExprType of
Left err -> dbErr err
Right newExprType -> do
if newExprType == expectedType then do
lift $ except $ validateAttributes (typeConstructorMapping context) (attributes newExprType)
setRelVar relVarName expr
else
dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))
evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do
gfExpr <- relVarByName relVarName
evalGraphRefDatabaseContextExpr (Assign relVarName
(Union
gfExpr
relExpr))
evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do
gfExpr <- relVarByName relVarName
setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)
evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do
rvExpr <- relVarByName relVarName
let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr
tmpAttr attr = "_tmp_" <> attr
updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)
projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
restrictedPortion = Restrict pred' rvExpr
updated = foldr (\(oldname, atomExpr) accum ->
let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in
updateAttr oldname procAtomExpr accum
) restrictedPortion (M.toList atomExprMap)
updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)
setRelVar relVarName (Union unrestrictedPortion updatedPortion)
evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
currContext <- getStateContext
transId <- dbcTransId
graph <- dbcGraph
let currDeps = inclusionDependencies currContext
newDeps = M.insert newDepName newDep currDeps
if M.member newDepName currDeps then
dbErr (InclusionDependencyNameInUseError newDepName)
else do
let potentialContext = currContext { inclusionDependencies = newDeps }
case checkConstraints potentialContext transId graph of
Left err -> dbErr err
Right _ ->
putStateContext potentialContext
evalGraphRefDatabaseContextExpr (RemoveInclusionDependency depName) = do
currContext <- getStateContext
let currDeps = inclusionDependencies currContext
newDeps = M.delete depName currDeps
if M.notMember depName currDeps then
dbErr (InclusionDependencyNameNotInUseError depName)
else
putStateContext $ currContext {inclusionDependencies = newDeps }
evalGraphRefDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do
currentContext <- getStateContext
let nots = notifications currentContext
if M.member notName nots then
dbErr (NotificationNameInUseError notName)
else do
let newNotifications = M.insert notName newNotification nots
newNotification = Notification { changeExpr = triggerExpr,
reportOldExpr = resultOldExpr,
reportNewExpr = resultNewExpr}
putStateContext $ currentContext { notifications = newNotifications }
evalGraphRefDatabaseContextExpr (RemoveNotification notName) = do
currentContext <- getStateContext
let nots = notifications currentContext
if M.notMember notName nots then
dbErr (NotificationNameNotInUseError notName)
else do
let newNotifications = M.delete notName nots
putStateContext $ currentContext { notifications = newNotifications }
evalGraphRefDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
currentContext <- getStateContext
let oldTypes = typeConstructorMapping currentContext
tConsName = TCD.name tConsDef
case validateTypeConstructorDef tConsDef dConsDefList oldTypes of
Left err -> throwError err
Right () | T.null tConsName || not (isUpper (T.head tConsName)) -> dbErr (InvalidAtomTypeName tConsName)
| isJust (findTypeConstructor tConsName oldTypes) -> dbErr (AtomTypeNameInUseError tConsName)
| otherwise -> do
let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
putStateContext $ currentContext { typeConstructorMapping = newTypes }
evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do
currentContext <- getStateContext
let oldTypes = typeConstructorMapping currentContext
if isNothing (findTypeConstructor tConsName oldTypes) then
dbErr (AtomTypeNameNotInUseError tConsName)
else do
let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
putStateContext $ currentContext { typeConstructorMapping = newTypes }
evalGraphRefDatabaseContextExpr (MultipleExpr exprs) =
mapM_ evalGraphRefDatabaseContextExpr exprs
evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do
currentContext <- getStateContext
let atomFuncs = atomFunctions currentContext
case atomFunctionForName funcName atomFuncs of
Left err -> dbErr err
Right realFunc ->
if isScriptedAtomFunction realFunc then do
let updatedFuncs = HS.delete realFunc atomFuncs
putStateContext (currentContext {atomFunctions = updatedFuncs })
else
dbErr (PrecompiledFunctionRemoveError funcName)
evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
context <- getStateContext
let dbcFuncs = dbcFunctions context
case databaseContextFunctionForName funcName dbcFuncs of
Left err -> dbErr err
Right realFunc ->
if isScriptedDatabaseContextFunction realFunc then do
let updatedFuncs = HS.delete realFunc dbcFuncs
putStateContext (context { dbcFunctions = updatedFuncs })
else
dbErr (PrecompiledFunctionRemoveError funcName)
evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
context <- getStateContext
graph <- dbcGraph
let eAtomTypes = mapM (runGraphRefRelationalExprM gfEnv . typeForGraphRefAtomExpr emptyAttributes) atomArgExprs
eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
case eFunc of
Left err -> dbErr err
Right func -> do
let expectedArgCount = length (dbcFuncType func)
actualArgCount = length atomArgExprs
if expectedArgCount /= actualArgCount then
dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
else
case eAtomTypes of
Left err -> dbErr err
Right atomTypes -> do
let mValidTypes = zipWith (\ expType actType
-> case atomTypeVerify expType actType of
Left err -> Just err
Right _ -> Nothing)
(dbcFuncType func) atomTypes
typeErrors = catMaybes mValidTypes
eAtomArgs = map (runGraphRefRelationalExprM gfEnv . evalGraphRefAtomExpr emptyTuple) atomArgExprs
if length (lefts eAtomArgs) > 1 then
dbErr (someErrors (lefts eAtomArgs))
else if not (null typeErrors) then
dbErr (someErrors typeErrors)
else
case evalDatabaseContextFunction func (rights eAtomArgs) context of
Left err -> dbErr err
Right newContext -> putStateContext newContext
data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv
{ dbcio_transId :: TransactionId,
dbcio_graph :: TransactionGraph,
dbcio_mScriptSession :: Maybe ScriptSession
}
type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a
runDatabaseContextIOEvalMonad :: DatabaseContextIOEvalEnv -> DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ()) -> IO (Either RelationalError DatabaseContextEvalState)
runDatabaseContextIOEvalMonad env ctx m = do
res <- runRWST m env freshState
case res of
(Left err,_,_) -> pure (Left err)
(Right (),s,_) -> pure (Right s)
where
freshState = mkDatabaseContextEvalState ctx
requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)
requireScriptSession = do
env <- RWS.ask
case dbcio_mScriptSession env of
Nothing -> pure $ Left $ ScriptError ScriptCompilationDisabledError
Just ss -> pure (Right ss)
putDBCIOContext :: DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext ctx = do
RWS.modify (\dbstate -> dbstate { dbc_context = ctx})
pure (Right ())
getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext = dbc_context <$> RWS.get
getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv
getDBCIORelationalExprEnv = do
context <- getDBCIOContext
mkRelationalExprEnv context . dbcio_graph <$> RWS.ask
evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())
#if !defined(PM36_HASKELL_SCRIPTING)
evalGraphRefDatabaseContextIOExpr AddAtomFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
evalGraphRefDatabaseContextIOExpr AddDatabaseContextFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
evalGraphRefDatabaseContextIOExpr LoadAtomFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
evalGraphRefDatabaseContextIOExpr LoadDatabaseContextFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
#else
evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do
eScriptSession <- requireScriptSession
currentContext <- getDBCIOContext
case eScriptSession of
Left err -> pure (Left err)
Right scriptSession -> do
res <- liftIO $ try $ runGhc (Just libdir) $ do
setSession (hscEnv scriptSession)
let atomFuncs = atomFunctions currentContext
case extractAtomFunctionType funcType of
Left err -> pure (Left err)
Right adjustedAtomTypeCons -> do
eCompiledFunc <- compileScript (atomFunctionBodyType scriptSession) script
pure $ case eCompiledFunc of
Left err -> Left (ScriptError err)
Right compiledFunc -> do
funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructorValidate False funcTypeArg (typeConstructorMapping currentContext) M.empty) adjustedAtomTypeCons
let updatedFuncs = HS.insert newAtomFunc atomFuncs
newContext = currentContext { atomFunctions = updatedFuncs }
newAtomFunc = AtomFunction { atomFuncName = funcName,
atomFuncType = funcAtomType,
atomFuncBody = AtomFunctionBody (Just script) compiledFunc }
if HS.member funcName (HS.map atomFuncName atomFuncs) then
Left (FunctionNameInUseError funcName)
else
Right newContext
case res of
Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
Right eContext -> case eContext of
Left err -> pure (Left err)
Right context' -> putDBCIOContext context'
evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do
eScriptSession <- requireScriptSession
currentContext <- getDBCIOContext
case eScriptSession of
Left err -> pure (Left err)
Right scriptSession -> do
let last2Args = reverse (take 2 (reverse funcType))
atomArgs = take (length funcType - 2) funcType
dbContextTypeCons = ADTypeConstructor "Either" [ADTypeConstructor "DatabaseContextFunctionError" [], ADTypeConstructor "DatabaseContext" []]
expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"
actualType = show funcType
if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
else do
res <- liftIO $ try $ runGhc (Just libdir) $ do
setSession (hscEnv scriptSession)
eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
pure $ case eCompiledFunc of
Left err -> Left (ScriptError err)
Right compiledFunc -> do
funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) atomArgs
let updatedDBCFuncs = HS.insert newDBCFunc (dbcFunctions currentContext)
newContext = currentContext { dbcFunctions = updatedDBCFuncs }
dbcFuncs = dbcFunctions currentContext
newDBCFunc = DatabaseContextFunction {
dbcFuncName = funcName,
dbcFuncType = funcAtomType,
dbcFuncBody = DatabaseContextFunctionBody (Just script) compiledFunc
}
if HS.member funcName (HS.map dbcFuncName dbcFuncs) then
Left (FunctionNameInUseError funcName)
else
Right newContext
case res of
Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
Right eContext -> case eContext of
Left err -> pure (Left err)
Right context' -> putDBCIOContext context'
evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do
currentContext <- getDBCIOContext
eLoadFunc <- liftIO $ loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
case eLoadFunc of
Left LoadSymbolError -> pure (Left LoadFunctionError)
Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
in putDBCIOContext newContext
evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName modPath) = do
currentContext <- getDBCIOContext
eLoadFunc <- liftIO $ loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
case eLoadFunc of
Left LoadSymbolError -> pure (Left LoadFunctionError)
Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
in putDBCIOContext newContext
#endif
evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do
currentContext <- getDBCIOContext
env <- RWS.ask
let gfExpr = Define relVarName attrExprs
evalEnv = mkDatabaseContextEvalEnv (dbcio_transId env) (dbcio_graph env)
graph = dbcio_graph env
case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of
Left err -> pure (Left err)
Right dbstate -> do
let existingRelVar = M.lookup relVarName relVarTable
relVarTable = relationVariables (dbc_context dbstate)
case existingRelVar of
Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
Just existingRel -> do
let gfEnv = freshGraphRefRelationalExprEnv (Just currentContext) graph
case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of
Left err -> pure (Left err)
Right relType -> do
let expectedAttributes = attributes relType
tcMap = typeConstructorMapping (dbc_context dbstate)
eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
case eitherRel of
Left err -> pure $ Left err
Right rel ->
case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of
Left err -> pure (Left err)
Right dbstate' -> putDBCIOContext (dbc_context dbstate')
checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
mapM_ (uncurry checkIncDep) (M.toList deps)
where
potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)
tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,
utctDayTime = secondsToDiffTime 0 }
tempSchemas = Schemas context M.empty
tempTrans = Transaction U.nil tempTransInfo tempSchemas
tempTransInfo = TransactionInfo { parents = transId NE.:| [],
stamp = tempStamp,
merkleHash = mempty
}
deps = inclusionDependencies context
checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
let process = runProcessExprM UncommittedContextMarker
gfSubsetExpr = process (processRelationalExpr subsetExpr)
gfSupersetExpr = process (processRelationalExpr supersetExpr)
let gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
runGfRel = runGraphRefRelationalExprM gfEnv
typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)
typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)
when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)
gfEnv' = freshGraphRefRelationalExprEnv (Just context) potentialGraph
case gfEvald of
Left err -> Left err
Right resultRel -> if resultRel == relationTrue then
pure ()
else
Left (InclusionDependencyCheckError depName)
typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation
typeForRelationalExpr expr = do
graph <- reGraph
context <- reContext
let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)
gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
lift $ except runGf
liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
liftE v = do
y <- lift v
case y of
Left err -> throwError err
Right val -> pure val
predicateRestrictionFilter :: Attributes -> GraphRefRestrictionPredicateExpr -> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do
expr1v <- predicateRestrictionFilter attrs expr1
expr2v <- predicateRestrictionFilter attrs expr2
pure (\x -> do
ev1 <- expr1v x
ev2 <- expr2v x
pure (ev1 && ev2))
predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do
expr1v <- predicateRestrictionFilter attrs expr1
expr2v <- predicateRestrictionFilter attrs expr2
pure (\x -> do
ev1 <- expr1v x
ev2 <- expr2v x
pure (ev1 || ev2))
predicateRestrictionFilter _ TruePredicate = pure (\_ -> pure True)
predicateRestrictionFilter attrs (NotPredicate expr) = do
exprv <- predicateRestrictionFilter attrs expr
pure (fmap not . exprv)
predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do
renv <- askEnv
let eval :: RelationTuple -> Either RelationalError Relation
eval tup =
let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in
runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)
pure (\tup -> case eval tup of
Left err -> Left err
Right rel -> if arity rel /= 0 then
Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
else
pure (rel == relationTrue))
predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
env <- askEnv
let attrs' = A.union attrs (envAttributes env)
ctxtup' = envTuple env
atomExprType <- typeForGraphRefAtomExpr attrs' atomExpr
attr <- lift $ except $ case A.attributeForName attrName attrs of
Right attr -> Right attr
Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of
Right ctxattr -> Right ctxattr
Left err2@(NoSuchAttributeNamesError _) -> Left err2
Left err -> Left err
Left err -> Left err
if atomExprType /= A.atomType attr then
throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
else
pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of
Right atomCmp -> atomCmp == atomIn
Left _ -> False
atomEvald = runGraphRefRelationalExprM env (evalGraphRefAtomExpr tupleIn atomExpr)
in
pure $ case atomForAttributeName attrName tupleIn of
Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of
Left _ -> False
Right ctxatom -> evalAndCmp ctxatom
Left _ -> False
Right atomIn -> evalAndCmp atomIn
predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
renv <- askEnv
aType <- typeForGraphRefAtomExpr attrs atomExpr
if aType /= BoolAtomType then
throwError (AtomTypeMismatchError aType BoolAtomType)
else
pure (\tupleIn ->
case runGraphRefRelationalExprM renv (evalGraphRefAtomExpr tupleIn atomExpr) of
Left err -> Left err
Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))
tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then
Left (AttributeNameInUseError attrName)
else
Right rel
extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)
extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) =
case tupleExprCheckNewAttrName newAttrName relIn of
Left err -> throwError err
Right _ -> do
atomExprType <- typeForGraphRefAtomExpr (attributes relIn) atomExpr
atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType
let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
env <- ask
pure (newAndOldAttrs, \tup -> do
let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup env
atom <- runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr tup atomExpr)
Right (tupleAtomExtend newAttrName atom tup)
)
evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr tupIn (AttributeAtomExpr attrName) =
case atomForAttributeName attrName tupIn of
Right atom -> pure atom
Left err@(NoSuchAttributeNamesError _) -> do
env <- askEnv
case gre_extra env of
Nothing -> throwError err
Just (Left ctxtup) -> lift $ except $ atomForAttributeName attrName ctxtup
Just (Right _) -> throwError err
Left err -> throwError err
evalGraphRefAtomExpr _ (NakedAtomExpr atom) = pure atom
evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName arguments tid) = do
argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments
context <- gfDatabaseContextForMarker tid
let functions = atomFunctions context
func <- lift $ except (atomFunctionForName funcName functions)
let expectedArgCount = length (atomFuncType func) - 1
actualArgCount = length argTypes
safeInit [] = []
safeInit xs = init xs
if expectedArgCount /= actualArgCount then
throwError (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
else do
let zippedArgs = zip (safeInit (atomFuncType func)) argTypes
mapM_ (\(expType, actType) ->
lift $ except (atomTypeVerify expType actType)) zippedArgs
evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments
case evalAtomFunction func evaldArgs of
Left err -> throwError (AtomFunctionUserError err)
Right result -> do
_ <- lift $ except (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))
pure result
evalGraphRefAtomExpr tupIn (RelationAtomExpr relExpr) = do
env <- ask
let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env
relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)
pure (RelationAtom relAtom)
evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do
let mergeEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn
aType <- local mergeEnv (typeForGraphRefAtomExpr (tupleAttributes tupIn) cons)
argAtoms <- local mergeEnv $
mapM (evalGraphRefAtomExpr tupIn) dConsArgs
pure (ConstructedAtom dConsName aType argAtoms)
typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do
renv <- askEnv
case A.atomTypeForAttributeName attrName attrs of
Right aType -> pure aType
Left err@(NoSuchAttributeNamesError _) ->
let envTup = envTuple renv
envAttrs = envAttributes renv in
case A.attributeForName attrName envAttrs of
Right attr -> pure (A.atomType attr)
Left _ -> case atomForAttributeName attrName envTup of
Right atom -> pure (atomTypeForAtom atom)
Left _ ->
throwError err
Left err -> throwError err
typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)
typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do
funcs <- atomFunctions <$> gfDatabaseContextForMarker transId
case atomFunctionForName funcName funcs of
Left err -> throwError err
Right func -> do
let funcRetType = last (atomFuncType func)
funcArgTypes = init (atomFuncType func)
argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs
let eTvMap = resolveTypeVariables funcArgTypes argTypes
case eTvMap of
Left err -> throwError err
Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName tvMap funcRetType
typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do
relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)
pure (RelationAtomType (attributes relType))
typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =
do
argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs
tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid
lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes
verifyGraphRefAtomExprTypes :: Relation -> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do
env <- askEnv
case A.atomTypeForAttributeName attrName (attributes relIn) of
Right aType -> lift $ except $ atomTypeVerify expectedType aType
(Left err@(NoSuchAttributeNamesError _)) ->
let attrs' = envAttributes env in
if attrs' == emptyAttributes then
throwError err
else
case A.attributeForName attrName attrs' of
Left err' -> throwError err'
Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)
Left err -> throwError err
verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =
lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)
verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) expectedType = do
context <- gfDatabaseContextForMarker tid
let functions = atomFunctions context
func <- lift $ except $ atomFunctionForName funcName functions
let expectedArgTypes = atomFuncType func
funcArgVerifier (atomExpr, expectedType2, argCount) = do
let handler :: RelationalError -> GraphRefRelationalExprM AtomType
handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)
handler err = throwError err
verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler
funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]
if length funcArgTypes /= length expectedArgTypes - 1 then
throwError (AtomTypeCountError funcArgTypes expectedArgTypes)
else
lift $ except $ atomTypeVerify expectedType (last expectedArgTypes)
verifyGraphRefAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType =
do
let mergedAttrsEnv e = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) e
relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)
lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType))
verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do
cType <- typeForGraphRefAtomExpr (attributes rel) cons
lift $ except $ atomTypeVerify expectedType cType
evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do
tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker transId
aType <- lift $ except $ atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
lift $ except $ validateAtomType aType tConsMap
pure $ Attribute attrName aType
evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure attr
evalGraphRefTupleExprs :: Maybe Attributes -> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs _ (TupleExprs _ []) = pure []
evalGraphRefTupleExprs mAttrs (TupleExprs fixedMarker tupleExprL) = do
tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprL
finalAttrs <- case mAttrs of
Just attrs -> pure attrs
Nothing ->
case tuples of
[] -> pure emptyAttributes
(headTuple:tailTuples) -> do
let
processTupleAttrs (tupAttr, accAttr) =
if isResolvedAttribute accAttr && tupAttr == accAttr then
pure accAttr
else
lift $ except $ resolveAttributes accAttr tupAttr
mostResolvedTypes <-
foldM (\acc tup -> do
let zipped = zip (V.toList $ tupleAttributes tup) acc
accNames = S.fromList $ map A.attributeName acc
tupNames = A.attributeNameSet (tupleAttributes tup)
attrNamesDiff = S.union (S.difference accNames tupNames) (S.difference tupNames accNames)
unless (null attrNamesDiff) (throwError (AttributeNamesMismatchError attrNamesDiff))
nextTupleAttrs <- mapM processTupleAttrs zipped
let diff = A.attributesDifference (A.attributesFromList nextTupleAttrs) (A.attributesFromList acc)
if diff == A.emptyAttributes then
pure nextTupleAttrs
else
throwError (TupleAttributeTypeMismatchError diff)
) (V.toList $ tupleAttributes headTuple) tailTuples
pure (A.attributesFromList mostResolvedTypes)
tConsMap <- case singularTransactions tupleExprL of
SingularTransactionRef commonTransId ->
typeConstructorMapping <$> gfDatabaseContextForMarker commonTransId
NoTransactionsRef ->
typeConstructorMapping <$> gfDatabaseContextForMarker fixedMarker
_ -> throwError TupleExprsReferenceMultipleMarkersError
lift $ except $ validateAttributes tConsMap finalAttrs
mapM (lift . except . resolveTypesInTuple finalAttrs tConsMap) tuples
evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple
evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do
let attrs = fromMaybe A.emptyAttributes mAttrs
resolveOneAtom (attrName, aExpr) =
do
let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs
unresolvedType <- typeForGraphRefAtomExpr attrs aExpr
resolvedType <- case eExpectedAtomType of
Left _ -> pure unresolvedType
Right typeHint -> lift $ except $ resolveAtomType typeHint unresolvedType
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
when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)
let tup' = reorderTuple finalAttrs tup
pure tup'
evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
mAttrs <- case mAttrExprs of
Just _ ->
Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)
Nothing -> pure Nothing
tuples <- evalGraphRefTupleExprs mAttrs tupleExprs
let attrs = fromMaybe firstTupleAttrs mAttrs
firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)
lift $ except $ mkRelation attrs (RelationTupleSet tuples)
evalGraphRefRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
lift $ except $ mkRelation attributeSet tupleSet
evalGraphRefRelationalExpr (ExistingRelation rel) = pure rel
evalGraphRefRelationalExpr (RelationVariable name tid) = do
ctx <- gfDatabaseContextForMarker tid
case M.lookup name (relationVariables ctx) of
Nothing -> throwError (RelVarNotDefinedError name)
Just rv -> evalGraphRefRelationalExpr rv
evalGraphRefRelationalExpr (Project attrNames expr) = do
attrNameSet <- evalGraphRefAttributeNames attrNames expr
rel <- evalGraphRefRelationalExpr expr
lift $ except $ project attrNameSet rel
evalGraphRefRelationalExpr (Union exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
lift $ except $ union relA relB
evalGraphRefRelationalExpr (Join exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
lift $ except $ join relA relB
evalGraphRefRelationalExpr (Rename oldName newName expr) = do
rel <- evalGraphRefRelationalExpr expr
lift $ except $ rename oldName newName rel
evalGraphRefRelationalExpr (Difference exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
lift $ except $ difference relA relB
evalGraphRefRelationalExpr (Group groupAttrNames newAttrName expr) = do
groupNames <- evalGraphRefAttributeNames groupAttrNames expr
rel <- evalGraphRefRelationalExpr expr
lift $ except $ group groupNames newAttrName rel
evalGraphRefRelationalExpr (Ungroup groupAttrName expr) = do
rel <- evalGraphRefRelationalExpr expr
lift $ except $ ungroup groupAttrName rel
evalGraphRefRelationalExpr (Restrict predExpr expr) = do
rel <- evalGraphRefRelationalExpr expr
filt <- predicateRestrictionFilter (attributes rel) predExpr
lift $ except $ restrict filt rel
evalGraphRefRelationalExpr (Equals exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
pure $ if relA == relB then relationTrue else relationFalse
evalGraphRefRelationalExpr (NotEquals exprA exprB) = do
relA <- evalGraphRefRelationalExpr exprA
relB <- evalGraphRefRelationalExpr exprB
pure $ if relA == relB then relationFalse else relationTrue
evalGraphRefRelationalExpr (Extend extendTupleExpr expr) = do
rel <- evalGraphRefRelationalExpr expr
(newAttrs, tupProc) <- extendGraphRefTupleExpressionProcessor rel extendTupleExpr
lift $ except $ relMogrify tupProc newAttrs rel
evalGraphRefRelationalExpr expr@With{} =
evalGraphRefRelationalExpr (substituteWithNameMacros [] expr)
dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext
dbContextForTransId tid graph = do
trans <- transactionForId tid graph
pure (concreteDatabaseContext trans)
transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
transactionForId tid graph
| tid == U.nil =
Left RootTransactionTraversalError
| S.null matchingTrans =
Left $ NoSuchTransactionError tid
| otherwise =
Right $ head (S.toList matchingTrans)
where
matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet
typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))
typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
mAttrs <- case mAttrExprs of
Just attrExprs -> do
attrs <- mapM evalGraphRefAttributeExpr attrExprs
pure (Just (attributesFromList attrs))
Nothing -> pure Nothing
tuples <- evalGraphRefTupleExprs mAttrs tupleExprs
let retAttrs = case tuples of
(tup:_) -> tupleAttributes tup
[] -> fromMaybe A.emptyAttributes mAttrs
pure $ emptyRelationWithAttrs retAttrs
typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do
relVars <- relationVariables <$> gfDatabaseContextForMarker tid
case M.lookup rvName relVars of
Nothing -> throwError (RelVarNotDefinedError rvName)
Just rvExpr ->
typeForGraphRefRelationalExpr rvExpr
typeForGraphRefRelationalExpr (Project attrNames expr) = do
exprType' <- typeForGraphRefRelationalExpr expr
projectionAttrs <- evalGraphRefAttributeNames attrNames expr
lift $ except $ project projectionAttrs exprType'
typeForGraphRefRelationalExpr (Union exprA exprB) = do
exprA' <- typeForGraphRefRelationalExpr exprA
exprB' <- typeForGraphRefRelationalExpr exprB
lift $ except $ union exprA' exprB'
typeForGraphRefRelationalExpr (Join exprA exprB) = do
exprA' <- typeForGraphRefRelationalExpr exprA
exprB' <- typeForGraphRefRelationalExpr exprB
lift $ except $ join exprA' exprB'
typeForGraphRefRelationalExpr (Rename oldAttr newAttr expr) = do
expr' <- typeForGraphRefRelationalExpr expr
lift $ except $ rename oldAttr newAttr expr'
typeForGraphRefRelationalExpr (Difference exprA exprB) = do
exprA' <- typeForGraphRefRelationalExpr exprA
exprB' <- typeForGraphRefRelationalExpr exprB
lift $ except $ difference exprA' exprB'
typeForGraphRefRelationalExpr (Group groupNames attrName expr) = do
expr' <- typeForGraphRefRelationalExpr expr
groupNames' <- evalGraphRefAttributeNames groupNames expr
lift $ except $ group groupNames' attrName expr'
typeForGraphRefRelationalExpr (Ungroup groupAttrName expr) = do
expr' <- typeForGraphRefRelationalExpr expr
lift $ except $ ungroup groupAttrName expr'
typeForGraphRefRelationalExpr (Restrict pred' expr) = do
expr' <- typeForGraphRefRelationalExpr expr
filt <- predicateRestrictionFilter (attributes expr') pred'
lift $ except $ restrict filt expr'
typeForGraphRefRelationalExpr Equals{} =
pure relationFalse
typeForGraphRefRelationalExpr NotEquals{} =
pure relationFalse
typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do
rel <- typeForGraphRefRelationalExpr expr
evalGraphRefRelationalExpr (Extend extendTupleExpr (ExistingRelation rel))
typeForGraphRefRelationalExpr expr@(With withs _) = do
let expr' = substituteWithNameMacros [] expr
checkMacroName (WithNameExpr macroName tid) = do
rvs <- relationVariables <$> gfDatabaseContextForMarker tid
case M.lookup macroName rvs of
Just _ -> lift $ except $ Left (RelVarAlreadyDefinedError macroName)
Nothing -> pure ()
mapM_ (checkMacroName . fst) withs
typeForGraphRefRelationalExpr expr'
evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)
evalGraphRefAttributeNames attrNames expr = do
exprType' <- typeForGraphRefRelationalExpr expr
let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType')))
case attrNames of
AttributeNames names ->
case A.projectionAttributesForNames names (attributes exprType') of
Left err -> throwError err
Right attrs -> pure (S.fromList (V.toList (A.attributeNames attrs)))
InvertedAttributeNames names -> do
let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
if not (S.null nonExistentAttributeNames) then
throwError $ AttributeNamesMismatchError nonExistentAttributeNames
else
pure (A.nonMatchingAttributeNameSet names typeNameSet)
UnionAttributeNames namesA namesB -> do
nameSetA <- evalGraphRefAttributeNames namesA expr
nameSetB <- evalGraphRefAttributeNames namesB expr
pure (S.union nameSetA nameSetB)
IntersectAttributeNames namesA namesB -> do
nameSetA <- evalGraphRefAttributeNames namesA expr
nameSetB <- evalGraphRefAttributeNames namesB expr
pure (S.intersection nameSetA nameSetB)
RelationalExprAttributeNames attrExpr -> do
attrExprType <- typeForGraphRefRelationalExpr attrExpr
pure (A.attributeNameSet (attributes attrExprType))
evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid
case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of
Left err -> throwError err
Right aType -> do
case validateAtomType aType tConsMap of
Left err -> throwError err
Right _ -> pure (Attribute attrName aType)
evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr
mkEmptyRelVars :: RelationVariables -> RelationVariables
mkEmptyRelVars = M.map mkEmptyRelVar
where
mkEmptyRelVar expr@MakeRelationFromExprs{} = expr
mkEmptyRelVar (MakeStaticRelation attrs _) = MakeStaticRelation attrs emptyTupleSet
mkEmptyRelVar (ExistingRelation rel) = ExistingRelation (emptyRelationWithAttrs (attributes rel))
mkEmptyRelVar rv@RelationVariable{} = Restrict (NotPredicate TruePredicate) rv
mkEmptyRelVar (Project attrNames expr) = Project attrNames (mkEmptyRelVar expr)
mkEmptyRelVar (Union exprA exprB) = Union (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (Join exprA exprB) = Join (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (Rename nameA nameB expr) = Rename nameA nameB (mkEmptyRelVar expr)
mkEmptyRelVar (Difference exprA exprB) = Difference (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (Group attrNames attrName expr) = Group attrNames attrName (mkEmptyRelVar expr)
mkEmptyRelVar (Ungroup attrName expr) = Ungroup attrName (mkEmptyRelVar expr)
mkEmptyRelVar (Restrict pred' expr) = Restrict pred' (mkEmptyRelVar expr)
mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)
mkEmptyRelVar (With macros expr) = With (map (second mkEmptyRelVar) macros) (mkEmptyRelVar expr)
dbErr :: RelationalError -> DatabaseContextEvalMonad ()
dbErr err = lift (except (Left err))
relationVariablesAsRelation :: DatabaseContext -> TransactionGraph -> Either RelationalError Relation
relationVariablesAsRelation ctx graph = do
let subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]
attrs = A.attributesFromList [Attribute "name" TextAtomType,
Attribute "attributes" (RelationAtomType subrelAttrs)]
relVars = relationVariables ctx
mkRvDesc (rvName, gfExpr) = do
let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph
gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
pure (rvName, gfType)
relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]
attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]
attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of
Left err -> error ("relationVariablesAsRelation pooped " ++ show err)
Right rel -> RelationAtom rel
rvs <- mapM mkRvDesc (M.toList relVars)
let tups = map relVarToAtomList rvs
mkRelationFromList attrs tups
evalRelationalExpr :: RelationalExpr -> RelationalExprM Relation
evalRelationalExpr expr = do
graph <- reGraph
context <- reContext
let expr' = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)
gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
case runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr expr') of
Left err -> throwError err
Right rel -> pure rel
class (MonadError RelationalError m, Monad m) => DatabaseContextM m where
getContext :: m DatabaseContext
instance DatabaseContextM (ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity)) where
getContext = gfDatabaseContextForMarker UncommittedContextMarker
instance DatabaseContextM (RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity)) where
getContext = getStateContext
relVarByName :: DatabaseContextM m => RelVarName -> m GraphRefRelationalExpr
relVarByName rvName = do
relvars <- relationVariables <$> getContext
case M.lookup rvName relvars of
Nothing -> throwError (RelVarNotDefinedError rvName)
Just gfexpr -> pure gfexpr