@@ -18,7 +18,9 @@ import qualified ProjectM36.Attribute as A
1818import qualified Data.Map as M
1919import qualified Data.HashSet as HS
2020import qualified Data.Set as S
21−import Control.Monad.State hiding (join)
21+import Control.Monad.Trans.RWS.Strict as RWS hiding (join)
22+import Control.Monad.Trans.Class (lift)
23+import Control.Monad (forM)
2224import Control.Exception
2325import Data.Maybe
2426import Data.Either
@@ -27,13 +29,16 @@ import qualified Data.Text as T
2729import qualified Data.Vector as V
2830import qualified ProjectM36.TypeConstructorDef as TCD
2931import Control.Monad.Trans.Except
30−import Control.Monad.Trans.Reader
32+import Control.Monad.Trans.Reader as R
3133import Test.QuickCheck
3234import GHC
3335import GHC.Paths
3436import Data.Time.Clock
3537import Data.Time.Calendar
3638import qualified Data.List.NonEmpty as NE
39+import Data.Functor.Identity
40+import Control.Monad
41+import Control.Monad.IO.Class
3742
3843data DatabaseContextExprDetails = CountUpdatedTuples
3944
@@ -50,11 +55,11 @@ databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTu
5055 Right ts -> ts
5156
5257-- | Used to start a fresh database state for a new database context expression.
53−freshDatabaseState :: DatabaseContext -> DatabaseStateElems
54−freshDatabaseState context = DatabaseStateElems {
55− context = context,
56− accum = M.empty,
57− dirty = False
58+mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
59+mkDatabaseContextEvalState context = DatabaseContextEvalState {
60+ dbc_context = context,
61+ dbc_accum = M.empty,
62+ dbc_dirty = False
5863 } --future work: propagate return accumulator
5964
6065-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
@@ -70,27 +75,25 @@ stateTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (re_extra e))
7075
7176stateAttributes :: RelationalExprEnv -> Attributes
7277stateAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (re_extra e))
73−{-
74−data RelationalExprEnv = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
75− RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
76− RelationalExprEnv DatabaseContext --used by default at the top level of evaluation
77− -}
7878
7979instance Show RelationalExprEnv where
8080 show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)
8181
82−mkRelationalExprState :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprEnv
83−mkRelationalExprState ctx currentTransId graph =
82+mkRelationalExprEnv :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprEnv
83+mkRelationalExprEnv ctx currentTransId graph =
8484 RelationalExprEnv
8585 { re_context = ctx,
8686 re_graph = graph,
8787 re_currentTransId = currentTransId,
8888 re_extra = Nothing }
8989
90+askEnv :: RelationalExprState RelationalExprEnv
91+askEnv = R.ask
92+
9093currentTrans :: RelationalExprState (Either RelationalError Transaction)
9194currentTrans = do
92− tid <- re_currentTransId <$> ask
93− graph <- re_graph <$> ask
95+ tid <- re_currentTransId <$> R.ask
96+ graph <- re_graph <$> R.ask
9497 pure (transactionForId tid graph)
9598
9699mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprEnv -> RelationalExprEnv
@@ -114,21 +117,47 @@ data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,
114117 resultAccumResult :: Relation
115118 }
116119
117−data DatabaseStateElems = DatabaseStateElems {
118− context :: DatabaseContext, --new, alterable context for a new transaction
119− accum :: M.Map ResultAccumName ResultAccum,
120− dirty :: DirtyFlag
120+data DatabaseContextEvalState = DatabaseContextEvalState {
121+ dbc_context :: DatabaseContext, --new, alterable context for a new transaction
122+ dbc_accum :: M.Map ResultAccumName ResultAccum,
123+ dbc_dirty :: DirtyFlag
124+ }
125+
126+data DatabaseContextEvalEnv = DatabaseContextEvalEnv
127+ { dce_transId :: TransactionId,
128+ dce_graph :: TransactionGraph
121129 }
122130
123−type DatabaseState a = State DatabaseStateElems a
131+mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
132+mkDatabaseContextEvalEnv tid graph = DatabaseContextEvalEnv tid graph
133+
134+type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a
135+
136+runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState
137+runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> (execRWST m env freshEnv)))
138+ where
139+ freshEnv = mkDatabaseContextEvalState ctx
140+
141+
142+dbcTransId :: DatabaseContextEvalMonad TransactionId
143+dbcTransId = dce_transId <$> RWS.ask
144+
145+dbcGraph :: DatabaseContextEvalMonad TransactionGraph
146+dbcGraph = dce_graph <$> RWS.ask
124147
125−getStateContext :: DatabaseState DatabaseContext
126−getStateContext = context <$> get
148+dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
149+dbcRelationalExprEnv = do
150+ tid <- dbcTransId
151+ graph <- dbcGraph
152+ mkRelationalExprEnv <$> getStateContext <*> dbcTransId <*> dbcGraph
127153
128−putStateContext :: DatabaseContext -> DatabaseState ()
154+getStateContext :: DatabaseContextEvalMonad DatabaseContext
155+getStateContext = dbc_context <$> get
156+
157+putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()
129158putStateContext ctx' = do
130159 s <- get
131− put (s {context = ctx'})
160+ put (s {dbc_context = ctx'})
132161
133162type RelationalExprState a = Reader RelationalExprEnv a
134163
@@ -138,10 +167,21 @@ envContext = re_context
138167setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv
139168setEnvContext e ctx = e { re_context = ctx }
140169
170+{-
171+--full evaluation down the graph
172+eval :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
173+eval expr = do
174+ env <- askEnv
175+ eGfExpr <- processRelationalExpr expr
176+ case eGfExpr of
177+ Left err -> pure (Left err)
178+ Right gfExpr -> pure $ evalGraphRefRelationalExpr gfExpr (re_graph env)
179+-}
180+{-
141181--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
142182evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)
143183evalRelationalExpr (RelationVariable name _) = do
144− relvarTable <- fmap (relationVariables . envContext) ask
184+ relvarTable <- fmap (relationVariables . envContext) askEnv
145185 return $ case M.lookup name relvarTable of
146186 Just res -> Right res
147187 Nothing -> Left $ RelVarNotDefinedError name
@@ -189,13 +229,13 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
189229 Left err -> return $ Left err
190230
191231evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
192− currentContext <- fmap envContext ask
232+ currentContext <- fmap envContext askEnv
193233 let tConss = typeConstructorMapping currentContext
194234 -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible
195235 runExceptT $ do
196236 mAttrs <- case mAttrExprs of
197237 Just _ ->
198− Just . A.attributesFromList <$> mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)
238+ Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)
199239 Nothing -> pure Nothing
200240 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
201241 let attrs = fromMaybe firstTupleAttrs mAttrs
@@ -229,12 +269,11 @@ evalRelationalExpr (Ungroup attrName relExpr) = do
229269
230270evalRelationalExpr (Restrict predicateExpr relExpr) = do
231271 evald <- evalRelationalExpr relExpr
232− ePred <- processRestrictionPredicateExpr predicateExpr
272+ pred <- processRestrictionPredicateExpr predicateExpr
233273 case evald of
234274 Left err -> return $ Left err
235− Right expr -> case ePred of
236− Left err -> pure (Left err)
237− Right pred -> pure $ Right (Restrict pred expr)
275+ Right expr ->
276+ pure $ Right (Restrict pred expr)
238277
239278evalRelationalExpr (Equals relExprA relExprB) = do
240279 evaldA <- evalRelationalExpr relExprA
@@ -279,252 +318,240 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do
279318 case eExpr of
280319 Left err -> pure (Left err)
281320 Right expr -> do
282− eTupProc <- processExtendTupleExpr tupleExpression
283− case eTupProc of
284− Left err -> pure (Left err)
285− Right tupProc -> pure (Right (Extend tupProc expr))
286−
321+ tupProc <- processExtendTupleExpr tupleExpression
322+ pure (Right (Extend tupProc expr))
323+-}
287324--helper function to process relation variable creation/assignment
288−setRelVar :: RelVarName -> GraphRefRelationalExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())
289−setRelVar relVarName relExpr transId graph = do
325+setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
326+setRelVar relVarName relExpr = do
327+
290328 currentContext <- getStateContext
291329 let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext
292330 potentialContext = currentContext { relationVariables = newRelVars }
293331 --determine when to check constraints
294−
295− case checkConstraints potentialContext transId graph of
296− Left err -> pure (Left err)
297− Right _ -> do
298− putStateContext potentialContext
299− return (Right ())
332+ graph <- dbcGraph
333+ tid <- dbcTransId
334+ case checkConstraints potentialContext tid graph of
335+ Left err -> dbErr err
336+ Right _ -> putStateContext potentialContext
300337
301338-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation
302−deleteRelVar :: RelVarName -> DatabaseState (Either RelationalError ())
339+deleteRelVar :: RelVarName -> DatabaseContextEvalMonad ()
303340deleteRelVar relVarName = do
304341 currContext <- getStateContext
305342 let relVars = relationVariables currContext
306343 if M.notMember relVarName relVars then
307− pure (Right ())
344+ pure ()
308345 else do
309346 let newRelVars = M.delete relVarName relVars
310347 newContext = currContext { relationVariables = newRelVars }
311348 putStateContext newContext
312− pure (Right ())
349+ pure ()
313350
314−evalDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())
315−evalDatabaseContextExpr NoOperation _ _ = pure (Right ())
351+evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
352+evalGraphRefDatabaseContextExpr NoOperation = pure ()
316353
317−evalDatabaseContextExpr (Define relVarName attrExprs) transId graph = do
354+evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do
318355 relvars <- fmap relationVariables getStateContext
319356 tConss <- fmap typeConstructorMapping getStateContext
320− let eAttrs = map (evalAttrExpr tConss) attrExprs
357+ relEnv <- dbcRelationalExprEnv
358+ let eAttrs = runReader (mapM evalGraphRefAttrExpr attrExprs) relEnv
321359 attrErrs = lefts eAttrs
322360 attrsList = rights eAttrs
323361 if not (null attrErrs) then
324− pure (Left (someErrors attrErrs))
362+ dbErr (someErrors attrErrs)
325363 else do
326364 let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList
327365 if not (null atomTypeErrs) then
328− pure (Left (someErrors atomTypeErrs))
366+ dbErr (someErrors atomTypeErrs)
329367 else
330368 case M.member relVarName relvars of
331− True -> pure (Left (RelVarAlreadyDefinedError relVarName))
332− False -> setRelVar relVarName (ExistingRelation emptyRelation) transId graph >> pure (Right ())
369+ True -> dbErr (RelVarAlreadyDefinedError relVarName)
370+ False -> setRelVar relVarName (ExistingRelation emptyRelation)
333371 where
334372 attrs = A.attributesFromList attrsList
335373 emptyRelation = Relation attrs emptyTupleSet
336374
337−evalDatabaseContextExpr (Undefine relVarName) _ _ = deleteRelVar relVarName
375+evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
338376
339−evalDatabaseContextExpr (Assign relVarName expr) transId graph = do
377+evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do
378+ relExprEnv <- dbcRelationalExprEnv
340379 context <- getStateContext
341380 let existingRelVar = M.lookup relVarName (relationVariables context)
342− relExprState = mkRelationalExprState context transId graph
343381 case existingRelVar of
344382 Nothing -> do
345− let ervExpr = runReader (evalRelationalExpr expr) relExprState
346− case ervExpr of
347− Left err -> pure (Left err)
348− Right rvExpr -> setRelVar relVarName rvExpr transId graph
383+ setRelVar relVarName expr
349384 Just existingRel -> do
350− let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprState context transId graph)
351− eNewExprType = runReader (typeForRelationalExpr expr) relExprState
385+ let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) relExprEnv
386+ eNewExprType = runReader (typeForGraphRefRelationalExpr expr) relExprEnv
352387 case eExpectedType of
353− Left err -> pure (Left err)
388+ Left err -> dbErr err
354389 Right expectedType ->
355390 case eNewExprType of
356− Left err -> pure (Left err)
391+ Left err -> dbErr err
357392 Right newExprType -> do
358393 if newExprType == expectedType then do
359− let ervExpr = runReader (evalRelationalExpr expr) relExprState
360− case ervExpr of
361− Left err -> pure (Left err)
362− Right rvExpr -> setRelVar relVarName rvExpr transId graph
394+ setRelVar relVarName expr
363395 else
364− pure (Left (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)))
396+ dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))
365397
366−evalDatabaseContextExpr (Insert relVarName relExpr) tid graph =
367− evalDatabaseContextExpr (Assign relVarName (Union (RelationVariable relVarName ())
368− relExpr)) tid graph
398+evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do
399+ transId <- dbcTransId
400+ evalGraphRefDatabaseContextExpr (Assign relVarName
401+ (Union
402+ (RelationVariable relVarName transId)
403+ relExpr))
369404
370−evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do
371− ctx <- getStateContext
405+evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do
406+ transId <- dbcTransId
372407 let rv = RelationVariable relVarName transId
373− rvState = mkRelationalExprState ctx transId graph
374− case runReader (processRestrictionPredicateExpr predicate) rvState of
375− Left err -> pure (Left err)
376− Right graphRefPredicate ->
377− setRelVar relVarName (Restrict (NotPredicate graphRefPredicate) rv) transId graph
408+ setRelVar relVarName (Restrict (NotPredicate predicate) rv)
378409
379410--union of restricted+updated portion and the unrestricted+unupdated portion
380−evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId graph = do
411+evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred) = do
381412 context <- getStateContext
382− let rvState = mkRelationalExprState context transId graph
383− relVarTable = relationVariables context
384− case runReader (processRestrictionPredicateExpr restrictionPredicateExpr) rvState of
385− Left err -> pure (Left err)
386− Right graphRefPredicate ->
387− case M.lookup relVarName relVarTable of
388− Nothing -> pure (Left (RelVarNotDefinedError relVarName))
413+ transId <- dbcTransId
414+ reEnv <- dbcRelationalExprEnv
415+ let relVarMap = relationVariables context
416+ case M.lookup relVarName relVarMap of
417+ Nothing -> dbErr (RelVarNotDefinedError relVarName)
389418 Just existingRvExpr -> do
390− let unrestrictedPortion = Restrict (NotPredicate graphRefPredicate) rv
419+ let unrestrictedPortion = Restrict (NotPredicate pred) rv
391420 rv = RelationVariable relVarName transId
392421 tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict
393422 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)
394423 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
395− restrictedPortion = Restrict graphRefPredicate
424+ restrictedPortion = Restrict pred
396425 updated = foldr (\(oldname, atomExpr) accum ->
397− let procAtomExpr = runReader (processAtomExpr atomExpr) rvState in
426+ let procAtomExpr = runReader (processAtomExpr atomExpr) reEnv in
398427 updateAttr oldname procAtomExpr accum
399428 ) rv (M.toList atomExprMap)
400429 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
401430 updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)
402− setRelVar relVarName (Union unrestrictedPortion updatedPortion) transId graph
431+ setRelVar relVarName (Union unrestrictedPortion updatedPortion)
403432
404−evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) transId graph = do
433+evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
405434 currContext <- getStateContext
435+ transId <- dbcTransId
436+ graph <- dbcGraph
406437 let currDeps = inclusionDependencies currContext
407438 newDeps = M.insert newDepName newDep currDeps
408439 if M.member newDepName currDeps then
409− pure (Left (InclusionDependencyNameInUseError newDepName))
440+ dbErr (InclusionDependencyNameInUseError newDepName)
410441 else do
411442 let potentialContext = currContext { inclusionDependencies = newDeps }
412443 case checkConstraints potentialContext transId graph of
413− Left err -> pure (Left err)
414− Right _ -> do
444+ Left err -> dbErr err
445+ Right _ ->
415446 putStateContext potentialContext
416− return (Right ())
417447
418−evalDatabaseContextExpr (RemoveInclusionDependency depName) _ _ = do
448+evalGraphRefDatabaseContextExpr (RemoveInclusionDependency depName) = do
419449 currContext <- getStateContext
420450 let currDeps = inclusionDependencies currContext
421451 newDeps = M.delete depName currDeps
422452 if M.notMember depName currDeps then
423− pure (Left (InclusionDependencyNameNotInUseError depName))
424− else do
453+ dbErr (InclusionDependencyNameNotInUseError depName)
454+ else
425455 putStateContext $ currContext {inclusionDependencies = newDeps }
426− return (Right ())
427456
428457-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
429−evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) _ _ = do
458+evalGraphRefDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do
430459 currentContext <- getStateContext
431460 let nots = notifications currentContext
432461 if M.member notName nots then
433− pure (Left (NotificationNameInUseError notName))
462+ dbErr (NotificationNameInUseError notName)
434463 else do
435464 let newNotifications = M.insert notName newNotification nots
436465 newNotification = Notification { changeExpr = triggerExpr,
437466 reportOldExpr = resultOldExpr,
438467 reportNewExpr = resultNewExpr}
439468 putStateContext $ currentContext { notifications = newNotifications }
440− return (Right ())
441469
442−evalDatabaseContextExpr (RemoveNotification notName) _ _ = do
470+evalGraphRefDatabaseContextExpr (RemoveNotification notName) = do
443471 currentContext <- getStateContext
444472 let nots = notifications currentContext
445473 if M.notMember notName nots then
446− pure (Left (NotificationNameNotInUseError notName))
474+ dbErr (NotificationNameNotInUseError notName)
447475 else do
448476 let newNotifications = M.delete notName nots
449477 putStateContext $ currentContext { notifications = newNotifications }
450− pure (Right ())
478+
451479
452480-- | Adds type and data constructors to the database context.
453481-- validate that the type *and* constructor names are unique! not yet implemented!
454−evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) _ _ = do
482+evalGraphRefDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
455483 currentContext <- getStateContext
456484 let oldTypes = typeConstructorMapping currentContext
457485 tConsName = TCD.name tConsDef
458486 -- validate that the constructor's types exist
459487 case validateTypeConstructorDef tConsDef dConsDefList of
460− errs@(_:_) -> pure (Left (someErrors errs))
461− [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName))
462− | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName))
488+ errs@(_:_) -> dbErr (someErrors errs)
489+ [] | T.null tConsName || not (isUpper (T.head tConsName)) -> dbErr (InvalidAtomTypeName tConsName)
490+ | isJust (findTypeConstructor tConsName oldTypes) -> dbErr (AtomTypeNameInUseError tConsName)
463491 | otherwise -> do
464492 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
465493 putStateContext $ currentContext { typeConstructorMapping = newTypes }
466− pure (Right ())
467494
468495-- | 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.
469−evalDatabaseContextExpr (RemoveTypeConstructor tConsName) _ _ = do
496+evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do
470497 currentContext <- getStateContext
471498 let oldTypes = typeConstructorMapping currentContext
472499 if isNothing (findTypeConstructor tConsName oldTypes) then
473− pure (Left (AtomTypeNameNotInUseError tConsName))
500+ dbErr (AtomTypeNameNotInUseError tConsName)
474501 else do
475502 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
476503 putStateContext $ currentContext { typeConstructorMapping = newTypes }
477− pure (Right ())
478504
479−evalDatabaseContextExpr (MultipleExpr exprs) transId graph = do
505+evalGraphRefDatabaseContextExpr (MultipleExpr exprs) = do
480506 --the multiple expressions must pass the same context around- not the old unmodified context
481− evald <- forM exprs (\expr -> evalDatabaseContextExpr expr transId graph)
507+ unimplemented
508+{- evald <- forM exprs (\expr -> evalGraphRefDatabaseContextExpr expr)
482509 --some lifting magic needed here
483510 case lefts evald of
484− [] -> pure (Right ())
485− errs -> pure (Left (someErrors errs))
486−
487−evalDatabaseContextExpr (RemoveAtomFunction funcName) _ _ = do
511+ [] -> pure ()
512+ errs -> dbErr (someErrors errs)
513+ -}
514+evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do
488515 currentContext <- getStateContext
489516 let atomFuncs = atomFunctions currentContext
490517 case atomFunctionForName funcName atomFuncs of
491− Left err -> pure (Left err)
492− Right realFunc -> if isScriptedAtomFunction realFunc then do
493− let updatedFuncs = HS.delete realFunc atomFuncs
494− putStateContext (currentContext {atomFunctions = updatedFuncs })
495− pure (Right ())
496− else
497− pure (Left (PrecompiledFunctionRemoveError funcName))
518+ Left err -> dbErr err
519+ Right realFunc ->
520+ if isScriptedAtomFunction realFunc then do
521+ let updatedFuncs = HS.delete realFunc atomFuncs
522+ putStateContext (currentContext {atomFunctions = updatedFuncs })
523+ else
524+ dbErr (PrecompiledFunctionRemoveError funcName)
498525
499−evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) _ _ = do
526+evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
500527 context <- getStateContext
501528 let dbcFuncs = dbcFunctions context
502529 case databaseContextFunctionForName funcName dbcFuncs of
503− Left err -> pure (Left err)
504− Right realFunc -> if isScriptedDatabaseContextFunction realFunc then do
505− let updatedFuncs = HS.delete realFunc dbcFuncs
506− putStateContext (context { dbcFunctions = updatedFuncs })
507− pure (Right ())
508− else
509− pure (Left (PrecompiledFunctionRemoveError funcName))
530+ Left err -> dbErr err
531+ Right realFunc ->
532+ if isScriptedDatabaseContextFunction realFunc then do
533+ let updatedFuncs = HS.delete realFunc dbcFuncs
534+ putStateContext (context { dbcFunctions = updatedFuncs })
535+ else
536+ dbErr (PrecompiledFunctionRemoveError funcName)
510537
511−evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) transId graph = do
538+evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
512539 context <- getStateContext
540+ relExprEnv <- dbcRelationalExprEnv
513541 --resolve atom arguments
514− let relExprState = mkRelationalExprState context transId graph
515− eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs
542+ let eAtomTypes = map (\atomExpr -> runReader (typeForGraphRefAtomExpr emptyAttributes atomExpr) relExprEnv) atomArgExprs
516543 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
517544 case eFunc of
518− Left err -> pure (Left err)
545+ Left err -> dbErr err
519546 Right func -> do
520547 let expectedArgCount = length (dbcFuncType func)
521548 actualArgCount = length atomArgExprs
522549 if expectedArgCount /= actualArgCount then
523− pure (Left (FunctionArgumentCountMismatchError expectedArgCount actualArgCount))
550+ dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
524551 else
525552 --check that the atom types are valid
526553 case lefts eAtomTypes of
527− _:_ -> pure (Left (someErrors (lefts eAtomTypes)))
554+ _:_ -> dbErr (someErrors (lefts eAtomTypes))
528555 [] -> do
529556 let atomTypes = rights eAtomTypes
530557 let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of
@@ -534,20 +561,51 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) t
534561 eAtomArgs = unimplemented
535562 --eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
536563 if length (lefts eAtomArgs) > 1 then
537− pure (Left (someErrors (lefts eAtomArgs)))
564+ dbErr (someErrors (lefts eAtomArgs))
538565 else if not (null typeErrors) then
539− pure (Left (someErrors typeErrors))
566+ dbErr (someErrors typeErrors)
540567 else
541568 case evalDatabaseContextFunction func (rights eAtomArgs) context of
542− Left err -> pure (Left err)
543− Right newContext -> putStateContext newContext >> pure (Right ())
544−
545−evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> TransactionId -> TransactionGraph -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
546−evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddAtomFunction funcName funcType script) =
547− case mScriptSession of
548− Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
549− Just scriptSession -> do
550− res <- try $ runGhc (Just libdir) $ do
569+ Left err -> dbErr err
570+ Right newContext -> putStateContext newContext
571+
572+data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv
573+ { dbcio_transId :: TransactionId,
574+ dbcio_graph :: TransactionGraph,
575+ dbcio_mScriptSession :: Maybe ScriptSession
576+ }
577+
578+type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a
579+
580+requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)
581+requireScriptSession = do
582+ env <- RWS.ask
583+ case dbcio_mScriptSession env of
584+ Nothing -> pure $ Left $ ScriptError ScriptCompilationDisabledError
585+ Just ss -> pure (Right ss)
586+
587+putDBCIOContext :: DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ())
588+putDBCIOContext ctx = do
589+ RWS.modify (\dbstate -> dbstate { dbc_context = ctx})
590+ pure (Right ())
591+
592+getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
593+getDBCIOContext = dbc_context <$> RWS.get
594+
595+getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv
596+getDBCIORelationalExprEnv = do
597+ context <- getDBCIOContext
598+ env <- RWS.ask
599+ pure $ mkRelationalExprEnv context (dbcio_transId env) (dbcio_graph env)
600+
601+evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())
602+evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do
603+ eScriptSession <- requireScriptSession
604+ currentContext <- getDBCIOContext
605+ case eScriptSession of
606+ Left err -> pure (Left err)
607+ Right scriptSession -> do
608+ res <- liftIO $ try $ runGhc (Just libdir) $ do
551609 setSession (hscEnv scriptSession)
552610 let atomFuncs = atomFunctions currentContext
553611 case extractAtomFunctionType funcType of
@@ -573,12 +631,14 @@ evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddAtomFunction fun
573631 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
574632 Right eContext -> case eContext of
575633 Left err -> pure (Left err)
576− Right context' -> pure (Right context')
634+ Right context' -> putDBCIOContext context'
577635
578−evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddDatabaseContextFunction funcName funcType script) =
579− case mScriptSession of
580− Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
581− Just scriptSession -> do
636+evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do
637+ eScriptSession <- requireScriptSession
638+ currentContext <- getDBCIOContext
639+ case eScriptSession of
640+ Left err -> pure (Left err)
641+ Right scriptSession -> do
582642 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
583643 let last2Args = reverse (take 2 (reverse funcType))
584644 atomArgs = take (length funcType - 2) funcType
@@ -588,7 +648,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddDatabaseContextF
588648 if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
589649 pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
590650 else do
591− res <- try $ runGhc (Just libdir) $ do
651+ res <- liftIO $ try $ runGhc (Just libdir) $ do
592652 setSession (hscEnv scriptSession)
593653 eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
594654 pure $ case eCompiledFunc of
@@ -613,45 +673,55 @@ evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddDatabaseContextF
613673 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
614674 Right eContext -> case eContext of
615675 Left err -> pure (Left err)
616− Right context' -> pure (Right context')
617−evalDatabaseContextIOExpr _ currentContext _ _ (LoadAtomFunctions modName funcName modPath) = do
618− eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
676+ Right context' -> putDBCIOContext context'
677+
678+evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do
679+ currentContext <- getDBCIOContext
680+ eLoadFunc <- liftIO $ loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
619681 case eLoadFunc of
620682 Left LoadSymbolError -> pure (Left LoadFunctionError)
621683 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
622684 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
623− in pure (Right newContext)
624−evalDatabaseContextIOExpr _ currentContext _ _ (LoadDatabaseContextFunctions modName funcName modPath) = do
625− eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
685+ in putDBCIOContext newContext
686+evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName modPath) = do
687+ currentContext <- getDBCIOContext
688+ eLoadFunc <- liftIO $ loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
626689 case eLoadFunc of
627690 Left LoadSymbolError -> pure (Left LoadFunctionError)
628691 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
629692 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
630− in pure (Right newContext)
693+ in putDBCIOContext newContext
631694
632−evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelation relVarName attrExprs range) =
695+evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do
633696 --Define
634− case runState (evalDatabaseContextExpr (Define relVarName attrExprs) transId graph) (freshDatabaseState currentContext) of
635− (Left err,_) -> pure (Left err)
636− (Right (), elems) -> do
697+ currentContext <- getDBCIOContext
698+ env <- RWS.ask
699+ --create graph ref expr
700+ let gfExpr = Define relVarName attrExprs
701+ evalEnv = mkDatabaseContextEvalEnv (dbcio_transId env) (dbcio_graph env)
702+ transId = dbcio_transId env
703+ graph = dbcio_graph env
704+ case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of
705+ Left err -> pure (Left err)
706+ Right state -> do
637707 --Assign
638708 let existingRelVar = M.lookup relVarName relVarTable
639− relVarTable = relationVariables (context elems)
709+ relVarTable = relationVariables (dbc_context state)
640710 case existingRelVar of
641711 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
642712 Just existingRel -> do
643− case runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprState currentContext transId graph) of
713+ case runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprEnv currentContext transId graph) of
644714 Left err -> pure (Left err)
645715 Right relType -> do
646716 let expectedAttributes = attributes relType
647− tcMap = typeConstructorMapping (context elems)
648− eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
717+ tcMap = typeConstructorMapping (dbc_context state)
718+ eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
649719 case eitherRel of
650720 Left err -> pure $ Left err
651721 Right rel ->
652− case runState (setRelVar relVarName (ExistingRelation rel) transId graph) elems of
653− (Left err,_) -> pure (Left err)
654− (Right (), elems') -> pure $ Right (context elems)
722+ case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of
723+ Left err -> pure (Left err)
724+ Right state -> putDBCIOContext (dbc_context state)
655725
656726updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple
657727updateTupleWithAtomExprs exprMap context graph tupIn = do
@@ -675,14 +745,14 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
675745 tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas
676746
677747 deps = inclusionDependencies context
678− eval expr = evalReader (evalRelationalExpr expr)
679− evalReader f = runReader f (mkRelationalExprState context transId graph)
748+ reEnv = mkRelationalExprEnv context transId graph
749+ -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment
680750 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
681− let gfSubsetExpr = evalReader (processRelationalExpr subsetExpr)
682− gfSupersetExpr = evalReader (processRelationalExpr supersetExpr)
751+ let gfSubsetExpr = runReader (processRelationalExpr subsetExpr) reEnv
752+ gfSupersetExpr = runReader (processRelationalExpr supersetExpr) reEnv
683753 --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.
684− typeSub <- evalReader (typeForRelationalExpr subsetExpr)
685− typeSuper <- evalReader (typeForRelationalExpr supersetExpr)
754+ typeSub <- runReader (typeForRelationalExpr subsetExpr) reEnv
755+ typeSuper <- runReader (typeForRelationalExpr supersetExpr) reEnv
686756 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
687757 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
688758 case evalGraphRefRelationalExpr checkExpr potentialGraph of
@@ -805,7 +875,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName r
805875
806876extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
807877extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
808− rstate <- ask
878+ rstate <- askEnv
809879 -- check that the attribute name is not in use
810880 case tupleExprCheckNewAttrName newAttrName relIn of
811881 Left err -> pure (Left err)
@@ -871,9 +941,9 @@ evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExcept
871941 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
872942 pure (ConstructedAtom dConsName aType argAtoms)
873943-}
874−typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)
875−typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
876− rstate <- ask
944+typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> RelationalExprState (Either RelationalError AtomType)
945+typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do
946+ rstate <- askEnv
877947 case A.atomTypeForAttributeName attrName attrs of
878948 Right aType -> pure (Right aType)
879949 Left err@(NoSuchAttributeNamesError _) ->
@@ -885,9 +955,9 @@ typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
885955 Right atom -> pure (Right (atomTypeForAtom atom))
886956 Left _ -> pure (Left err)
887957
888−typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
889−typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
890− context <- fmap envContext ask
958+typeForGraphAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
959+typeForGraphAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
960+ context <- fmap envContext askEnv
891961 let funcs = atomFunctions context
892962 case atomFunctionForName funcName funcs of
893963 Left err -> pure (Left err)
@@ -904,7 +974,7 @@ typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
904974 Left err -> pure (Left err)
905975 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
906976typeFromAtomExpr attrs (RelationAtomExpr relExpr) = do
907− relType <- local (mergeAttributesIntoRelationalExprState attrs) (typeForRelationalExpr relExpr)
977+ relType <- R.local (mergeAttributesIntoRelationalExprState attrs) (typeForRelationalExpr relExpr)
908978 case relType of
909979 Left err -> pure (Left err)
910980 Right relType' ->
@@ -913,13 +983,13 @@ typeFromAtomExpr attrs (RelationAtomExpr relExpr) = do
913983typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
914984 runExceptT $ do
915985 argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs
916− context <- fmap envContext (lift ask)
986+ context <- fmap envContext (lift askEnv)
917987 either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
918988
919989-- | Validate that the type of the AtomExpr matches the expected type.
920990verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
921991verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
922− rstate <- lift ask
992+ rstate <- lift askEnv
923993 case A.atomTypeForAttributeName attrName (attributes relIn) of
924994 Right aType -> either throwE pure (atomTypeVerify expectedType aType)
925995 (Left err@(NoSuchAttributeNamesError _)) ->
@@ -932,7 +1002,7 @@ verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT
9321002 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
9331003verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
9341004verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
935− rstate <- ask
1005+ rstate <- askEnv
9361006 let functions = atomFunctions context
9371007 context = envContext rstate
9381008 runExceptT $ do
@@ -948,7 +1018,7 @@ verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedTyp
9481018 else
9491019 either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
9501020verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
951− rstate <- lift ask
1021+ rstate <- lift askEnv
9521022 relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
9531023 either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
9541024verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do
@@ -956,17 +1026,27 @@ verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ d
9561026 either throwE pure (atomTypeVerify expectedType cType)
9571027
9581028-- | Look up the type's name and create a new attribute.
959−evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute
960−evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do
961− aType <- atomTypeForTypeConstructorValidate True tCons aTypes M.empty
962− validateAtomType aType aTypes
963− Right (Attribute attrName aType)
1029+evalGraphRefAttrExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)
1030+evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do
1031+ graph <- re_graph <$> askEnv
1032+ case transactionForId transId graph of
1033+ Left err -> pure (Left err)
1034+ Right trans -> do
1035+ let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)
1036+ validate = do
1037+ aType <- atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
1038+ validateAtomType aType tConsMap
1039+ pure aType
1040+ case validate of
1041+ Left err -> pure (Left err)
1042+ Right aType ->
1043+ pure $ Right (Attribute attrName aType)
9641044
965−evalAttrExpr _ (NakedAttributeExpr attr) = Right attr
1045+evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure $ Right attr
9661046
9671047evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
9681048evalTupleExpr mAttrs (TupleExpr tupMap) = do
969− context <- fmap envContext ask
1049+ context <- fmap envContext askEnv
9701050 runExceptT $ do
9711051 -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority
9721052 -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed
@@ -1064,48 +1144,21 @@ transactionForId tid graph
10641144 where
10651145 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
10661146
1067−processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError GraphRefRestrictionPredicateExpr)
1068−processRestrictionPredicateExpr TruePredicate = pure (Right TruePredicate)
1069−processRestrictionPredicateExpr (AndPredicate a b) = do
1070− a' <- processRestrictionPredicateExpr a
1071− b' <- processRestrictionPredicateExpr b
1072− case a' of
1073− Left err -> pure (Left err)
1074− Right a'' -> case b' of
1075− Left err -> pure (Left err)
1076− Right b'' ->
1077− pure (Right (AndPredicate a'' b''))
1078−processRestrictionPredicateExpr (OrPredicate a b) = do
1079− a' <- processRestrictionPredicateExpr a
1080− b' <- processRestrictionPredicateExpr b
1081− case a' of
1082− Left err -> pure (Left err)
1083− Right a'' -> case b' of
1084− Left err -> pure (Left err)
1085− Right b'' ->
1086− pure (Right (OrPredicate a'' b''))
1087−processRestrictionPredicateExpr (NotPredicate a) = do
1088− a' <- processRestrictionPredicateExpr a
1089− case a' of
1090− Left err -> pure (Left err)
1091− Right a'' ->
1092− pure (Right (NotPredicate a''))
1093−processRestrictionPredicateExpr (RelationalExprPredicate expr) = do
1094− e <- evalRelationalExpr expr
1095− pure $ case e of
1096− Left err -> Left err
1097− Right e' -> Right (RelationalExprPredicate e')
1098−processRestrictionPredicateExpr (AtomExprPredicate expr) = do
1099− e <- processAtomExpr expr
1100− pure (Right (AtomExprPredicate e))
1101−processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = do
1102− e <- processAtomExpr expr
1103− pure (Right (AttributeEqualityPredicate nam e))
1104−
1105−processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError GraphRefExtendTupleExpr)
1106−processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do
1107− e <- processAtomExpr atomExpr
1108− pure (Right (AttributeExtendTupleExpr nam e))
1147+processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState GraphRefRestrictionPredicateExpr
1148+processRestrictionPredicateExpr TruePredicate = pure TruePredicate
1149+processRestrictionPredicateExpr (AndPredicate a b) = AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
1150+processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
1151+processRestrictionPredicateExpr (NotPredicate a) = NotPredicate <$> processRestrictionPredicateExpr a
1152+processRestrictionPredicateExpr (RelationalExprPredicate expr) =
1153+ RelationalExprPredicate <$> processRelationalExpr expr
1154+processRestrictionPredicateExpr (AtomExprPredicate expr) =
1155+ AtomExprPredicate <$> processAtomExpr expr
1156+processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) =
1157+ AttributeEqualityPredicate nam <$> processAtomExpr expr
1158+
1159+processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState GraphRefExtendTupleExpr
1160+processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =
1161+ AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr
11091162
11101163typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExprState (Either RelationalError Relation)
11111164typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = pure $ mkRelation attrs emptyTupleSet
@@ -1191,10 +1244,10 @@ processAtomExpr :: AtomExpr -> RelationalExprState GraphRefAtomExpr
11911244processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam
11921245processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
11931246processAtomExpr (FunctionAtomExpr fName atomExprs ()) = do
1194− tid <- re_currentTransId <$> ask
1247+ tid <- re_currentTransId <$> askEnv
11951248 FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> pure tid
11961249processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr
1197−processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> (re_currentTransId <$> ask)
1250+processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> (re_currentTransId <$> askEnv)
11981251
11991252processTupleExpr :: TupleExpr -> RelationalExprState GraphRefTupleExpr
12001253processTupleExpr (TupleExpr tMap) =
@@ -1202,7 +1255,7 @@ processTupleExpr (TupleExpr tMap) =
12021255
12031256evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)
12041257evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
1205− graph <- re_graph <$> ask
1258+ graph <- re_graph <$> askEnv
12061259 case transactionForId tid graph of
12071260 Left err -> pure (Left err)
12081261 Right trans -> do
@@ -1217,18 +1270,38 @@ evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
12171270--convert AttributeExpr to GraphRefAttributeExpr
12181271processAttributeExpr :: AttributeExpr -> RelationalExprState GraphRefAttributeExpr
12191272processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) = do
1220− tid <- re_currentTransId <$> ask
1273+ tid <- re_currentTransId <$> askEnv
12211274 pure $ AttributeAndTypeNameExpr nam tCons tid
12221275processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr
12231276
1224−-- convert a RelationalExpr into a GraphRefRelationalExpr
1277+-- convert a RelationalExpr into a GraphRefRelationalExpr using the current trans Id
1278+-- can this be done without any RelationalErrors as opposed to evalRelationalExpr?
12251279processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr
12261280processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do
12271281 mAttrs' <- case mAttrs of
12281282 Nothing -> pure Nothing
12291283 Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''
12301284 MakeRelationFromExprs mAttrs' <$> mapM processTupleExpr tupleExprs
1231−
1285+processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)
1286+processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)
1287+processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> fmap re_currentTransId askEnv
1288+processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr
1289+processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1290+processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1291+processRelationalExpr (Rename attrA attrB expr) =
1292+ Rename attrA attrB <$> processRelationalExpr expr
1293+processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1294+processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr
1295+processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr
1296+processRelationalExpr (Restrict pred expr) = Restrict <$> processRestrictionPredicateExpr pred <*> processRelationalExpr expr
1297+processRelationalExpr (Equals exprA exprB) =
1298+ Equals <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1299+processRelationalExpr (NotEquals exprA exprB) =
1300+ NotEquals <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1301+processRelationalExpr (Extend extendExpr expr) =
1302+ Extend <$> processExtendTupleExpr extendExpr <*> processRelationalExpr expr
1303+processRelationalExpr (With macros expr) =
1304+ With <$> mapM (\(nam, wexpr) -> (,) nam <$> processRelationalExpr wexpr) macros <*> processRelationalExpr expr
12321305
12331306mkEmptyRelVars :: RelationVariables -> RelationVariables
12341307mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap
@@ -1255,3 +1328,42 @@ processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet
12551328processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
12561329processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
12571330processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr
1331+
1332+processDatabaseContextExpr :: DatabaseContextExpr -> RelationalExprState GraphRefDatabaseContextExpr
1333+processDatabaseContextExpr expr =
1334+ case expr of
1335+ NoOperation -> pure NoOperation
1336+ Define nam attrExprs -> Define nam <$> mapM processAttributeExpr attrExprs
1337+ Undefine nam -> pure (Undefine nam)
1338+ Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr
1339+ Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr
1340+ Delete nam pred -> Delete nam <$> processRestrictionPredicateExpr pred
1341+ Update nam attrMap pred -> Update nam attrMap <$> processRestrictionPredicateExpr pred
1342+
1343+ AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)
1344+ RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)
1345+ AddNotification nam exprA exprB exprC -> pure (AddNotification nam exprA exprB exprC)
1346+ RemoveNotification nam -> pure (RemoveNotification nam)
1347+ AddTypeConstructor tyDef consDefs -> pure (AddTypeConstructor tyDef consDefs)
1348+ RemoveTypeConstructor tyName -> pure (RemoveTypeConstructor tyName)
1349+
1350+ RemoveAtomFunction aFuncName -> pure (RemoveAtomFunction aFuncName)
1351+ RemoveDatabaseContextFunction funcName -> pure (RemoveDatabaseContextFunction funcName)
1352+ ExecuteDatabaseContextFunction funcName atomExprs -> ExecuteDatabaseContextFunction funcName <$> mapM processAtomExpr atomExprs
1353+ MultipleExpr exprs -> MultipleExpr <$> mapM processDatabaseContextExpr exprs
1354+
1355+dbErr :: RelationalError -> DatabaseContextEvalMonad ()
1356+dbErr err = lift (except (Left err))
1357+
1358+processDatabaseContextIOExpr :: DatabaseContextIOExpr -> RelationalExprState GraphRefDatabaseContextIOExpr
1359+processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =
1360+ pure (AddAtomFunction f tcs sc)
1361+processDatabaseContextIOExpr (LoadAtomFunctions mod fun file) =
1362+ pure (LoadAtomFunctions mod fun file)
1363+processDatabaseContextIOExpr (AddDatabaseContextFunction mod fun path) =
1364+ pure (AddDatabaseContextFunction mod fun path)
1365+processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod fun path) =
1366+ pure (LoadDatabaseContextFunctions mod fun path)
1367+processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =
1368+ CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range
1369+