git.iko.soy/project-m36
on master help sign in
WIP more process* functions
1656f99AgentM
src/lib/ProjectM36/Base.hs+13−8
compare with master
unifiedsplit
@@ -316,7 +316,7 @@ type GraphRefDatabaseContextExpr = DatabaseContextExprBase TransactionId
316-- | Database context expressions modify the database context.
316-- | Database context expressions modify the database context.
317data DatabaseContextExprBase a =
317data DatabaseContextExprBase a =
318 NoOperation |
318 NoOperation |
319− Define RelVarName [AttributeExpr] |
319+ Define RelVarName [AttributeExprBase a] |
320 Undefine RelVarName | --forget existence of relvar X
320 Undefine RelVarName | --forget existence of relvar X
321 Assign RelVarName (RelationalExprBase a) |
321 Assign RelVarName (RelationalExprBase a) |
322 Insert RelVarName (RelationalExprBase a) |
322 Insert RelVarName (RelationalExprBase a) |
@@ -326,7 +326,7 @@ data DatabaseContextExprBase a =
326 AddInclusionDependency IncDepName InclusionDependency |
326 AddInclusionDependency IncDepName InclusionDependency |
327 RemoveInclusionDependency IncDepName |
327 RemoveInclusionDependency IncDepName |
328
328
329− AddNotification NotificationName (RelationalExprBase a) (RelationalExprBase a) (RelationalExprBase a) |
329+ AddNotification NotificationName RelationalExpr RelationalExpr RelationalExpr |
330 RemoveNotification NotificationName |
330 RemoveNotification NotificationName |
331
331
332 AddTypeConstructor TypeConstructorDef [DataConstructorDef] |
332 AddTypeConstructor TypeConstructorDef [DataConstructorDef] |
@@ -337,7 +337,7 @@ data DatabaseContextExprBase a =
337
337
338 RemoveDatabaseContextFunction DatabaseContextFunctionName |
338 RemoveDatabaseContextFunction DatabaseContextFunctionName |
339
339
340− ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExpr] |
340+ ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExprBase a] |
341
341
342 MultipleExpr [DatabaseContextExprBase a]
342 MultipleExpr [DatabaseContextExprBase a]
343 deriving (Show, Eq, Generic)
343 deriving (Show, Eq, Generic)
@@ -348,13 +348,18 @@ type ObjModuleName = StringType
348type ObjFunctionName = StringType
348type ObjFunctionName = StringType
349type Range = (Int,Int)
349type Range = (Int,Int)
350-- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.
350-- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.
351+data DatabaseContextIOExprBase a =
351−data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |
352+ AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |
352− LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |
353+ LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |
353− AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |
354+ AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |
354− LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |
355+ LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |
355− CreateArbitraryRelation RelVarName [AttributeExpr] Range
356+ CreateArbitraryRelation RelVarName [AttributeExprBase a] Range
356 deriving (Show, Eq, Generic, Binary)
357 deriving (Show, Eq, Generic, Binary)
357
358
359+type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase TransactionId
360+
361+type DatabaseContextIOExpr = DatabaseContextIOExprBase ()
362+
358type RestrictionPredicateExpr = RestrictionPredicateExprBase ()
363type RestrictionPredicateExpr = RestrictionPredicateExprBase ()
359
364
360type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionId
365type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionId
src/lib/ProjectM36/Client.hs+23−24
@@ -407,7 +407,7 @@ createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do
407 let sessions = ipSessions conf
407 let sessions = ipSessions conf
408 graphTvar = ipTransactionGraph conf
408 graphTvar = ipTransactionGraph conf
409 graph <- readTVar graphTvar
409 graph <- readTVar graphTvar
410− case transactionForId commitId graph of
410+ case RE.transactionForId commitId graph of
411 Left err -> pure (Left err)
411 Left err -> pure (Left err)
412 Right transaction -> do
412 Right transaction -> do
413 let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) NoOperation
413 let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) NoOperation
@@ -570,13 +570,14 @@ executeRelationalExpr sessionId (InProcessConnection conf) expr = excEither $ at
570 Right expr
570 Right expr
571 case expr' of
571 case expr' of
572 Left err -> pure (Left err)
572 Left err -> pure (Left err)
573− Right expr'' -> case optimizeRelationalExpr (Sess.concreteDatabaseContext session) expr'' of
573+ Right expr'' -> do
574− Left err -> pure (Left err)
574+ let graphTvar = ipTransactionGraph conf
575− Right optExpr -> do
575+ graph <- readTVar graphTvar
576− let evald = runReader (RE.evalRelationalExpr optExpr) (RE.mkRelationalExprState (Sess.concreteDatabaseContext session))
576+ let reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) (Sess.parentId session) graph
577− case evald of
577+ case optimizeAndEvalRelationalExpr reEnv expr'' of
578− Left err -> pure (Left err)
579− Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here
578+ Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here
579+ Left err -> pure (Left err)
580+
580executeRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)
581executeRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)
581
582
582-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.
583-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.
@@ -593,21 +594,19 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither
593 Schema.processDatabaseContextExprInSchema schema expr
594 Schema.processDatabaseContextExprInSchema schema expr
594 case expr' of
595 case expr' of
595 Left err -> pure (Left err)
596 Left err -> pure (Left err)
596− Right expr'' -> case runState (do
597+ Right expr'' ->
597− eOptExpr <- applyStaticDatabaseOptimization expr''
598+ case runDatabaseContextEvalMonad ctx env (optimizeAndEvalDatabaseContextExpr expr'') of
598− case eOptExpr of
599− Left err -> pure (Left err)
600− Right optExpr ->
601− RE.evalDatabaseContextExpr optExpr) (RE.freshDatabaseState (Sess.concreteDatabaseContext session)) of
602− (Left err,_) -> pure (Left err)
599+ Left err -> pure (Left err)
600+ Right newState ->
603− (Right (), (_,_,False)) -> pure (Right ()) --optimization- if nothing was dirtied, nothing to do
601+ if not dbc_dirty then --nothing dirtied, nothing to do
604− (Right (), (!context',_,True)) -> do
602+ pure (Right ())
603+ else do
605− let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation
604+ let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation
606− newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr
605+ newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr
607− newSchemas = Schemas context' newSubschemas
606+ newSchemas = Schemas context' newSubschemas
608− newSession = Session newDiscon (Sess.schemaName session)
607+ newSession = Session newDiscon (Sess.schemaName session)
609− StmMap.insert newSession sessionId sessions
608+ StmMap.insert newSession sessionId sessions
610− pure (Right ())
609+ pure (Right ())
611executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)
610executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)
612
611
613-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead.
612-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead.
@@ -680,7 +679,7 @@ executeCommitExprSTM_ oldContext newContext nodes = do
680 let nots = notifications oldContext
679 let nots = notifications oldContext
681 fireNots = notificationChanges nots oldContext newContext
680 fireNots = notificationChanges nots oldContext newContext
682 evaldNots = M.map mkEvaldNot fireNots
681 evaldNots = M.map mkEvaldNot fireNots
683− evalInContext expr ctx = runReader (RE.evalRelationalExpr expr) (RE.mkRelationalExprState ctx)
682+ evalInContext expr ctx = runReader (optimizeAndEvalRelationalExpr expr) (RE.mkRelationalExprEnv ctx)
684 mkEvaldNot notif = EvaluatedNotification { notification = notif,
683 mkEvaldNot notif = EvaluatedNotification { notification = notif,
685 reportOldRelation = evalInContext (reportOldExpr notif) oldContext,
684 reportOldRelation = evalInContext (reportOldExpr notif) oldContext,
686 reportNewRelation = evalInContext (reportNewExpr notif) newContext}
685 reportNewRelation = evalInContext (reportNewExpr notif) newContext}
src/lib/ProjectM36/DatabaseContextFunctionUtils.hs+6−4
@@ -7,9 +7,11 @@ import Control.Monad.State
7import Control.Monad.Trans.Reader
7import Control.Monad.Trans.Reader
8
8
9executeDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext
9executeDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext
10−executeDatabaseContextExpr expr tid graph context = case runState (evalDatabaseContextExpr expr tid graph) (freshDatabaseState context) of
10+executeDatabaseContextExpr expr tid graph context' = case runState (evalDatabaseContextExpr expr tid graph) (freshDatabaseState context') of
11− (Right (), st) -> pure (context t)
11+ (Right (), st) -> pure (context st)
12 (Left err, _) -> error (show err)
12 (Left err, _) -> error (show err)
13
13
14−executeRelationalExpr :: RelationalExpr -> DatabaseContext -> Either RelationalError Relation
14+executeRelationalExpr :: RelationalExpr -> DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError Relation
15+executeRelationalExpr expr context tid graph = do
15−executeRelationalExpr expr context = runReader (evalRelationalExpr expr) (mkRelationalExprState context)
16+ gfExpr <- runReader (evalRelationalExpr expr) (mkRelationalExprState context tid graph)
17+ evalGraphRefRelationalExpr gfExpr graph
src/lib/ProjectM36/Notifications.hs+12−6
@@ -1,17 +1,23 @@
1module ProjectM36.Notifications where
1module ProjectM36.Notifications where
2import ProjectM36.Base
2import ProjectM36.Base
3+import ProjectM36.Error
3import ProjectM36.RelationalExpression
4import ProjectM36.RelationalExpression
5+import ProjectM36.StaticOptimizer
4import Control.Monad.Trans.Reader
6import Control.Monad.Trans.Reader
5import qualified Data.Map as M
7import qualified Data.Map as M
6import Data.Either (isRight)
8import Data.Either (isRight)
7
9
8-- | Returns the notifications which should be triggered based on the transition from the first 'DatabaseContext' to the second 'DatabaseContext'.
10-- | Returns the notifications which should be triggered based on the transition from the first 'DatabaseContext' to the second 'DatabaseContext'.
9−notificationChanges :: Notifications -> DatabaseContext -> DatabaseContext -> Notifications
11+notificationChanges :: Notifications -> TransactionId -> TransactionGraph -> DatabaseContext -> DatabaseContext -> Notifications
10−notificationChanges nots context1 context2 = M.filter notificationFilter nots
12+notificationChanges nots tid graph context1 context2 = M.filter notificationFilter nots
11 where
13 where
12− notificationFilter (Notification chExpr _ _) = let oldChangeEval = evalChangeExpr chExpr (RelationalExprStateElems context1)
13− newChangeEval = evalChangeExpr chExpr (RelationalExprStateElems context2) in
14− oldChangeEval /= newChangeEval && isRight oldChangeEval
14+ notificationFilter (Notification chExpr _ _) = oldChangeEval /= newChangeEval && isRight oldChangeEval
15− evalChangeExpr chExpr = runReader (evalRelationalExpr chExpr)
15+ where
16+ oldChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context1 tid graph)
17+ newChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context2 tid graph)
18+
19+ evalChangeExpr :: RelationalExpr -> RelationalExprEnv -> Either RelationalError Relation
20+ evalChangeExpr chExpr env =
21+ optimizeAndEvalRelationalExpr env chExpr
16
22
17
23
src/lib/ProjectM36/RelationalExpression.hs+364−252
@@ -18,7 +18,9 @@ import qualified ProjectM36.Attribute as A
18import qualified Data.Map as M
18import qualified Data.Map as M
19import qualified Data.HashSet as HS
19import qualified Data.HashSet as HS
20import qualified Data.Set as S
20import 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)
22import Control.Exception
24import Control.Exception
23import Data.Maybe
25import Data.Maybe
24import Data.Either
26import Data.Either
@@ -27,13 +29,16 @@ import qualified Data.Text as T
27import qualified Data.Vector as V
29import qualified Data.Vector as V
28import qualified ProjectM36.TypeConstructorDef as TCD
30import qualified ProjectM36.TypeConstructorDef as TCD
29import Control.Monad.Trans.Except
31import Control.Monad.Trans.Except
30−import Control.Monad.Trans.Reader
32+import Control.Monad.Trans.Reader as R
31import Test.QuickCheck
33import Test.QuickCheck
32import GHC
34import GHC
33import GHC.Paths
35import GHC.Paths
34import Data.Time.Clock
36import Data.Time.Clock
35import Data.Time.Calendar
37import Data.Time.Calendar
36import qualified Data.List.NonEmpty as NE
38import qualified Data.List.NonEmpty as NE
39+import Data.Functor.Identity
40+import Control.Monad
41+import Control.Monad.IO.Class
37
42
38data DatabaseContextExprDetails = CountUpdatedTuples
43data DatabaseContextExprDetails = CountUpdatedTuples
39
44
@@ -50,11 +55,11 @@ databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTu
50 Right ts -> ts
55 Right ts -> ts
51
56
52-- | Used to start a fresh database state for a new database context expression.
57-- | Used to start a fresh database state for a new database context expression.
53−freshDatabaseState :: DatabaseContext -> DatabaseStateElems
58+mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
54−freshDatabaseState context = DatabaseStateElems {
59+mkDatabaseContextEvalState context = DatabaseContextEvalState {
55− context = context,
60+ dbc_context = context,
56− accum = M.empty,
61+ dbc_accum = M.empty,
57− dirty = False
62+ dbc_dirty = False
58 } --future work: propagate return accumulator
63 } --future work: propagate return accumulator
59
64
60-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
65-- 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))
70
75
71stateAttributes :: RelationalExprEnv -> Attributes
76stateAttributes :: RelationalExprEnv -> Attributes
72stateAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (re_extra e))
77stateAttributes 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− -}
78
78
79instance Show RelationalExprEnv where
79instance Show RelationalExprEnv where
80 show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)
80 show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)
81
81
82−mkRelationalExprState :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprEnv
82+mkRelationalExprEnv :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprEnv
83−mkRelationalExprState ctx currentTransId graph =
83+mkRelationalExprEnv ctx currentTransId graph =
84 RelationalExprEnv
84 RelationalExprEnv
85 { re_context = ctx,
85 { re_context = ctx,
86 re_graph = graph,
86 re_graph = graph,
87 re_currentTransId = currentTransId,
87 re_currentTransId = currentTransId,
88 re_extra = Nothing }
88 re_extra = Nothing }
89
89
90+askEnv :: RelationalExprState RelationalExprEnv
91+askEnv = R.ask
92+
90currentTrans :: RelationalExprState (Either RelationalError Transaction)
93currentTrans :: RelationalExprState (Either RelationalError Transaction)
91currentTrans = do
94currentTrans = do
92− tid <- re_currentTransId <$> ask
95+ tid <- re_currentTransId <$> R.ask
93− graph <- re_graph <$> ask
96+ graph <- re_graph <$> R.ask
94 pure (transactionForId tid graph)
97 pure (transactionForId tid graph)
95
98
96mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprEnv -> RelationalExprEnv
99mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprEnv -> RelationalExprEnv
@@ -114,21 +117,47 @@ data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,
114 resultAccumResult :: Relation
117 resultAccumResult :: Relation
115 }
118 }
116
119
117−data DatabaseStateElems = DatabaseStateElems {
120+data DatabaseContextEvalState = DatabaseContextEvalState {
118− context :: DatabaseContext, --new, alterable context for a new transaction
121+ dbc_context :: DatabaseContext, --new, alterable context for a new transaction
119− accum :: M.Map ResultAccumName ResultAccum,
122+ dbc_accum :: M.Map ResultAccumName ResultAccum,
120− dirty :: DirtyFlag
123+ dbc_dirty :: DirtyFlag
124+ }
125+
126+data DatabaseContextEvalEnv = DatabaseContextEvalEnv
127+ { dce_transId :: TransactionId,
128+ dce_graph :: TransactionGraph
121 }
129 }
122
130
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
124
147
125−getStateContext :: DatabaseState DatabaseContext
148+dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
126−getStateContext = context <$> get
149+dbcRelationalExprEnv = do
150+ tid <- dbcTransId
151+ graph <- dbcGraph
152+ mkRelationalExprEnv <$> getStateContext <*> dbcTransId <*> dbcGraph
127
153
154+getStateContext :: DatabaseContextEvalMonad DatabaseContext
155+getStateContext = dbc_context <$> get
156+
128−putStateContext :: DatabaseContext -> DatabaseState ()
157+putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()
129putStateContext ctx' = do
158putStateContext ctx' = do
130 s <- get
159 s <- get
131− put (s {context = ctx'})
160+ put (s {dbc_context = ctx'})
132
161
133type RelationalExprState a = Reader RelationalExprEnv a
162type RelationalExprState a = Reader RelationalExprEnv a
134
163
@@ -138,10 +167,21 @@ envContext = re_context
138setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv
167setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv
139setEnvContext e ctx = e { re_context = ctx }
168setEnvContext e ctx = e { re_context = ctx }
140
169
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+{-
141--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
181--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
142evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)
182evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)
143evalRelationalExpr (RelationVariable name _) = do
183evalRelationalExpr (RelationVariable name _) = do
144− relvarTable <- fmap (relationVariables . envContext) ask
184+ relvarTable <- fmap (relationVariables . envContext) askEnv
145 return $ case M.lookup name relvarTable of
185 return $ case M.lookup name relvarTable of
146 Just res -> Right res
186 Just res -> Right res
147 Nothing -> Left $ RelVarNotDefinedError name
187 Nothing -> Left $ RelVarNotDefinedError name
@@ -189,13 +229,13 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
189 Left err -> return $ Left err
229 Left err -> return $ Left err
190
230
191evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
231evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
192− currentContext <- fmap envContext ask
232+ currentContext <- fmap envContext askEnv
193 let tConss = typeConstructorMapping currentContext
233 let tConss = typeConstructorMapping currentContext
194 -- 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
234 -- 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
195 runExceptT $ do
235 runExceptT $ do
196 mAttrs <- case mAttrExprs of
236 mAttrs <- case mAttrExprs of
197 Just _ ->
237 Just _ ->
198− Just . A.attributesFromList <$> mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)
238+ Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)
199 Nothing -> pure Nothing
239 Nothing -> pure Nothing
200 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
240 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
201 let attrs = fromMaybe firstTupleAttrs mAttrs
241 let attrs = fromMaybe firstTupleAttrs mAttrs
@@ -229,12 +269,11 @@ evalRelationalExpr (Ungroup attrName relExpr) = do
229
269
230evalRelationalExpr (Restrict predicateExpr relExpr) = do
270evalRelationalExpr (Restrict predicateExpr relExpr) = do
231 evald <- evalRelationalExpr relExpr
271 evald <- evalRelationalExpr relExpr
232− ePred <- processRestrictionPredicateExpr predicateExpr
272+ pred <- processRestrictionPredicateExpr predicateExpr
233 case evald of
273 case evald of
234 Left err -> return $ Left err
274 Left err -> return $ Left err
235− Right expr -> case ePred of
275+ Right expr ->
236− Left err -> pure (Left err)
237− Right pred -> pure $ Right (Restrict pred expr)
276+ pure $ Right (Restrict pred expr)
238
277
239evalRelationalExpr (Equals relExprA relExprB) = do
278evalRelationalExpr (Equals relExprA relExprB) = do
240 evaldA <- evalRelationalExpr relExprA
279 evaldA <- evalRelationalExpr relExprA
@@ -279,252 +318,240 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do
279 case eExpr of
318 case eExpr of
280 Left err -> pure (Left err)
319 Left err -> pure (Left err)
281 Right expr -> do
320 Right expr -> do
282− eTupProc <- processExtendTupleExpr tupleExpression
321+ tupProc <- processExtendTupleExpr tupleExpression
283− case eTupProc of
284− Left err -> pure (Left err)
285− Right tupProc -> pure (Right (Extend tupProc expr))
322+ pure (Right (Extend tupProc expr))
286−
323+-}
287--helper function to process relation variable creation/assignment
324--helper function to process relation variable creation/assignment
288−setRelVar :: RelVarName -> GraphRefRelationalExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())
325+setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
289−setRelVar relVarName relExpr transId graph = do
326+setRelVar relVarName relExpr = do
327+
290 currentContext <- getStateContext
328 currentContext <- getStateContext
291 let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext
329 let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext
292 potentialContext = currentContext { relationVariables = newRelVars }
330 potentialContext = currentContext { relationVariables = newRelVars }
293 --determine when to check constraints
331 --determine when to check constraints
294−
332+ graph <- dbcGraph
333+ tid <- dbcTransId
295− case checkConstraints potentialContext transId graph of
334+ case checkConstraints potentialContext tid graph of
296− Left err -> pure (Left err)
335+ Left err -> dbErr err
297− Right _ -> do
298− putStateContext potentialContext
336+ Right _ -> putStateContext potentialContext
299− return (Right ())
300
337
301-- 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
338-- 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 ()
303deleteRelVar relVarName = do
340deleteRelVar relVarName = do
304 currContext <- getStateContext
341 currContext <- getStateContext
305 let relVars = relationVariables currContext
342 let relVars = relationVariables currContext
306 if M.notMember relVarName relVars then
343 if M.notMember relVarName relVars then
307− pure (Right ())
344+ pure ()
308 else do
345 else do
309 let newRelVars = M.delete relVarName relVars
346 let newRelVars = M.delete relVarName relVars
310 newContext = currContext { relationVariables = newRelVars }
347 newContext = currContext { relationVariables = newRelVars }
311 putStateContext newContext
348 putStateContext newContext
312− pure (Right ())
349+ pure ()
313
350
314−evalDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())
351+evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
315−evalDatabaseContextExpr NoOperation _ _ = pure (Right ())
352+evalGraphRefDatabaseContextExpr NoOperation = pure ()
316
353
317−evalDatabaseContextExpr (Define relVarName attrExprs) transId graph = do
354+evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do
318 relvars <- fmap relationVariables getStateContext
355 relvars <- fmap relationVariables getStateContext
319 tConss <- fmap typeConstructorMapping getStateContext
356 tConss <- fmap typeConstructorMapping getStateContext
320− let eAttrs = map (evalAttrExpr tConss) attrExprs
357+ relEnv <- dbcRelationalExprEnv
358+ let eAttrs = runReader (mapM evalGraphRefAttrExpr attrExprs) relEnv
321 attrErrs = lefts eAttrs
359 attrErrs = lefts eAttrs
322 attrsList = rights eAttrs
360 attrsList = rights eAttrs
323 if not (null attrErrs) then
361 if not (null attrErrs) then
324− pure (Left (someErrors attrErrs))
362+ dbErr (someErrors attrErrs)
325 else do
363 else do
326 let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList
364 let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList
327 if not (null atomTypeErrs) then
365 if not (null atomTypeErrs) then
328− pure (Left (someErrors atomTypeErrs))
366+ dbErr (someErrors atomTypeErrs)
329 else
367 else
330 case M.member relVarName relvars of
368 case M.member relVarName relvars of
331− True -> pure (Left (RelVarAlreadyDefinedError relVarName))
369+ True -> dbErr (RelVarAlreadyDefinedError relVarName)
332− False -> setRelVar relVarName (ExistingRelation emptyRelation) transId graph >> pure (Right ())
370+ False -> setRelVar relVarName (ExistingRelation emptyRelation)
333 where
371 where
334 attrs = A.attributesFromList attrsList
372 attrs = A.attributesFromList attrsList
335 emptyRelation = Relation attrs emptyTupleSet
373 emptyRelation = Relation attrs emptyTupleSet
336
374
337−evalDatabaseContextExpr (Undefine relVarName) _ _ = deleteRelVar relVarName
375+evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
338
376
339−evalDatabaseContextExpr (Assign relVarName expr) transId graph = do
377+evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do
378+ relExprEnv <- dbcRelationalExprEnv
340 context <- getStateContext
379 context <- getStateContext
341 let existingRelVar = M.lookup relVarName (relationVariables context)
380 let existingRelVar = M.lookup relVarName (relationVariables context)
342− relExprState = mkRelationalExprState context transId graph
343 case existingRelVar of
381 case existingRelVar of
344 Nothing -> do
382 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
349 Just existingRel -> do
384 Just existingRel -> do
350− let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprState context transId graph)
385+ let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) relExprEnv
351− eNewExprType = runReader (typeForRelationalExpr expr) relExprState
386+ eNewExprType = runReader (typeForGraphRefRelationalExpr expr) relExprEnv
352 case eExpectedType of
387 case eExpectedType of
353− Left err -> pure (Left err)
388+ Left err -> dbErr err
354 Right expectedType ->
389 Right expectedType ->
355 case eNewExprType of
390 case eNewExprType of
356− Left err -> pure (Left err)
391+ Left err -> dbErr err
357 Right newExprType -> do
392 Right newExprType -> do
358 if newExprType == expectedType then do
393 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
363 else
395 else
364− pure (Left (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)))
396+ dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))
365
397
366−evalDatabaseContextExpr (Insert relVarName relExpr) tid graph =
398+evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do
399+ transId <- dbcTransId
400+ evalGraphRefDatabaseContextExpr (Assign relVarName
401+ (Union
367− evalDatabaseContextExpr (Assign relVarName (Union (RelationVariable relVarName ())
402+ (RelationVariable relVarName transId)
368− relExpr)) tid graph
403+ relExpr))
369
404
370−evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do
405+evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do
371− ctx <- getStateContext
406+ transId <- dbcTransId
372 let rv = RelationVariable relVarName transId
407 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)
378
409
379--union of restricted+updated portion and the unrestricted+unupdated portion
410--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
381 context <- getStateContext
412 context <- getStateContext
382− let rvState = mkRelationalExprState context transId graph
413+ transId <- dbcTransId
414+ reEnv <- dbcRelationalExprEnv
383− relVarTable = relationVariables context
415+ let relVarMap = 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
416+ case M.lookup relVarName relVarMap of
388− Nothing -> pure (Left (RelVarNotDefinedError relVarName))
417+ Nothing -> dbErr (RelVarNotDefinedError relVarName)
389 Just existingRvExpr -> do
418 Just existingRvExpr -> do
390− let unrestrictedPortion = Restrict (NotPredicate graphRefPredicate) rv
419+ let unrestrictedPortion = Restrict (NotPredicate pred) rv
391 rv = RelationVariable relVarName transId
420 rv = RelationVariable relVarName transId
392 tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict
421 tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict
393 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)
422 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)
394 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
423 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
395− restrictedPortion = Restrict graphRefPredicate
424+ restrictedPortion = Restrict pred
396 updated = foldr (\(oldname, atomExpr) accum ->
425 updated = foldr (\(oldname, atomExpr) accum ->
397− let procAtomExpr = runReader (processAtomExpr atomExpr) rvState in
426+ let procAtomExpr = runReader (processAtomExpr atomExpr) reEnv in
398 updateAttr oldname procAtomExpr accum
427 updateAttr oldname procAtomExpr accum
399 ) rv (M.toList atomExprMap)
428 ) rv (M.toList atomExprMap)
400 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
429 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
401 updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)
430 updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)
402− setRelVar relVarName (Union unrestrictedPortion updatedPortion) transId graph
431+ setRelVar relVarName (Union unrestrictedPortion updatedPortion)
403
432
404−evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) transId graph = do
433+evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
405 currContext <- getStateContext
434 currContext <- getStateContext
435+ transId <- dbcTransId
436+ graph <- dbcGraph
406 let currDeps = inclusionDependencies currContext
437 let currDeps = inclusionDependencies currContext
407 newDeps = M.insert newDepName newDep currDeps
438 newDeps = M.insert newDepName newDep currDeps
408 if M.member newDepName currDeps then
439 if M.member newDepName currDeps then
409− pure (Left (InclusionDependencyNameInUseError newDepName))
440+ dbErr (InclusionDependencyNameInUseError newDepName)
410 else do
441 else do
411 let potentialContext = currContext { inclusionDependencies = newDeps }
442 let potentialContext = currContext { inclusionDependencies = newDeps }
412 case checkConstraints potentialContext transId graph of
443 case checkConstraints potentialContext transId graph of
413− Left err -> pure (Left err)
444+ Left err -> dbErr err
414− Right _ -> do
445+ Right _ ->
415 putStateContext potentialContext
446 putStateContext potentialContext
416− return (Right ())
417
447
418−evalDatabaseContextExpr (RemoveInclusionDependency depName) _ _ = do
448+evalGraphRefDatabaseContextExpr (RemoveInclusionDependency depName) = do
419 currContext <- getStateContext
449 currContext <- getStateContext
420 let currDeps = inclusionDependencies currContext
450 let currDeps = inclusionDependencies currContext
421 newDeps = M.delete depName currDeps
451 newDeps = M.delete depName currDeps
422 if M.notMember depName currDeps then
452 if M.notMember depName currDeps then
423− pure (Left (InclusionDependencyNameNotInUseError depName))
453+ dbErr (InclusionDependencyNameNotInUseError depName)
424− else do
454+ else
425 putStateContext $ currContext {inclusionDependencies = newDeps }
455 putStateContext $ currContext {inclusionDependencies = newDeps }
426− return (Right ())
427
456
428-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
457-- | 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
430 currentContext <- getStateContext
459 currentContext <- getStateContext
431 let nots = notifications currentContext
460 let nots = notifications currentContext
432 if M.member notName nots then
461 if M.member notName nots then
433− pure (Left (NotificationNameInUseError notName))
462+ dbErr (NotificationNameInUseError notName)
434 else do
463 else do
435 let newNotifications = M.insert notName newNotification nots
464 let newNotifications = M.insert notName newNotification nots
436 newNotification = Notification { changeExpr = triggerExpr,
465 newNotification = Notification { changeExpr = triggerExpr,
437 reportOldExpr = resultOldExpr,
466 reportOldExpr = resultOldExpr,
438 reportNewExpr = resultNewExpr}
467 reportNewExpr = resultNewExpr}
439 putStateContext $ currentContext { notifications = newNotifications }
468 putStateContext $ currentContext { notifications = newNotifications }
440− return (Right ())
441
469
442−evalDatabaseContextExpr (RemoveNotification notName) _ _ = do
470+evalGraphRefDatabaseContextExpr (RemoveNotification notName) = do
443 currentContext <- getStateContext
471 currentContext <- getStateContext
444 let nots = notifications currentContext
472 let nots = notifications currentContext
445 if M.notMember notName nots then
473 if M.notMember notName nots then
446− pure (Left (NotificationNameNotInUseError notName))
474+ dbErr (NotificationNameNotInUseError notName)
447 else do
475 else do
448 let newNotifications = M.delete notName nots
476 let newNotifications = M.delete notName nots
449 putStateContext $ currentContext { notifications = newNotifications }
477 putStateContext $ currentContext { notifications = newNotifications }
450− pure (Right ())
478+
451
479
452-- | Adds type and data constructors to the database context.
480-- | Adds type and data constructors to the database context.
453-- validate that the type *and* constructor names are unique! not yet implemented!
481-- validate that the type *and* constructor names are unique! not yet implemented!
454−evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) _ _ = do
482+evalGraphRefDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
455 currentContext <- getStateContext
483 currentContext <- getStateContext
456 let oldTypes = typeConstructorMapping currentContext
484 let oldTypes = typeConstructorMapping currentContext
457 tConsName = TCD.name tConsDef
485 tConsName = TCD.name tConsDef
458 -- validate that the constructor's types exist
486 -- validate that the constructor's types exist
459 case validateTypeConstructorDef tConsDef dConsDefList of
487 case validateTypeConstructorDef tConsDef dConsDefList of
460− errs@(_:_) -> pure (Left (someErrors errs))
488+ errs@(_:_) -> dbErr (someErrors errs)
461− [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName))
489+ [] | T.null tConsName || not (isUpper (T.head tConsName)) -> dbErr (InvalidAtomTypeName tConsName)
462− | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName))
490+ | isJust (findTypeConstructor tConsName oldTypes) -> dbErr (AtomTypeNameInUseError tConsName)
463 | otherwise -> do
491 | otherwise -> do
464 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
492 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
465 putStateContext $ currentContext { typeConstructorMapping = newTypes }
493 putStateContext $ currentContext { typeConstructorMapping = newTypes }
466− pure (Right ())
467
494
468-- | 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.
495-- | 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
470 currentContext <- getStateContext
497 currentContext <- getStateContext
471 let oldTypes = typeConstructorMapping currentContext
498 let oldTypes = typeConstructorMapping currentContext
472 if isNothing (findTypeConstructor tConsName oldTypes) then
499 if isNothing (findTypeConstructor tConsName oldTypes) then
473− pure (Left (AtomTypeNameNotInUseError tConsName))
500+ dbErr (AtomTypeNameNotInUseError tConsName)
474 else do
501 else do
475 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
502 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
476 putStateContext $ currentContext { typeConstructorMapping = newTypes }
503 putStateContext $ currentContext { typeConstructorMapping = newTypes }
477− pure (Right ())
478
504
479−evalDatabaseContextExpr (MultipleExpr exprs) transId graph = do
505+evalGraphRefDatabaseContextExpr (MultipleExpr exprs) = do
480 --the multiple expressions must pass the same context around- not the old unmodified context
506 --the multiple expressions must pass the same context around- not the old unmodified context
507+ unimplemented
481− evald <- forM exprs (\expr -> evalDatabaseContextExpr expr transId graph)
508+{- evald <- forM exprs (\expr -> evalGraphRefDatabaseContextExpr expr)
482 --some lifting magic needed here
509 --some lifting magic needed here
483 case lefts evald of
510 case lefts evald of
484− [] -> pure (Right ())
511+ [] -> pure ()
485− errs -> pure (Left (someErrors errs))
512+ errs -> dbErr (someErrors errs)
486−
513+ -}
487−evalDatabaseContextExpr (RemoveAtomFunction funcName) _ _ = do
514+evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do
488 currentContext <- getStateContext
515 currentContext <- getStateContext
489 let atomFuncs = atomFunctions currentContext
516 let atomFuncs = atomFunctions currentContext
490 case atomFunctionForName funcName atomFuncs of
517 case atomFunctionForName funcName atomFuncs of
491− Left err -> pure (Left err)
518+ Left err -> dbErr err
519+ Right realFunc ->
492− Right realFunc -> if isScriptedAtomFunction realFunc then do
520+ if isScriptedAtomFunction realFunc then do
493− let updatedFuncs = HS.delete realFunc atomFuncs
521+ let updatedFuncs = HS.delete realFunc atomFuncs
494− putStateContext (currentContext {atomFunctions = updatedFuncs })
522+ putStateContext (currentContext {atomFunctions = updatedFuncs })
495− pure (Right ())
496− else
523+ else
497− pure (Left (PrecompiledFunctionRemoveError funcName))
524+ dbErr (PrecompiledFunctionRemoveError funcName)
498
525
499−evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) _ _ = do
526+evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
500 context <- getStateContext
527 context <- getStateContext
501 let dbcFuncs = dbcFunctions context
528 let dbcFuncs = dbcFunctions context
502 case databaseContextFunctionForName funcName dbcFuncs of
529 case databaseContextFunctionForName funcName dbcFuncs of
503− Left err -> pure (Left err)
530+ Left err -> dbErr err
531+ Right realFunc ->
504− Right realFunc -> if isScriptedDatabaseContextFunction realFunc then do
532+ if isScriptedDatabaseContextFunction realFunc then do
505− let updatedFuncs = HS.delete realFunc dbcFuncs
533+ let updatedFuncs = HS.delete realFunc dbcFuncs
506− putStateContext (context { dbcFunctions = updatedFuncs })
534+ putStateContext (context { dbcFunctions = updatedFuncs })
507− pure (Right ())
508− else
535+ else
509− pure (Left (PrecompiledFunctionRemoveError funcName))
536+ dbErr (PrecompiledFunctionRemoveError funcName)
510
537
511−evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) transId graph = do
538+evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
512 context <- getStateContext
539 context <- getStateContext
540+ relExprEnv <- dbcRelationalExprEnv
513 --resolve atom arguments
541 --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
516 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
543 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
517 case eFunc of
544 case eFunc of
518− Left err -> pure (Left err)
545+ Left err -> dbErr err
519 Right func -> do
546 Right func -> do
520 let expectedArgCount = length (dbcFuncType func)
547 let expectedArgCount = length (dbcFuncType func)
521 actualArgCount = length atomArgExprs
548 actualArgCount = length atomArgExprs
522 if expectedArgCount /= actualArgCount then
549 if expectedArgCount /= actualArgCount then
523− pure (Left (FunctionArgumentCountMismatchError expectedArgCount actualArgCount))
550+ dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
524 else
551 else
525 --check that the atom types are valid
552 --check that the atom types are valid
526 case lefts eAtomTypes of
553 case lefts eAtomTypes of
527− _:_ -> pure (Left (someErrors (lefts eAtomTypes)))
554+ _:_ -> dbErr (someErrors (lefts eAtomTypes))
528 [] -> do
555 [] -> do
529 let atomTypes = rights eAtomTypes
556 let atomTypes = rights eAtomTypes
530 let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of
557 let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of
@@ -534,20 +561,51 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) t
534 eAtomArgs = unimplemented
561 eAtomArgs = unimplemented
535 --eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
562 --eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
536 if length (lefts eAtomArgs) > 1 then
563 if length (lefts eAtomArgs) > 1 then
537− pure (Left (someErrors (lefts eAtomArgs)))
564+ dbErr (someErrors (lefts eAtomArgs))
538 else if not (null typeErrors) then
565 else if not (null typeErrors) then
539− pure (Left (someErrors typeErrors))
566+ dbErr (someErrors typeErrors)
540 else
567 else
541 case evalDatabaseContextFunction func (rights eAtomArgs) context of
568 case evalDatabaseContextFunction func (rights eAtomArgs) context of
542− Left err -> pure (Left err)
569+ Left err -> dbErr err
543− Right newContext -> putStateContext newContext >> pure (Right ())
570+ Right newContext -> putStateContext newContext
544−
571+
545−evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> TransactionId -> TransactionGraph -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
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 ())
546−evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddAtomFunction funcName funcType script) =
602+evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do
547− case mScriptSession of
603+ eScriptSession <- requireScriptSession
548− Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
604+ currentContext <- getDBCIOContext
605+ case eScriptSession of
606+ Left err -> pure (Left err)
549− Just scriptSession -> do
607+ Right scriptSession -> do
550− res <- try $ runGhc (Just libdir) $ do
608+ res <- liftIO $ try $ runGhc (Just libdir) $ do
551 setSession (hscEnv scriptSession)
609 setSession (hscEnv scriptSession)
552 let atomFuncs = atomFunctions currentContext
610 let atomFuncs = atomFunctions currentContext
553 case extractAtomFunctionType funcType of
611 case extractAtomFunctionType funcType of
@@ -573,12 +631,14 @@ evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddAtomFunction fun
573 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
631 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
574 Right eContext -> case eContext of
632 Right eContext -> case eContext of
575 Left err -> pure (Left err)
633 Left err -> pure (Left err)
576− Right context' -> pure (Right context')
634+ Right context' -> putDBCIOContext context'
577
635
578−evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddDatabaseContextFunction funcName funcType script) =
636+evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do
579− case mScriptSession of
637+ eScriptSession <- requireScriptSession
580− Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
638+ currentContext <- getDBCIOContext
639+ case eScriptSession of
640+ Left err -> pure (Left err)
581− Just scriptSession -> do
641+ Right scriptSession -> do
582 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
642 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
583 let last2Args = reverse (take 2 (reverse funcType))
643 let last2Args = reverse (take 2 (reverse funcType))
584 atomArgs = take (length funcType - 2) funcType
644 atomArgs = take (length funcType - 2) funcType
@@ -588,7 +648,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddDatabaseContextF
588 if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
648 if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
589 pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
649 pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
590 else do
650 else do
591− res <- try $ runGhc (Just libdir) $ do
651+ res <- liftIO $ try $ runGhc (Just libdir) $ do
592 setSession (hscEnv scriptSession)
652 setSession (hscEnv scriptSession)
593 eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
653 eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
594 pure $ case eCompiledFunc of
654 pure $ case eCompiledFunc of
@@ -613,45 +673,55 @@ evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddDatabaseContextF
613 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
673 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
614 Right eContext -> case eContext of
674 Right eContext -> case eContext of
615 Left err -> pure (Left err)
675 Left err -> pure (Left err)
616− Right context' -> pure (Right context')
676+ Right context' -> putDBCIOContext context'
677+
617−evalDatabaseContextIOExpr _ currentContext _ _ (LoadAtomFunctions modName funcName modPath) = do
678+evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do
679+ currentContext <- getDBCIOContext
618− eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
680+ eLoadFunc <- liftIO $ loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
619 case eLoadFunc of
681 case eLoadFunc of
620 Left LoadSymbolError -> pure (Left LoadFunctionError)
682 Left LoadSymbolError -> pure (Left LoadFunctionError)
621 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
683 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
622 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
684 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
623− in pure (Right newContext)
685+ in putDBCIOContext newContext
624−evalDatabaseContextIOExpr _ currentContext _ _ (LoadDatabaseContextFunctions modName funcName modPath) = do
686+evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName modPath) = do
687+ currentContext <- getDBCIOContext
625− eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
688+ eLoadFunc <- liftIO $ loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
626 case eLoadFunc of
689 case eLoadFunc of
627 Left LoadSymbolError -> pure (Left LoadFunctionError)
690 Left LoadSymbolError -> pure (Left LoadFunctionError)
628 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
691 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
629 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
692 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
630− in pure (Right newContext)
693+ in putDBCIOContext newContext
631
694
632−evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelation relVarName attrExprs range) =
695+evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do
633 --Define
696 --Define
634− case runState (evalDatabaseContextExpr (Define relVarName attrExprs) transId graph) (freshDatabaseState currentContext) of
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
635− (Left err,_) -> pure (Left err)
705+ Left err -> pure (Left err)
636− (Right (), elems) -> do
706+ Right state -> do
637 --Assign
707 --Assign
638 let existingRelVar = M.lookup relVarName relVarTable
708 let existingRelVar = M.lookup relVarName relVarTable
639− relVarTable = relationVariables (context elems)
709+ relVarTable = relationVariables (dbc_context state)
640 case existingRelVar of
710 case existingRelVar of
641 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
711 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
642 Just existingRel -> do
712 Just existingRel -> do
643− case runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprState currentContext transId graph) of
713+ case runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprEnv currentContext transId graph) of
644 Left err -> pure (Left err)
714 Left err -> pure (Left err)
645 Right relType -> do
715 Right relType -> do
646 let expectedAttributes = attributes relType
716 let expectedAttributes = attributes relType
647− tcMap = typeConstructorMapping (context elems)
717+ tcMap = typeConstructorMapping (dbc_context state)
648− eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
718+ eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
649 case eitherRel of
719 case eitherRel of
650 Left err -> pure $ Left err
720 Left err -> pure $ Left err
651 Right rel ->
721 Right rel ->
652− case runState (setRelVar relVarName (ExistingRelation rel) transId graph) elems of
722+ case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of
653− (Left err,_) -> pure (Left err)
723+ Left err -> pure (Left err)
654− (Right (), elems') -> pure $ Right (context elems)
724+ Right state -> putDBCIOContext (dbc_context state)
655
725
656updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple
726updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple
657updateTupleWithAtomExprs exprMap context graph tupIn = do
727updateTupleWithAtomExprs exprMap context graph tupIn = do
@@ -675,14 +745,14 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
675 tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas
745 tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas
676
746
677 deps = inclusionDependencies context
747 deps = inclusionDependencies context
678− eval expr = evalReader (evalRelationalExpr expr)
748+ reEnv = mkRelationalExprEnv context transId graph
679− evalReader f = runReader f (mkRelationalExprState 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
680 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
750 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
681− let gfSubsetExpr = evalReader (processRelationalExpr subsetExpr)
751+ let gfSubsetExpr = runReader (processRelationalExpr subsetExpr) reEnv
682− gfSupersetExpr = evalReader (processRelationalExpr supersetExpr)
752+ gfSupersetExpr = runReader (processRelationalExpr supersetExpr) reEnv
683 --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.
753 --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)
754+ typeSub <- runReader (typeForRelationalExpr subsetExpr) reEnv
685− typeSuper <- evalReader (typeForRelationalExpr supersetExpr)
755+ typeSuper <- runReader (typeForRelationalExpr supersetExpr) reEnv
686 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
756 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
687 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
757 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
688 case evalGraphRefRelationalExpr checkExpr potentialGraph of
758 case evalGraphRefRelationalExpr checkExpr potentialGraph of
@@ -805,7 +875,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName r
805
875
806extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
876extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
807extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
877extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
808− rstate <- ask
878+ rstate <- askEnv
809 -- check that the attribute name is not in use
879 -- check that the attribute name is not in use
810 case tupleExprCheckNewAttrName newAttrName relIn of
880 case tupleExprCheckNewAttrName newAttrName relIn of
811 Left err -> pure (Left err)
881 Left err -> pure (Left err)
@@ -871,9 +941,9 @@ evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExcept
871 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
941 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
872 pure (ConstructedAtom dConsName aType argAtoms)
942 pure (ConstructedAtom dConsName aType argAtoms)
873-}
943-}
874−typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)
944+typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> RelationalExprState (Either RelationalError AtomType)
875−typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
945+typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do
876− rstate <- ask
946+ rstate <- askEnv
877 case A.atomTypeForAttributeName attrName attrs of
947 case A.atomTypeForAttributeName attrName attrs of
878 Right aType -> pure (Right aType)
948 Right aType -> pure (Right aType)
879 Left err@(NoSuchAttributeNamesError _) ->
949 Left err@(NoSuchAttributeNamesError _) ->
@@ -885,9 +955,9 @@ typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
885 Right atom -> pure (Right (atomTypeForAtom atom))
955 Right atom -> pure (Right (atomTypeForAtom atom))
886 Left _ -> pure (Left err)
956 Left _ -> pure (Left err)
887
957
888−typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
958+typeForGraphAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
889−typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
959+typeForGraphAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
890− context <- fmap envContext ask
960+ context <- fmap envContext askEnv
891 let funcs = atomFunctions context
961 let funcs = atomFunctions context
892 case atomFunctionForName funcName funcs of
962 case atomFunctionForName funcName funcs of
893 Left err -> pure (Left err)
963 Left err -> pure (Left err)
@@ -904,7 +974,7 @@ typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
904 Left err -> pure (Left err)
974 Left err -> pure (Left err)
905 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
975 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
906typeFromAtomExpr attrs (RelationAtomExpr relExpr) = do
976typeFromAtomExpr attrs (RelationAtomExpr relExpr) = do
907− relType <- local (mergeAttributesIntoRelationalExprState attrs) (typeForRelationalExpr relExpr)
977+ relType <- R.local (mergeAttributesIntoRelationalExprState attrs) (typeForRelationalExpr relExpr)
908 case relType of
978 case relType of
909 Left err -> pure (Left err)
979 Left err -> pure (Left err)
910 Right relType' ->
980 Right relType' ->
@@ -913,13 +983,13 @@ typeFromAtomExpr attrs (RelationAtomExpr relExpr) = do
913typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
983typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
914 runExceptT $ do
984 runExceptT $ do
915 argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs
985 argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs
916− context <- fmap envContext (lift ask)
986+ context <- fmap envContext (lift askEnv)
917 either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
987 either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
918
988
919-- | Validate that the type of the AtomExpr matches the expected type.
989-- | Validate that the type of the AtomExpr matches the expected type.
920verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
990verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
921verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
991verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
922− rstate <- lift ask
992+ rstate <- lift askEnv
923 case A.atomTypeForAttributeName attrName (attributes relIn) of
993 case A.atomTypeForAttributeName attrName (attributes relIn) of
924 Right aType -> either throwE pure (atomTypeVerify expectedType aType)
994 Right aType -> either throwE pure (atomTypeVerify expectedType aType)
925 (Left err@(NoSuchAttributeNamesError _)) ->
995 (Left err@(NoSuchAttributeNamesError _)) ->
@@ -932,7 +1002,7 @@ verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT
932 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
1002 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
933verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
1003verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
934verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
1004verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
935− rstate <- ask
1005+ rstate <- askEnv
936 let functions = atomFunctions context
1006 let functions = atomFunctions context
937 context = envContext rstate
1007 context = envContext rstate
938 runExceptT $ do
1008 runExceptT $ do
@@ -948,7 +1018,7 @@ verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedTyp
948 else
1018 else
949 either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
1019 either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
950verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
1020verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
951− rstate <- lift ask
1021+ rstate <- lift askEnv
952 relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
1022 relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
953 either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
1023 either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
954verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do
1024verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do
@@ -956,17 +1026,27 @@ verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ d
956 either throwE pure (atomTypeVerify expectedType cType)
1026 either throwE pure (atomTypeVerify expectedType cType)
957
1027
958-- | Look up the type's name and create a new attribute.
1028-- | Look up the type's name and create a new attribute.
959−evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute
1029+evalGraphRefAttrExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)
960−evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do
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
961− aType <- atomTypeForTypeConstructorValidate True tCons aTypes M.empty
1037+ aType <- atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
962− validateAtomType aType aTypes
1038+ validateAtomType aType tConsMap
1039+ pure aType
1040+ case validate of
1041+ Left err -> pure (Left err)
1042+ Right aType ->
963− Right (Attribute attrName aType)
1043+ pure $ Right (Attribute attrName aType)
964
1044
965−evalAttrExpr _ (NakedAttributeExpr attr) = Right attr
1045+evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure $ Right attr
966
1046
967evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
1047evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
968evalTupleExpr mAttrs (TupleExpr tupMap) = do
1048evalTupleExpr mAttrs (TupleExpr tupMap) = do
969− context <- fmap envContext ask
1049+ context <- fmap envContext askEnv
970 runExceptT $ do
1050 runExceptT $ do
971 -- 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
1051 -- 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
972 -- 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
1052 -- 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
1064 where
1144 where
1065 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
1145 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
1066
1146
1067−processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError GraphRefRestrictionPredicateExpr)
1147+processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState GraphRefRestrictionPredicateExpr
1068−processRestrictionPredicateExpr TruePredicate = pure (Right TruePredicate)
1148+processRestrictionPredicateExpr TruePredicate = pure TruePredicate
1069−processRestrictionPredicateExpr (AndPredicate a b) = do
1149+processRestrictionPredicateExpr (AndPredicate a b) = AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
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
1150+processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
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
1151+processRestrictionPredicateExpr (NotPredicate a) = NotPredicate <$> processRestrictionPredicateExpr a
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
1152+processRestrictionPredicateExpr (RelationalExprPredicate expr) =
1094− e <- evalRelationalExpr expr
1153+ RelationalExprPredicate <$> processRelationalExpr expr
1095− pure $ case e of
1096− Left err -> Left err
1097− Right e' -> Right (RelationalExprPredicate e')
1098−processRestrictionPredicateExpr (AtomExprPredicate expr) = do
1154+processRestrictionPredicateExpr (AtomExprPredicate expr) =
1099− e <- processAtomExpr expr
1155+ AtomExprPredicate <$> processAtomExpr expr
1100− pure (Right (AtomExprPredicate e))
1101−processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = do
1156+processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) =
1102− e <- processAtomExpr expr
1157+ AttributeEqualityPredicate nam <$> processAtomExpr expr
1103− pure (Right (AttributeEqualityPredicate nam e))
1158+
1104−
1105−processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError GraphRefExtendTupleExpr)
1159+processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState GraphRefExtendTupleExpr
1106−processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do
1160+processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =
1107− e <- processAtomExpr atomExpr
1161+ AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr
1108− pure (Right (AttributeExtendTupleExpr nam e))
1109
1162
1110typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExprState (Either RelationalError Relation)
1163typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExprState (Either RelationalError Relation)
1111typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = pure $ mkRelation attrs emptyTupleSet
1164typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = pure $ mkRelation attrs emptyTupleSet
@@ -1191,10 +1244,10 @@ processAtomExpr :: AtomExpr -> RelationalExprState GraphRefAtomExpr
1191processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam
1244processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam
1192processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
1245processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
1193processAtomExpr (FunctionAtomExpr fName atomExprs ()) = do
1246processAtomExpr (FunctionAtomExpr fName atomExprs ()) = do
1194− tid <- re_currentTransId <$> ask
1247+ tid <- re_currentTransId <$> askEnv
1195 FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> pure tid
1248 FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> pure tid
1196processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr
1249processAtomExpr (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)
1198
1251
1199processTupleExpr :: TupleExpr -> RelationalExprState GraphRefTupleExpr
1252processTupleExpr :: TupleExpr -> RelationalExprState GraphRefTupleExpr
1200processTupleExpr (TupleExpr tMap) =
1253processTupleExpr (TupleExpr tMap) =
@@ -1202,7 +1255,7 @@ processTupleExpr (TupleExpr tMap) =
1202
1255
1203evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)
1256evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)
1204evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
1257evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
1205− graph <- re_graph <$> ask
1258+ graph <- re_graph <$> askEnv
1206 case transactionForId tid graph of
1259 case transactionForId tid graph of
1207 Left err -> pure (Left err)
1260 Left err -> pure (Left err)
1208 Right trans -> do
1261 Right trans -> do
@@ -1217,18 +1270,38 @@ evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
1217--convert AttributeExpr to GraphRefAttributeExpr
1270--convert AttributeExpr to GraphRefAttributeExpr
1218processAttributeExpr :: AttributeExpr -> RelationalExprState GraphRefAttributeExpr
1271processAttributeExpr :: AttributeExpr -> RelationalExprState GraphRefAttributeExpr
1219processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) = do
1272processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) = do
1220− tid <- re_currentTransId <$> ask
1273+ tid <- re_currentTransId <$> askEnv
1221 pure $ AttributeAndTypeNameExpr nam tCons tid
1274 pure $ AttributeAndTypeNameExpr nam tCons tid
1222processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr
1275processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr
1223
1276
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?
1225processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr
1279processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr
1226processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do
1280processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do
1227 mAttrs' <- case mAttrs of
1281 mAttrs' <- case mAttrs of
1228 Nothing -> pure Nothing
1282 Nothing -> pure Nothing
1229 Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''
1283 Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''
1230 MakeRelationFromExprs mAttrs' <$> mapM processTupleExpr tupleExprs
1284 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
1232
1305
1233mkEmptyRelVars :: RelationVariables -> RelationVariables
1306mkEmptyRelVars :: RelationVariables -> RelationVariables
1234mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap
1307mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap
@@ -1255,3 +1328,42 @@ processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet
1255processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
1328processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
1256processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
1329processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
1257processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr
1330processAttributeNames (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+
src/lib/ProjectM36/StaticOptimizer.hs+32−7
@@ -16,15 +16,40 @@ import Control.Monad.Trans.Reader
16import qualified Data.Map as M
16import qualified Data.Map as M
17import qualified Data.Set as S
17import qualified Data.Set as S
18
18
19−
20type StaticOptimizerEnv = RelationalExprEnv
19type StaticOptimizerEnv = RelationalExprEnv
21
20
22type StaticOptimizerMonad a = ReaderT StaticOptimizerEnv (ExceptT RelationalError Identity) a
21type StaticOptimizerMonad a = ReaderT StaticOptimizerEnv (ExceptT RelationalError Identity) a
23-- the static optimizer performs optimizations which need not take any specific-relation statistics into account
22-- the static optimizer performs optimizations which need not take any specific-relation statistics into account
24−optimize :: RelationalExprEnv -> GraphRefRelationalExpr -> Either RelationalError GraphRefRelationalExpr
25−optimize reEnv expr = runIdentity (runExceptT (runReaderT (optimizeGraphRefRelationalExpr expr) reEnv))
26
23
24+-- | A temporary function to be replaced by IO-based implementation.
25+optimizeAndEvalRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError Relation
26+optimizeAndEvalRelationalExpr env expr = do
27+ let gfExpr = runReader (processRelationalExpr expr) env
28+ optExpr <- runStaticOptimizerMonad env (fullOptimizeGraphRefRelationalExpr gfExpr)
29+ evalGraphRefRelationalExpr optExpr (re_graph env)
30+
31+optimizeAndEvalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextEvalMonad ()
32+optimizeAndEvalDatabaseContextExpr expr = do
33+ env <- dbcRelationalExprEnv
34+ let gfExpr = runReader (processDatabaseContextExpr expr) env
35+ eOptExpr = runStaticOptimizerMonad env (optimizeDatabaseContextExpr gfExpr)
36+ case eOptExpr of
37+ Left err -> lift (except (Left err))
38+ Right optExpr -> evalGraphRefDatabaseContextExpr optExpr
39+
40+optimizeAndEvalDatabaseContextIOExpr :: DatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())
41+optimizeAndEvalDatabaseContextIOExpr expr = do
42+ reEnv <- getDBCIORelationalExprEnv
43+ let gfExpr = runReader (processDatabaseContextIOExpr expr) reEnv
44+ optExpr <- runStaticOptimizerMonad reEnv (optimizeDatbaseContextIOExpr gfExpr)
45+ evalGraphRefDatabaseContextIOExpr optExpr
46+
47+
48+runStaticOptimizerMonad :: RelationalExprEnv -> StaticOptimizerMonad a -> Either RelationalError a
49+runStaticOptimizerMonad env m = runIdentity (runExceptT (runReaderT m env))
27
50
51+optimizeRelationalExpr' :: RelationalExprEnv -> GraphRefRelationalExpr -> Either RelationalError GraphRefRelationalExpr
52+optimizeRelationalExpr' reEnv expr = runIdentity (runExceptT (runReaderT (optimizeGraphRefRelationalExpr expr) reEnv))
28
53
29fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> StaticOptimizerMonad GraphRefRelationalExpr
54fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> StaticOptimizerMonad GraphRefRelationalExpr
30fullOptimizeGraphRefRelationalExpr expr = do
55fullOptimizeGraphRefRelationalExpr expr = do
@@ -138,7 +163,7 @@ optimizeDatabaseContextExpr (Assign name expr) = do
138 pure $ Assign name optExpr
163 pure $ Assign name optExpr
139
164
140optimizeDatabaseContextExpr (Insert targetName expr) = do
165optimizeDatabaseContextExpr (Insert targetName expr) = do
141− optimizedExpr <- optimizeGraphRefRelationalExpr expr
166+ optimizedExpr <- fullOptimizeGraphRefRelationalExpr expr
142 if isEmptyRelationExpr optimizedExpr then -- if we are trying to insert an empty relation, do nothing
167 if isEmptyRelationExpr optimizedExpr then -- if we are trying to insert an empty relation, do nothing
143 pure NoOperation
168 pure NoOperation
144 else
169 else
@@ -158,9 +183,9 @@ optimizeDatabaseContextExpr dep@(AddInclusionDependency _ _) = pure dep
158
183
159optimizeDatabaseContextExpr (RemoveInclusionDependency name) = pure (RemoveInclusionDependency name)
184optimizeDatabaseContextExpr (RemoveInclusionDependency name) = pure (RemoveInclusionDependency name)
160
185
161−optimizeDatabaseContextExpr (AddNotification name triggerExpr resultOldExpr resultNewExpr) = do
186+optimizeDatabaseContextExpr (AddNotification name triggerExpr resultOldExpr resultNewExpr) =
162− optExpr <- optimizeGraphRefRelationalExpr triggerExpr
187+ --we can't optimize these expressions until they run
163− pure (AddNotification name optExpr resultOldExpr resultNewExpr)
188+ pure (AddNotification name triggerExpr resultOldExpr resultNewExpr)
164
189
165optimizeDatabaseContextExpr notif@(RemoveNotification _) = pure notif
190optimizeDatabaseContextExpr notif@(RemoveNotification _) = pure notif
166
191