@@ -4,6 +4,7 @@ import ProjectM36.Relation
44import ProjectM36.Tuple
55import ProjectM36.TupleSet
66import ProjectM36.Base
7+import qualified Data.UUID as U
78import ProjectM36.Error
89import ProjectM36.AtomType
910import ProjectM36.Attribute (emptyAttributes)
@@ -46,7 +47,11 @@ databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTu
4647
4748-- | Used to start a fresh database state for a new database context expression.
4849freshDatabaseState :: DatabaseContext -> DatabaseStateElems
49−freshDatabaseState ctx = (ctx, M.empty, False) --future work: propagate return accumulator
50+freshDatabaseState context = DatabaseStateElems {
51+ context = context,
52+ accum = M.empty,
53+ dirty = False
54+ } --future work: propagate return accumulator
5055
5156-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
5257data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
@@ -80,19 +85,21 @@ data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,
8085 resultAccumResult :: Relation
8186 }
8287
83−type DatabaseStateElems = (DatabaseContext, M.Map ResultAccumName ResultAccum, DirtyFlag)
88+data DatabaseStateElems = DatabaseStateElems {
89+ context :: DatabaseContext, --new, alterable context for a new transaction
90+ accum :: M.Map ResultAccumName ResultAccum,
91+ dirty :: DirtyFlag
92+ }
8493
8594type DatabaseState a = State DatabaseStateElems a
8695
8796getStateContext :: DatabaseState DatabaseContext
88−getStateContext = do
89− (ctx,_, _) <- get
90− pure ctx
91−
97+getStateContext = context <$> get
98+
9299putStateContext :: DatabaseContext -> DatabaseState ()
93−putStateContext ctx = do
94− (_, accum, _) <- get
95− put (ctx, accum, True)
100+putStateContext ctx' = do
101+ s <- get
102+ put (s {context = ctx'})
96103
97104type RelationalExprState a = Reader RelationalExprStateElems a
98105
@@ -107,7 +114,7 @@ setStateElemsContext (RelationalExprStateElems _) ctx = RelationalExprStateElems
107114setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
108115
109116--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
110−evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
117+evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)
111118evalRelationalExpr (RelationVariable name _) = do
112119 relvarTable <- fmap (relationVariables . stateElemsContext) ask
113120 return $ case M.lookup name relvarTable of
@@ -121,7 +128,7 @@ evalRelationalExpr (Project attrNames expr) = do
121128 Right attrNameSet -> do
122129 rel <- evalRelationalExpr expr
123130 case rel of
124− Right rel2 -> pure $ project attrNameSet rel2
131+ Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)
125132 Left err -> pure $ Left err
126133
127134evalRelationalExpr (Union exprA exprB) = do
@@ -131,7 +138,7 @@ evalRelationalExpr (Union exprA exprB) = do
131138 Left err -> return $ Left err
132139 Right relA2 -> case relB of
133140 Left err -> return $ Left err
134− Right relB2 -> return $ union relA2 relB2
141+ Right relB2 -> return $ Right (Union relA2 relB2)
135142
136143evalRelationalExpr (Join exprA exprB) = do
137144 relA <- evalRelationalExpr exprA
@@ -140,7 +147,7 @@ evalRelationalExpr (Join exprA exprB) = do
140147 Left err -> return $ Left err
141148 Right relA2 -> case relB of
142149 Left err -> return $ Left err
143− Right relB2 -> return $ join relA2 relB2
150+ Right relB2 -> return $ Right (Join relA2 relB2)
144151
145152evalRelationalExpr (Difference exprA exprB) = do
146153 relA <- evalRelationalExpr exprA
@@ -149,11 +156,11 @@ evalRelationalExpr (Difference exprA exprB) = do
149156 Left err -> return $ Left err
150157 Right relA2 -> case relB of
151158 Left err -> return $ Left err
152− Right relB2 -> return $ difference relA2 relB2
159+ Right relB2 -> return $ Right (Difference relA2 relB2)
153160
154161evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
155162 case mkRelation attributeSet tupleSet of
156− Right rel -> return $ Right rel
163+ Right rel -> return $ Right (ExistingRelation rel)
157164 Left err -> return $ Left err
158165
159166evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
@@ -168,14 +175,15 @@ evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
168175 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
169176 let attrs = fromMaybe firstTupleAttrs mAttrs
170177 firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)
171− either throwE pure (mkRelation attrs (RelationTupleSet tuples))
178+ expr <- either throwE pure (mkRelation attrs (RelationTupleSet tuples))
179+ pure (ExistingRelation expr)
172180
173−evalRelationalExpr (ExistingRelation rel) = pure (Right rel)
181+evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))
174182
175183evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
176184 evald <- evalRelationalExpr relExpr
177185 case evald of
178− Right rel -> return $ rename oldAttrName newAttrName rel
186+ Right expr -> return $ Right (Rename oldAttrName newAttrName expr)
179187 Left err -> return $ Left err
180188
181189evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
@@ -185,35 +193,33 @@ evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
185193 Right oldAttrNameSet -> do
186194 evald <- evalRelationalExpr relExpr
187195 case evald of
188− Right rel -> return $ group oldAttrNameSet newAttrName rel
196+ Right expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)
189197 Left err -> return $ Left err
190198
191199evalRelationalExpr (Ungroup attrName relExpr) = do
192200 evald <- evalRelationalExpr relExpr
193201 case evald of
194− Right rel -> return $ ungroup attrName rel
202+ Right expr -> return $ Right (Ungroup attrName expr)
195203 Left err -> return $ Left err
196204
197205evalRelationalExpr (Restrict predicateExpr relExpr) = do
198206 evald <- evalRelationalExpr relExpr
207+ ePred <- processRestrictionPredicateExpr predicateExpr
199208 case evald of
200209 Left err -> return $ Left err
201− Right rel -> do
202− eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr
203− case eFilterFunc of
204− Left err -> return $ Left err
205− Right filterfunc ->
206− pure (restrict filterfunc rel)
210+ Right expr -> case ePred of
211+ Left err -> pure (Left err)
212+ Right pred -> pure $ Right (Restrict pred expr)
207213
208214evalRelationalExpr (Equals relExprA relExprB) = do
209215 evaldA <- evalRelationalExpr relExprA
210216 evaldB <- evalRelationalExpr relExprB
211217 case evaldA of
212218 Left err -> return $ Left err
213− Right relA -> case evaldB of
219+ Right exprA -> case evaldB of
214220 Left err -> return $ Left err
215− Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse
216−
221+ Right exprB -> return $ Right (Equals exprA exprB)
222+{-
217223evalRelationalExpr (With views mainExpr) = do
218224 rstate <- ask
219225
@@ -231,36 +237,36 @@ evalRelationalExpr (With views mainExpr) = do
231237 case evalMainExpr mainExpr of
232238 Left err -> return $ Left err
233239 Right rel -> return $ Right rel
234−
240+-}
235241--warning: copy-pasta from above- refactor
236242evalRelationalExpr (NotEquals relExprA relExprB) = do
237243 evaldA <- evalRelationalExpr relExprA
238244 evaldB <- evalRelationalExpr relExprB
239245 case evaldA of
240246 Left err -> return $ Left err
241− Right relA -> case evaldB of
247+ Right exprA -> case evaldB of
242248 Left err -> return $ Left err
243− Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse
249+ Right exprB -> return $ Right (NotEquals exprA exprB)
244250
245251-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
246252evalRelationalExpr (Extend tupleExpression relExpr) = do
247− rstate <- ask
248− let evald = runReader (evalRelationalExpr relExpr) rstate
249− case evald of
253+ eExpr <- evalRelationalExpr relExpr
254+ case eExpr of
250255 Left err -> pure (Left err)
251− Right rel -> do
252− tupProc <- extendTupleExpressionProcessor rel tupleExpression
253− case tupProc of
256+ Right expr -> do
257+ eTupProc <- processExtendTupleExpr tupleExpression
258+ case eTupProc of
254259 Left err -> pure (Left err)
255− Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel
260+ Right tupProc -> pure (Right (Extend tupProc expr))
256261
257262--helper function to process relation variable creation/assignment
258−setRelVar :: RelVarName -> Relation -> DatabaseState (Either RelationalError ())
259−setRelVar relVarName rel = do
263+setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseState (Either RelationalError ())
264+setRelVar relVarName relExpr = do
260265 currentContext <- getStateContext
261− let newRelVars = M.insert relVarName rel $ relationVariables currentContext
266+ let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext
262267 potentialContext = currentContext { relationVariables = newRelVars }
263−
268+ --determine when to check constraints
269+
264270 case checkConstraints potentialContext of
265271 Left err -> pure (Left err)
266272 Right _ -> do
@@ -280,10 +286,10 @@ deleteRelVar relVarName = do
280286 putStateContext newContext
281287 pure (Right ())
282288
283−evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Either RelationalError ())
284−evalDatabaseContextExpr NoOperation = pure (Right ())
289+evalDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())
290+evalDatabaseContextExpr NoOperation _ _ = pure (Right ())
285291
286−evalDatabaseContextExpr (Define relVarName attrExprs) = do
292+evalDatabaseContextExpr (Define relVarName attrExprs) _ _ = do
287293 relvars <- fmap relationVariables getStateContext
288294 tConss <- fmap typeConstructorMapping getStateContext
289295 let eAttrs = map (evalAttrExpr tConss) attrExprs
@@ -298,84 +304,79 @@ evalDatabaseContextExpr (Define relVarName attrExprs) = do
298304 else
299305 case M.member relVarName relvars of
300306 True -> pure (Left (RelVarAlreadyDefinedError relVarName))
301− False -> setRelVar relVarName emptyRelation >> pure (Right ())
307+ False -> setRelVar relVarName (ExistingRelation emptyRelation) >> pure (Right ())
302308 where
303309 attrs = A.attributesFromList attrsList
304310 emptyRelation = Relation attrs emptyTupleSet
305311
306−evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
312+evalDatabaseContextExpr (Undefine relVarName) _ _ = deleteRelVar relVarName
307313
308−evalDatabaseContextExpr (Assign relVarName expr) = do
309− -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
310− context <- getStateContext
311− let existingRelVar = M.lookup relVarName relVarTable
312− relVarTable = relationVariables context
313− value = runReader (evalRelationalExpr expr) (RelationalExprStateElems context)
314− case value of
315− Left err -> pure (Left err)
316− Right rel -> case existingRelVar of
317− Nothing -> setRelVar relVarName rel
318− Just existingRel -> let expectedAttributes = attributes existingRel
319− foundAttributes = attributes rel in
320− if A.attributesEqual expectedAttributes foundAttributes then
321− setRelVar relVarName rel
322− else
323− pure (Left (RelationTypeMismatchError expectedAttributes foundAttributes))
324−
325−evalDatabaseContextExpr (Insert relVarName relExpr) = do
314+evalDatabaseContextExpr (Assign relVarName expr) transId graph = do
326315 context <- getStateContext
327− let unionexp = Union relExpr rv
328− rv = RelationVariable relVarName ()
329− unioned = runReader (evalRelationalExpr unionexp) (RelationalExprStateElems context)
330− origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)
331− case unioned of
332− Left err -> pure (Left err)
333− Right unioned' -> case origRel of
334− Left err -> pure (Left err)
335− Right origRel' -> if cardinality unioned' == cardinality origRel' then --no tuples actually inserted
336− pure (Right ())
337− else
338− evalDatabaseContextExpr $ Assign relVarName (ExistingRelation unioned')
316+ let existingRelVar = M.lookup relVarName (relationVariables context)
317+ relExprState = mkRelationalExprState context
318+ case existingRelVar of
319+ Nothing -> do
320+ let ervExpr = runReader (evalRelationalExpr expr) relExprState
321+ case ervExpr of
322+ Left err -> pure (Left err)
323+ Right rvExpr -> setRelVar relVarName rvExpr
324+ Just existingRel -> do
325+ let eExpectedType = typeForGraphRefRelationalExpr existingRel transId graph
326+ eNewExprType = runReader (typeForRelationalExpr expr) relExprState
327+ case eExpectedType of
328+ Left err -> pure (Left err)
329+ Right expectedType ->
330+ case eNewExprType of
331+ Left err -> pure (Left err)
332+ Right newExprType -> do
333+ if newExprType == expectedType then do
334+ let ervExpr = runReader (evalRelationalExpr expr) relExprState
335+ case ervExpr of
336+ Left err -> pure (Left err)
337+ Right rvExpr -> setRelVar relVarName rvExpr
338+ else
339+ pure (Left (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)))
339340
340−evalDatabaseContextExpr (Delete relVarName predicate) = do
341− context <- getStateContext
342− let rv = RelationVariable relVarName ()
343− let updatedRel = runReader (evalRelationalExpr (Restrict (NotPredicate predicate) rv)) (RelationalExprStateElems context)
344− origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)
345− case updatedRel of
346− Left err -> pure (Left err)
347− Right updatedRel' -> case origRel of
348− Left err -> pure (Left err)
349− Right origRel' -> if cardinality origRel' == cardinality updatedRel' then
350− pure (Right ())
351− else
352− setRelVar relVarName updatedRel'
341+evalDatabaseContextExpr (Insert relVarName relExpr) tid graph =
342+ evalDatabaseContextExpr (Assign relVarName (Union (RelationVariable relVarName ())
343+ relExpr)) tid graph
353344
345+evalDatabaseContextExpr (Delete relVarName predicate) transId _ = do
346+ ctx <- getStateContext
347+ let rv = RelationVariable relVarName transId
348+ rvState = mkRelationalExprState ctx
349+ case runReader (processRestrictionPredicateExpr predicate) rvState of
350+ Left err -> pure (Left err)
351+ Right graphRefPredicate ->
352+ setRelVar relVarName (Restrict (NotPredicate graphRefPredicate) rv)
353+
354354--union of restricted+updated portion and the unrestricted+unupdated portion
355−evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do
355+evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId _ = do
356356 context <- getStateContext
357− let relVarTable = relationVariables context
358− case M.lookup relVarName relVarTable of
359− Nothing -> pure (Left (RelVarNotDefinedError relVarName))
360− Just rel ->
361− case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of
362− Left err -> pure (Left err)
363− Right predicateFunc -> do
364− let ret = do
365− restrictedPortion <- restrict predicateFunc rel
366− if cardinality restrictedPortion == Finite 0 then
367− pure Nothing
368− else do
369− unrestrictedPortion <- restrict (predicateFunc >=> (pure . not)) rel
370− updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion
371− updatedRel <- updatedPortion `union` unrestrictedPortion
372− pure (Just updatedRel)
373− case ret of
374− Left err -> pure (Left err)
375− Right Nothing -> pure (Right ())
376− Right (Just updatedRel) -> setRelVar relVarName updatedRel
357+ let rvState = mkRelationalExprState context
358+ relVarTable = relationVariables context
359+ case runReader (processRestrictionPredicateExpr restrictionPredicateExpr) rvState of
360+ Left err -> pure (Left err)
361+ Right graphRefPredicate ->
362+ case M.lookup relVarName relVarTable of
363+ Nothing -> pure (Left (RelVarNotDefinedError relVarName))
364+ Just existingRvExpr -> do
365+ let unrestrictedPortion = Restrict (NotPredicate graphRefPredicate) rv
366+ rv = RelationVariable relVarName transId
367+ tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict
368+ updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)
369+ projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
370+ restrictedPortion = Restrict graphRefPredicate
371+ updated = foldr (\(oldname, atomExpr) accum ->
372+ let procAtomExpr = processAtomExpr atomExpr transId in
373+ updateAttr oldname procAtomExpr accum
374+ ) rv (M.toList atomExprMap)
375+ -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
376+ updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)
377+ setRelVar relVarName (Union unrestrictedPortion updatedPortion)
377378
378−evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
379+evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) _ _ = do
379380 currContext <- getStateContext
380381 let currDeps = inclusionDependencies currContext
381382 newDeps = M.insert newDepName newDep currDeps
@@ -389,7 +390,7 @@ evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
389390 putStateContext potentialContext
390391 return (Right ())
391392
392−evalDatabaseContextExpr (RemoveInclusionDependency depName) = do
393+evalDatabaseContextExpr (RemoveInclusionDependency depName) _ _ = do
393394 currContext <- getStateContext
394395 let currDeps = inclusionDependencies currContext
395396 newDeps = M.delete depName currDeps
@@ -400,7 +401,7 @@ evalDatabaseContextExpr (RemoveInclusionDependency depName) = do
400401 return (Right ())
401402
402403-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
403−evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do
404+evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) _ _ = do
404405 currentContext <- getStateContext
405406 let nots = notifications currentContext
406407 if M.member notName nots then
@@ -413,7 +414,7 @@ evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resul
413414 putStateContext $ currentContext { notifications = newNotifications }
414415 return (Right ())
415416
416−evalDatabaseContextExpr (RemoveNotification notName) = do
417+evalDatabaseContextExpr (RemoveNotification notName) _ _ = do
417418 currentContext <- getStateContext
418419 let nots = notifications currentContext
419420 if M.notMember notName nots then
@@ -425,7 +426,7 @@ evalDatabaseContextExpr (RemoveNotification notName) = do
425426
426427-- | Adds type and data constructors to the database context.
427428-- validate that the type *and* constructor names are unique! not yet implemented!
428−evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
429+evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) _ _ = do
429430 currentContext <- getStateContext
430431 let oldTypes = typeConstructorMapping currentContext
431432 tConsName = TCD.name tConsDef
@@ -440,7 +441,7 @@ evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
440441 pure (Right ())
441442
442443-- | 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.
443−evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do
444+evalDatabaseContextExpr (RemoveTypeConstructor tConsName) _ _ = do
444445 currentContext <- getStateContext
445446 let oldTypes = typeConstructorMapping currentContext
446447 if isNothing (findTypeConstructor tConsName oldTypes) then
@@ -450,15 +451,15 @@ evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do
450451 putStateContext $ currentContext { typeConstructorMapping = newTypes }
451452 pure (Right ())
452453
453−evalDatabaseContextExpr (MultipleExpr exprs) = do
454+evalDatabaseContextExpr (MultipleExpr exprs) transId graph = do
454455 --the multiple expressions must pass the same context around- not the old unmodified context
455− evald <- forM exprs evalDatabaseContextExpr
456+ evald <- forM exprs (\expr -> evalDatabaseContextExpr expr transId graph)
456457 --some lifting magic needed here
457458 case lefts evald of
458459 [] -> pure (Right ())
459460 errs -> pure (Left (someErrors errs))
460461
461−evalDatabaseContextExpr (RemoveAtomFunction funcName) = do
462+evalDatabaseContextExpr (RemoveAtomFunction funcName) _ _ = do
462463 currentContext <- getStateContext
463464 let atomFuncs = atomFunctions currentContext
464465 case atomFunctionForName funcName atomFuncs of
@@ -470,7 +471,7 @@ evalDatabaseContextExpr (RemoveAtomFunction funcName) = do
470471 else
471472 pure (Left (PrecompiledFunctionRemoveError funcName))
472473
473−evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
474+evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) _ _ = do
474475 context <- getStateContext
475476 let dbcFuncs = dbcFunctions context
476477 case databaseContextFunctionForName funcName dbcFuncs of
@@ -482,7 +483,7 @@ evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
482483 else
483484 pure (Left (PrecompiledFunctionRemoveError funcName))
484485
485−evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
486+evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) _ _ = do
486487 context <- getStateContext
487488 --resolve atom arguments
488489 let relExprState = mkRelationalExprState context
@@ -515,8 +516,8 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) =
515516 Left err -> pure (Left err)
516517 Right newContext -> putStateContext newContext >> pure (Right ())
517518
518−evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
519−evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) =
519+evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> TransactionId -> TransactionGraph -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
520+evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddAtomFunction funcName funcType script) =
520521 case mScriptSession of
521522 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
522523 Just scriptSession -> do
@@ -548,7 +549,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam
548549 Left err -> pure (Left err)
549550 Right context' -> pure (Right context')
550551
551−evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) =
552+evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddDatabaseContextFunction funcName funcType script) =
552553 case mScriptSession of
553554 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
554555 Just scriptSession -> do
@@ -587,14 +588,14 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct
587588 Right eContext -> case eContext of
588589 Left err -> pure (Left err)
589590 Right context' -> pure (Right context')
590−evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do
591+evalDatabaseContextIOExpr _ currentContext _ _ (LoadAtomFunctions modName funcName modPath) = do
591592 eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
592593 case eLoadFunc of
593594 Left LoadSymbolError -> pure (Left LoadFunctionError)
594595 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
595596 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
596597 in pure (Right newContext)
597−evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName funcName modPath) = do
598+evalDatabaseContextIOExpr _ currentContext _ _ (LoadDatabaseContextFunctions modName funcName modPath) = do
598599 eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
599600 case eLoadFunc of
600601 Left LoadSymbolError -> pure (Left LoadFunctionError)
@@ -602,26 +603,29 @@ evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName
602603 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
603604 in pure (Right newContext)
604605
605−evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =
606+evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelation relVarName attrExprs range) =
606607 --Define
607− case runState ( evalDatabaseContextExpr (Define relVarName attrExprs)) (freshDatabaseState currentContext) of
608+ case runState (evalDatabaseContextExpr (Define relVarName attrExprs) transId graph) (freshDatabaseState currentContext) of
608609 (Left err,_) -> pure (Left err)
609− (Right (), elems@(ctx,_,_)) -> do
610+ (Right (), elems) -> do
610611 --Assign
611612 let existingRelVar = M.lookup relVarName relVarTable
612− relVarTable = relationVariables ctx
613+ relVarTable = relationVariables (context elems)
613614 case existingRelVar of
614615 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
615616 Just existingRel -> do
616− let expectedAttributes = attributes existingRel
617− let tcMap = typeConstructorMapping ctx
618− eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
619− case eitherRel of
620− Left err -> pure $ Left err
621− Right rel ->
622− case runState (setRelVar relVarName rel) elems of
623− (Left err,_) -> pure (Left err)
624− (Right (), (ctx',_,_)) -> pure $ Right ctx'
617+ case typeForGraphRefRelationalExpr existingRel transId graph of
618+ Left err -> pure (Left err)
619+ Right relType -> do
620+ let expectedAttributes = attributes relType
621+ tcMap = typeConstructorMapping (context elems)
622+ eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
623+ case eitherRel of
624+ Left err -> pure $ Left err
625+ Right rel ->
626+ case runState (setRelVar relVarName (ExistingRelation rel)) elems of
627+ (Left err,_) -> pure (Left err)
628+ (Right (), elems') -> pure $ Right (context elems)
625629
626630updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
627631updateTupleWithAtomExprs exprMap context tupIn = do
@@ -683,7 +687,7 @@ liftE v = do
683687 Right val -> pure val
684688
685689{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
686−predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter)
690+predicateRestrictionFilter :: Attributes -> RestrictionPredicateExprBase a -> RelationalExprState (Either RelationalError RestrictionFilter)
687691predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =
688692 runExceptT $ do
689693 expr1v <- liftE (predicateRestrictionFilter attrs expr1)
@@ -1000,3 +1004,49 @@ evalAttributeNames attrNames expr = do
10001004 Left err -> pure (Left err)
10011005 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
10021006
1007+evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation
1008+evalGraphRefRelationalExpr (RelationVariable name tid) graph = do
1009+ ctx <- dbContextForTransId tid graph
1010+ case M.lookup name (relationVariables ctx) of
1011+ Nothing -> Left (RelVarNotDefinedError name)
1012+ Just rv -> evalGraphRefRelationalExpr rv graph
1013+
1014+dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext
1015+dbContextForTransId tid graph = do
1016+ trans <- transactionForId tid graph
1017+ pure (concreteDatabaseContext ctx)
1018+
1019+transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
1020+transactionForId tid graph
1021+ | tid == U.nil =
1022+ Left RootTransactionTraversalError
1023+ | S.null matchingTrans =
1024+ Left $ NoSuchTransactionError tid
1025+ | otherwise =
1026+ Right $ head (S.toList matchingTrans)
1027+ where
1028+ matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
1029+
1030+processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError GraphRefRestrictionPredicateExpr)
1031+processRestrictionPredicateExpr TruePredicate = TruePredicate
1032+processRestrictionPredicateExpr (AndPredicate a b) = pure $ AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
1033+processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
1034+processRestrictionPredicateExpr (NotPredicate a) = pure $ NotPredicate <$> processRestrictionPredicateExpr a
1035+processRestrictionPredicateExpr (RelationalExprPredicate expr) = pure $ RelationalExprPredicate <$> evalRelationalExpr expr
1036+processRestrictionPredicateExpr (AtomExprPredicate expr) = AtomExprPredicate <$> evalAtomExpr expr
1037+processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = AttributeEqualityPredicate nam <$> evalAtomExpr expr
1038+
1039+processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError (ExtendTupleExprBase a))
1040+processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do
1041+ eExpr <- evalAtomExpr atomExpr
1042+ case eExpr of
1043+ Left err -> pure (Left err)
1044+ Right expr -> pure (Right (AttributeExtendTupleExpr nam expr))
1045+
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
1050+
1051+processAtomExpr :: AtomExpr -> TransactionId -> GraphRefAtomExpr
1052+processAtomExpr = unimplemented