@@ -30,6 +30,9 @@ import Control.Monad.Trans.Reader
3030import Test.QuickCheck
3131import GHC
3232import GHC.Paths
33+import Data.Time.Clock
34+import Data.Time.Calendar
35+import qualified Data.List.NonEmpty as NE
3336
3437data DatabaseContextExprDetails = CountUpdatedTuples
3538
@@ -54,6 +57,11 @@ freshDatabaseState context = DatabaseStateElems {
5457 } --future work: propagate return accumulator
5558
5659-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
60+data RelationalExprStateElems = RelationalExprStateTupleElems
61+ DatabaseContext
62+ TransactionGraph
63+ Maybe (Either RelationTuple Attributes)
64+
5765data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
5866 RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
5967 RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation
@@ -260,14 +268,14 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do
260268 Right tupProc -> pure (Right (Extend tupProc expr))
261269
262270--helper function to process relation variable creation/assignment
263−setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseState (Either RelationalError ())
264−setRelVar relVarName relExpr = do
271+setRelVar :: RelVarName -> GraphRefRelationalExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())
272+setRelVar relVarName relExpr transId graph = do
265273 currentContext <- getStateContext
266274 let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext
267275 potentialContext = currentContext { relationVariables = newRelVars }
268276 --determine when to check constraints
269277
270− case checkConstraints potentialContext of
278+ case checkConstraints potentialContext transId graph of
271279 Left err -> pure (Left err)
272280 Right _ -> do
273281 putStateContext potentialContext
@@ -289,7 +297,7 @@ deleteRelVar relVarName = do
289297evalDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())
290298evalDatabaseContextExpr NoOperation _ _ = pure (Right ())
291299
292−evalDatabaseContextExpr (Define relVarName attrExprs) _ _ = do
300+evalDatabaseContextExpr (Define relVarName attrExprs) transId graph = do
293301 relvars <- fmap relationVariables getStateContext
294302 tConss <- fmap typeConstructorMapping getStateContext
295303 let eAttrs = map (evalAttrExpr tConss) attrExprs
@@ -304,7 +312,7 @@ evalDatabaseContextExpr (Define relVarName attrExprs) _ _ = do
304312 else
305313 case M.member relVarName relvars of
306314 True -> pure (Left (RelVarAlreadyDefinedError relVarName))
307− False -> setRelVar relVarName (ExistingRelation emptyRelation) >> pure (Right ())
315+ False -> setRelVar relVarName (ExistingRelation emptyRelation) transId graph >> pure (Right ())
308316 where
309317 attrs = A.attributesFromList attrsList
310318 emptyRelation = Relation attrs emptyTupleSet
@@ -320,10 +328,10 @@ evalDatabaseContextExpr (Assign relVarName expr) transId graph = do
320328 let ervExpr = runReader (evalRelationalExpr expr) relExprState
321329 case ervExpr of
322330 Left err -> pure (Left err)
323− Right rvExpr -> setRelVar relVarName rvExpr
331+ Right rvExpr -> setRelVar relVarName rvExpr transId graph
324332 Just existingRel -> do
325− let eExpectedType = typeForGraphRefRelationalExpr existingRel transId graph
326− eNewExprType = runReader (typeForRelationalExpr expr) relExprState
333+ let eExpectedType = typeForGraphRefRelationalExpr existingRel graph
334+ eNewExprType = runReader (typeForRelationalExpr expr transId graph) relExprState
327335 case eExpectedType of
328336 Left err -> pure (Left err)
329337 Right expectedType ->
@@ -334,7 +342,7 @@ evalDatabaseContextExpr (Assign relVarName expr) transId graph = do
334342 let ervExpr = runReader (evalRelationalExpr expr) relExprState
335343 case ervExpr of
336344 Left err -> pure (Left err)
337− Right rvExpr -> setRelVar relVarName rvExpr
345+ Right rvExpr -> setRelVar relVarName rvExpr transId graph
338346 else
339347 pure (Left (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)))
340348
@@ -342,17 +350,17 @@ evalDatabaseContextExpr (Insert relVarName relExpr) tid graph =
342350 evalDatabaseContextExpr (Assign relVarName (Union (RelationVariable relVarName ())
343351 relExpr)) tid graph
344352
345−evalDatabaseContextExpr (Delete relVarName predicate) transId _ = do
353+evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do
346354 ctx <- getStateContext
347355 let rv = RelationVariable relVarName transId
348356 rvState = mkRelationalExprState ctx
349357 case runReader (processRestrictionPredicateExpr predicate) rvState of
350358 Left err -> pure (Left err)
351359 Right graphRefPredicate ->
352− setRelVar relVarName (Restrict (NotPredicate graphRefPredicate) rv)
360+ setRelVar relVarName (Restrict (NotPredicate graphRefPredicate) rv) transId graph
353361
354362--union of restricted+updated portion and the unrestricted+unupdated portion
355−evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId _ = do
363+evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId graph = do
356364 context <- getStateContext
357365 let rvState = mkRelationalExprState context
358366 relVarTable = relationVariables context
@@ -374,9 +382,9 @@ evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr)
374382 ) rv (M.toList atomExprMap)
375383 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
376384 updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)
377− setRelVar relVarName (Union unrestrictedPortion updatedPortion)
385+ setRelVar relVarName (Union unrestrictedPortion updatedPortion) transId graph
378386
379−evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) _ _ = do
387+evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) transId graph = do
380388 currContext <- getStateContext
381389 let currDeps = inclusionDependencies currContext
382390 newDeps = M.insert newDepName newDep currDeps
@@ -384,7 +392,7 @@ evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) _ _ = do
384392 pure (Left (InclusionDependencyNameInUseError newDepName))
385393 else do
386394 let potentialContext = currContext { inclusionDependencies = newDeps }
387− case checkConstraints potentialContext of
395+ case checkConstraints potentialContext transId graph of
388396 Left err -> pure (Left err)
389397 Right _ -> do
390398 putStateContext potentialContext
@@ -614,7 +622,7 @@ evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelatio
614622 case existingRelVar of
615623 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
616624 Just existingRel -> do
617− case typeForGraphRefRelationalExpr existingRel transId graph of
625+ case typeForGraphRefRelationalExpr existingRel graph of
618626 Left err -> pure (Left err)
619627 Right relType -> do
620628 let expectedAttributes = attributes relType
@@ -623,7 +631,7 @@ evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelatio
623631 case eitherRel of
624632 Left err -> pure $ Left err
625633 Right rel ->
626− case runState (setRelVar relVarName (ExistingRelation rel)) elems of
634+ case runState (setRelVar relVarName (ExistingRelation rel) transId graph) elems of
627635 (Left err,_) -> pure (Left err)
628636 (Right (), elems') -> pure $ Right (context elems)
629637
@@ -637,20 +645,28 @@ updateTupleWithAtomExprs exprMap context tupIn = do
637645 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
638646
639647--run verification on all constraints
640−checkConstraints :: DatabaseContext -> Either RelationalError ()
641−checkConstraints context =
648+checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
649+checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
642650 mapM_ (uncurry checkIncDep) (M.toList deps)
643651 where
652+ potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)
653+ tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,
654+ utctDayTime = secondsToDiffTime 0 }
655+ tempSchemas = Schemas context M.empty
656+ tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas
657+
644658 deps = inclusionDependencies context
645659 eval expr = evalReader (evalRelationalExpr expr)
646660 evalReader f = runReader f (RelationalExprStateElems context)
647661 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
662+ let gfSubsetExpr = processRelationalExpr subsetExpr transId
663+ gfSupersetExpr = processRelationalExpr supersetExpr transId
648664 --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.
649− typeSub <- evalReader (typeForRelationalExpr subsetExpr)
650− typeSuper <- evalReader (typeForRelationalExpr supersetExpr)
665+ typeSub <- evalReader (typeForRelationalExpr subsetExpr transId graph)
666+ typeSuper <- evalReader (typeForRelationalExpr supersetExpr transId graph)
651667 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
652− let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)
653− case eval checkExpr of
668+ let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
669+ case evalGraphRefRelationalExpr checkExpr potentialGraph of
654670 Left err -> Left err
655671 Right resultRel -> if resultRel == relationTrue then
656672 pure ()
@@ -660,24 +676,23 @@ checkConstraints context =
660676-- 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
661677-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
662678
663−typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
664−typeForRelationalExpr expr = do
679+typeForRelationalExpr :: RelationalExpr -> TransactionId -> TransactionGraph -> RelationalExprState (Either RelationalError Relation)
680+typeForRelationalExpr expr transId graph = do
665681 rstate <- ask
666682 let context = stateElemsContext rstate
667683 --replace the relationVariables context element with a cloned set of relation devoid of tuples
668− let context' = contextWithEmptyTupleSets context
669− rstate' = setStateElemsContext rstate context'
670684 --evalRelationalExpr could still return an existing relation with tuples, so strip them
671− pure $ case runReader (evalRelationalExpr expr) rstate' of
672− Left err -> Left err
673− Right typeRel -> Right (relationWithEmptyTupleSet typeRel)
685+ let gfExpr = processRelationalExpr expr transId
686+ pure (typeForGraphRefRelationalExpr gfExpr graph)
674687
675688--returns a database context with all tuples removed
676689--this is useful for type checking and optimization
690+{-
677691contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
678692contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
679693 where
680− relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
694+ relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)
695+-}
681696
682697liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
683698liftE v = do
@@ -1043,10 +1058,97 @@ processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do
10431058 Left err -> pure (Left err)
10441059 Right expr -> pure (Right (AttributeExtendTupleExpr nam expr))
10451060
1046−typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionId -> TransactionGraph -> Either RelationalError Relation
1047−typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = mkRelation attrs emptyTupleSet
1048−typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))
1049−typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = unimplemented
1061+typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation
1062+typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) _ = mkRelation attrs emptyTupleSet
1063+typeForGraphRefRelationalExpr (ExistingRelation rel) _ = pure (emptyRelationWithAttrs (attributes rel))
1064+typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) graph =
1065+ case mAttrExprs of
1066+ Just attrExprs -> do
1067+ attrs <- mapM (\e -> evalGraphRefAttributeExpr e graph) attrExprs
1068+ pure (emptyRelationWithAttrs attrs)
1069+typeForGraphRefRelationalExpr (RelationVariable rvName tid) graph = do
1070+ trans <- transactionForId tid graph
1071+ let relVars = relationVariables (concreteDatabaseContext trans)
1072+ case M.lookup rvName relVars of
1073+ Nothing -> Left $ RelVarNotDefinedError name
1074+ Just rvExpr -> typeForGraphRefRelationalExpr rvExpr graph
1075+typeForGraphRefRelationalExpr (Project attrNames expr) graph = do
1076+ exprType <- typeForGraphRefRelationalExpr expr graph
1077+ projectionAttrs <- evalGraphRefAttributeNames attrNames expr graph
1078+ project projectionAttrs exprType
1079+
1080+evalGraphRefAttributeNames :: AttributeNames -> GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError (S.Set AttributeName)
1081+evalGraphRefAttributeNames attrNames expr graph = do
1082+ exprTyp <- typeForGraphRefRelationalExpr expr graph
1083+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
1084+ case attrNames of
1085+ AttributeNames names ->
1086+ case A.projectionAttributesForNames names (attributes exprTyp) of
1087+ Left err -> pure (Left err)
1088+ Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))
1089+
1090+ InvertedAttributeNames names -> do
1091+ let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
1092+ if not (S.null nonExistentAttributeNames) then
1093+ pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))
1094+ else
1095+ pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))
1096+
1097+ UnionAttributeNames namesA namesB -> do
1098+ eNameSetA <- evalAttributeNames namesA expr
1099+ case eNameSetA of
1100+ Left err -> pure (Left err)
1101+ Right nameSetA -> do
1102+ eNameSetB <- evalAttributeNames namesB expr
1103+ case eNameSetB of
1104+ Left err -> pure (Left err)
1105+ Right nameSetB ->
1106+ pure (Right (S.union nameSetA nameSetB))
1107+
1108+ IntersectAttributeNames namesA namesB -> do
1109+ eNameSetA <- evalAttributeNames namesA expr
1110+ case eNameSetA of
1111+ Left err -> pure (Left err)
1112+ Right nameSetA -> do
1113+ eNameSetB <- evalAttributeNames namesB expr
1114+ case eNameSetB of
1115+ Left err -> pure (Left err)
1116+ Right nameSetB ->
1117+ pure (Right (S.intersection nameSetA nameSetB))
1118+
1119+ RelationalExprAttributeNames attrExpr -> do
1120+ eAttrExprType <- typeForRelationalExpr attrExpr
1121+ case eAttrExprType of
1122+ Left err -> pure (Left err)
1123+ Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
1124+
1125+
1126+
10501127
10511128processAtomExpr :: AtomExpr -> TransactionId -> GraphRefAtomExpr
1052−processAtomExpr = unimplemented
1129+processAtomExpr (AttributeAtomExpr nam) _ = AttributeAtomExpr nam
1130+processAtomExpr (NakedAtomExpr atom) _ = NakedAtomExpr atom
1131+processAtomExpr (FunctionAtomExpr fName atomExprs ()) tid = FunctionAtomExpr fName (fmap processAtomExpr tid) tid
1132+processAtomExpr (RelationAtomExpr expr) tid = RelationAtomExpr (processRelationalExpr expr tid)
1133+processAtomExpr (ConstructedAtomExpr dConsName atomExprs) = ConstructedAtomExpr dConsName (fmap processAtomExpr tid) tid
1134+
1135+processTupleExpr :: TupleExpr -> TransactionId -> GraphRefTupleExpr
1136+processTupleExpr (TupleExpr tMap) tid = TupleExpr (M.map (processAtomExpr tid) tMap)
1137+
1138+evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> TransactionGraph -> Either RelationalError Attribute
1139+evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) graph = do
1140+ trans <- transactionForId tid graph
1141+ let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)
1142+ aType <- atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
1143+ validateAtomType aType tConsMap
1144+ pure (Attribute attrName aType)
1145+
1146+--convert AttributeExpr to GraphRefAttributeExpr
1147+processAttributeExpr :: AttributeExpr -> TransactionId -> GraphRefAttributeExpr
1148+processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) tid = AttributeAndTypeNameExpr nam tCons tid
1149+processAttributeExpr (NakedAttributeExpr attr) = NakedAttributeExpr attr
1150+
1151+-- convert a RelationalExpr into a GraphRefRelationalExpr
1152+processRelationalExpr :: RelationalExpr -> TransactionId -> GraphRefRelationalExpr
1153+processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) =
1154+ MakeRelationFromExprs (fmap (fmap processAttributeExpr) mAttrs) (processTupleExprs tupleExprs)