@@ -13,6 +13,7 @@ import ProjectM36.DataTypes.Primitive
1313import ProjectM36.AtomFunction
1414import ProjectM36.DatabaseContextFunction
1515import ProjectM36.Arbitrary
16+import ProjectM36.Transaction
1617import qualified ProjectM36.Attribute as A
1718import qualified Data.Map as M
1819import qualified Data.HashSet as HS
@@ -58,9 +59,11 @@ freshDatabaseState context = DatabaseStateElems {
5859
5960-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
6061data RelationalExprStateElems = RelationalExprStateElems {
61− elems_context :: DatabaseContext,
62+ elems_context :: DatabaseContext,
6263 elems_graph :: TransactionGraph,
63− elems_extra :: Maybe (Either RelationTuple Attributes) }
64+ elems_currentTransId :: TransactionId,
65+ elems_extra :: Maybe (Either RelationTuple Attributes)
66+ }
6467
6568stateTuple :: RelationalExprStateElems -> RelationTuple
6669stateTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (elems_extra e))
@@ -75,12 +78,14 @@ data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext Re
7578
7679instance Show RelationalExprStateElems where show e@RelationalExprStateElems{} = "RelationalExprStateElems " ++ show (elems_extra e)
7780
78−mkRelationalExprState :: DatabaseContext -> TransactionGraph -> RelationalExprStateElems
79−mkRelationalExprState ctx graph = RelationalExprStateElems
80− { elems_context = ctx,
81− elems_graph = graph,
82− elems_extra = Nothing }
83−
81+mkRelationalExprState :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprStateElems
82+mkRelationalExprState ctx currentTransId graph =
83+ RelationalExprStateElems
84+ { elems_context = ctx,
85+ elems_graph = graph,
86+ elems_currentTransId = currentTransId,
87+ elems_extra = Nothing }
88+
8489mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems
8590mergeTuplesIntoRelationalExprState tupIn e@RelationalExprStateElems{} =
8691 e{elems_extra = new_elems }
@@ -327,16 +332,16 @@ evalDatabaseContextExpr (Undefine relVarName) _ _ = deleteRelVar relVarName
327332evalDatabaseContextExpr (Assign relVarName expr) transId graph = do
328333 context <- getStateContext
329334 let existingRelVar = M.lookup relVarName (relationVariables context)
330− relExprState = mkRelationalExprState context graph
335+ relExprState = mkRelationalExprState context transId graph
331336 case existingRelVar of
332337 Nothing -> do
333− let ervExpr = runReader (evalRelationalExpr expr) relExprState
338+ let ervExpr = runReader (evalRelationalExpr expr) relExprState
334339 case ervExpr of
335340 Left err -> pure (Left err)
336341 Right rvExpr -> setRelVar relVarName rvExpr transId graph
337342 Just existingRel -> do
338343 let eExpectedType = typeForGraphRefRelationalExpr existingRel graph
339− eNewExprType = runReader (typeForRelationalExpr expr transId graph) relExprState
344+ eNewExprType = runReader (typeForRelationalExpr expr) relExprState
340345 case eExpectedType of
341346 Left err -> pure (Left err)
342347 Right expectedType ->
@@ -358,7 +363,7 @@ evalDatabaseContextExpr (Insert relVarName relExpr) tid graph =
358363evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do
359364 ctx <- getStateContext
360365 let rv = RelationVariable relVarName transId
361− rvState = mkRelationalExprState ctx graph
366+ rvState = mkRelationalExprState ctx transId graph
362367 case runReader (processRestrictionPredicateExpr predicate) rvState of
363368 Left err -> pure (Left err)
364369 Right graphRefPredicate ->
@@ -367,7 +372,7 @@ evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do
367372--union of restricted+updated portion and the unrestricted+unupdated portion
368373evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId graph = do
369374 context <- getStateContext
370− let rvState = mkRelationalExprState context graph
375+ let rvState = mkRelationalExprState context transId graph
371376 relVarTable = relationVariables context
372377 case runReader (processRestrictionPredicateExpr restrictionPredicateExpr) rvState of
373378 Left err -> pure (Left err)
@@ -496,10 +501,10 @@ evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) _ _ = do
496501 else
497502 pure (Left (PrecompiledFunctionRemoveError funcName))
498503
499−evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) _ graph = do
504+evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) transId graph = do
500505 context <- getStateContext
501506 --resolve atom arguments
502− let relExprState = mkRelationalExprState context graph
507+ let relExprState = mkRelationalExprState context transId graph
503508 eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs
504509 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
505510 case eFunc of
@@ -664,13 +669,13 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
664669
665670 deps = inclusionDependencies context
666671 eval expr = evalReader (evalRelationalExpr expr)
667− evalReader f = runReader f (mkRelationalExprState context graph)
672+ evalReader f = runReader f (mkRelationalExprState context transId graph)
668673 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
669− let gfSubsetExpr = processRelationalExpr subsetExpr transId
670− gfSupersetExpr = processRelationalExpr supersetExpr transId
674+ let gfSubsetExpr = evalReader (processRelationalExpr subsetExpr)
675+ gfSupersetExpr = evalReader (processRelationalExpr supersetExpr)
671676 --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.
672− typeSub <- evalReader (typeForRelationalExpr subsetExpr transId graph)
673− typeSuper <- evalReader (typeForRelationalExpr supersetExpr transId graph)
677+ typeSub <- evalReader (typeForRelationalExpr subsetExpr)
678+ typeSuper <- evalReader (typeForRelationalExpr supersetExpr)
674679 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
675680 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
676681 case evalGraphRefRelationalExpr checkExpr potentialGraph of
@@ -683,13 +688,12 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
683688-- 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
684689-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
685690
686−typeForRelationalExpr :: RelationalExpr -> TransactionId -> TransactionGraph -> RelationalExprState (Either RelationalError Relation)
687−typeForRelationalExpr expr transId graph = do
688− rstate <- ask
689− let context = stateElemsContext rstate
691+typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
692+typeForRelationalExpr expr = do
693+ graph <- elems_graph <$> ask
690694 --replace the relationVariables context element with a cloned set of relation devoid of tuples
691695 --evalRelationalExpr could still return an existing relation with tuples, so strip them
692− let gfExpr = processRelationalExpr expr transId
696+ gfExpr <- processRelationalExpr expr
693697 pure (typeForGraphRefRelationalExpr gfExpr graph)
694698
695699--returns a database context with all tuples removed
@@ -809,8 +813,12 @@ extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomE
809813 Left err -> Left err
810814 Right atom -> Right (tupleAtomExtend newAttrName atom tup)
811815 )
812−{-
816+
817+
813818evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)
819+evalAtomExpr = undefined
820+{-
821+
814822evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
815823 Right atom -> pure (Right atom)
816824 err@(Left (NoSuchAttributeNamesError _)) -> do
@@ -889,10 +897,12 @@ typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
889897 case eTvMap of
890898 Left err -> pure (Left err)
891899 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
892−typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do
893− rstate <- lift ask
894− relType <- either throwE pure (runReader (typeForRelationalExpr relExpr () (mergeAttributesIntoRelationalExprState attrs rstate))
895− pure (RelationAtomType (attributes relType))
900+typeFromAtomExpr attrs (RelationAtomExpr relExpr) = do
901+ relType <- local (mergeAttributesIntoRelationalExprState attrs) (typeForRelationalExpr relExpr)
902+ case relType of
903+ Left err -> pure (Left err)
904+ Right relType' ->
905+ pure (pure (RelationAtomType (attributes relType')))
896906-- grab the type of the data constructor, then validate that the args match the expected types
897907typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
898908 runExceptT $ do
@@ -907,11 +917,11 @@ verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT
907917 case A.atomTypeForAttributeName attrName (attributes relIn) of
908918 Right aType -> either throwE pure (atomTypeVerify expectedType aType)
909919 (Left err@(NoSuchAttributeNamesError _)) ->
910− let attrs' = stateAttrs rstate in
920+ let attrs' = stateAttributes rstate in
911921 if attrs' == emptyAttributes then
912922 throwE err
913923 else
914− case A.attributeForName attrName attrs of
924+ case A.attributeForName attrName attrs' of
915925 Left err' -> throwE err'
916926 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
917927verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
@@ -1035,7 +1045,7 @@ evalGraphRefRelationalExpr (RelationVariable name tid) graph = do
10351045dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext
10361046dbContextForTransId tid graph = do
10371047 trans <- transactionForId tid graph
1038− pure (concreteDatabaseContext ctx)
1048+ pure (concreteDatabaseContext trans)
10391049
10401050transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
10411051transactionForId tid graph
@@ -1049,14 +1059,44 @@ transactionForId tid graph
10491059 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
10501060
10511061processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError GraphRefRestrictionPredicateExpr)
1052−processRestrictionPredicateExpr TruePredicate = TruePredicate
1053−processRestrictionPredicateExpr (AndPredicate a b) = pure $ AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
1054−processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
1055−processRestrictionPredicateExpr (NotPredicate a) = pure $ NotPredicate <$> processRestrictionPredicateExpr a
1056−processRestrictionPredicateExpr (RelationalExprPredicate expr) = pure $ RelationalExprPredicate <$> evalRelationalExpr expr
1057−processRestrictionPredicateExpr (AtomExprPredicate expr) = AtomExprPredicate <$> evalAtomExpr expr
1058−processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = AttributeEqualityPredicate nam <$> evalAtomExpr expr
1059−
1062+processRestrictionPredicateExpr TruePredicate = pure (Right TruePredicate)
1063+processRestrictionPredicateExpr (AndPredicate a b) = do
1064+ a' <- processRestrictionPredicateExpr a
1065+ b' <- processRestrictionPredicateExpr b
1066+ case a' of
1067+ Left err -> pure (Left err)
1068+ Right a'' -> case b' of
1069+ Left err -> pure (Left err)
1070+ Right b'' ->
1071+ pure (Right (AndPredicate a'' b''))
1072+processRestrictionPredicateExpr (OrPredicate a b) = do
1073+ a' <- processRestrictionPredicateExpr a
1074+ b' <- processRestrictionPredicateExpr b
1075+ case a' of
1076+ Left err -> pure (Left err)
1077+ Right a'' -> case b' of
1078+ Left err -> pure (Left err)
1079+ Right b'' ->
1080+ pure (Right (OrPredicate a'' b''))
1081+processRestrictionPredicateExpr (NotPredicate a) = do
1082+ a' <- processRestrictionPredicateExpr a
1083+ case a' of
1084+ Left err -> pure (Left err)
1085+ Right a'' ->
1086+ pure (Right (NotPredicate a''))
1087+processRestrictionPredicateExpr (RelationalExprPredicate expr) = do
1088+ e <- evalRelationalExpr expr
1089+ pure $ case e of
1090+ Left err -> Left err
1091+ Right e' -> Right (RelationalExprPredicate e')
1092+processRestrictionPredicateExpr (AtomExprPredicate expr) = do
1093+ tid <- elems_currentTransId <$> ask
1094+ let e = processAtomExpr expr tid
1095+ pure (Right (AtomExprPredicate e))
1096+processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = do
1097+ tid <- elems_currentTransId <$> ask
1098+ let e = processAtomExpr expr tid
1099+ pure (Right (AttributeEqualityPredicate nam e))
10601100processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError (ExtendTupleExprBase a))
10611101processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do
10621102 eExpr <- evalAtomExpr atomExpr
@@ -1155,6 +1195,6 @@ processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) tid = AttributeAndT
11551195processAttributeExpr (NakedAttributeExpr attr) = NakedAttributeExpr attr
11561196
11571197-- convert a RelationalExpr into a GraphRefRelationalExpr
1158−processRelationalExpr :: RelationalExpr -> TransactionId -> GraphRefRelationalExpr
1159−processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) =
1198+processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr
1199+processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do
11601200 MakeRelationFromExprs (fmap (fmap processAttributeExpr) mAttrs) (processTupleExprs tupleExprs)