@@ -1,34 +1,50 @@
1{-# LANGUAGE ScopedTypeVariables #-}
1{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FlexibleContexts #-}
2module ProjectM36.RelationalExpression where
4module ProjectM36.RelationalExpression where
3import ProjectM36.Relation
5import ProjectM36.Relation
4import ProjectM36.Tuple
6import ProjectM36.Tuple
5import ProjectM36.TupleSet
7import ProjectM36.TupleSet
6import ProjectM36.Base
8import ProjectM36.Base
9+import qualified Data.UUID as U
7import ProjectM36.Error
10import ProjectM36.Error
8import ProjectM36.AtomType
11import ProjectM36.AtomType
9−import ProjectM36.Attribute (emptyAttributes)
12+import ProjectM36.Attribute (emptyAttributes, attributesFromList)
10import ProjectM36.ScriptSession
13import ProjectM36.ScriptSession
11import ProjectM36.DataTypes.Primitive
14import ProjectM36.DataTypes.Primitive
12import ProjectM36.AtomFunction
15import ProjectM36.AtomFunction
13import ProjectM36.DatabaseContextFunction
16import ProjectM36.DatabaseContextFunction
14import ProjectM36.Arbitrary
17import ProjectM36.Arbitrary
18+import ProjectM36.GraphRefRelationalExpr
19+import ProjectM36.Transaction
15import qualified ProjectM36.Attribute as A
20import qualified ProjectM36.Attribute as A
16import qualified Data.Map as M
21import qualified Data.Map as M
17import qualified Data.HashSet as HS
22import qualified Data.HashSet as HS
18import qualified Data.Set as S
23import qualified Data.Set as S
19import Control.Monad.State hiding (join)
24import Control.Monad.State hiding (join)
20−import Control.Exception
25+import Data.Bifunctor (second)
21import Data.Maybe
26import Data.Maybe
22import Data.Either
27import Data.Either
23import Data.Char (isUpper)
28import Data.Char (isUpper)
30+import qualified Data.List.NonEmpty as NE
31+import Data.Functor.Identity
24import qualified Data.Text as T
32import qualified Data.Text as T
25import qualified Data.Vector as V
33import qualified Data.Vector as V
26import qualified ProjectM36.TypeConstructorDef as TCD
34import qualified ProjectM36.TypeConstructorDef as TCD
27−import Control.Monad.Trans.Except
35+import qualified Control.Monad.RWS.Strict as RWS
36+import Control.Monad.RWS.Strict (RWST, execRWST, runRWST)
37+import Control.Monad.Except hiding (join)
28−import Control.Monad.Trans.Reader
38+import Control.Monad.Trans.Except (except)
39+import Control.Monad.Reader as R hiding (join)
40+import ProjectM36.NormalizeExpr
41+import ProjectM36.WithNameExpr
29import Test.QuickCheck
42import Test.QuickCheck
43+#ifdef PM36_HASKELL_SCRIPTING
30−import GHC
44+import GHC hiding (getContext)
45+import Control.Exception
31import GHC.Paths
46import GHC.Paths
33data DatabaseContextExprDetails = CountUpdatedTuples
49data DatabaseContextExprDetails = CountUpdatedTuples
@@ -45,32 +61,63 @@ databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTu
45 Right ts -> ts
61 Right ts -> ts
47-- | Used to start a fresh database state for a new database context expression.
63-- | Used to start a fresh database state for a new database context expression.
48−freshDatabaseState :: DatabaseContext -> DatabaseStateElems
64+mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
65+mkDatabaseContextEvalState context = DatabaseContextEvalState {
66+ dbc_context = context,
49−freshDatabaseState ctx = (ctx, M.empty, False) --future work: propagate return accumulator
69+ } --future work: propagate return accumulator
51-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
71-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
52−data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
72+data RelationalExprEnv = RelationalExprEnv {
53− RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
73+ re_context :: DatabaseContext,
54− RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation
74+ re_graph :: TransactionGraph,
55−
75+ re_extra :: Maybe (Either RelationTuple Attributes)
56−instance Show RelationalExprStateElems where
76+ }
57− show (RelationalExprStateTupleElems _ tup) = "RelationalExprStateTupleElems " ++ show tup
77+
58− show (RelationalExprStateAttrsElems _ attrs) = "RelationalExprStateAttrsElems" ++ show attrs
78+envTuple :: GraphRefRelationalExprEnv -> RelationTuple
59− show (RelationalExprStateElems _) = "RelationalExprStateElems"
79+envTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (gre_extra e))
61−mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems
81+envAttributes :: GraphRefRelationalExprEnv -> Attributes
62−mkRelationalExprState = RelationalExprStateElems
82+envAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (gre_extra e))
64−mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems
65−mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateElems ctx) = RelationalExprStateTupleElems ctx tupIn
66−mergeTuplesIntoRelationalExprState _ st@(RelationalExprStateAttrsElems _ _) = st
67−mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateTupleElems ctx existingTuple) = let mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap existingTuple) in
68− RelationalExprStateTupleElems ctx (mkRelationTupleFromMap mergedTupMap)
70−mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprStateElems -> RelationalExprStateElems
84+instance Show RelationalExprEnv where
71−mergeAttributesIntoRelationalExprState attrs (RelationalExprStateElems ctx) = RelationalExprStateAttrsElems ctx attrs
85+ show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)
72−mergeAttributesIntoRelationalExprState _ st@(RelationalExprStateTupleElems _ _) = st
86+
73−mergeAttributesIntoRelationalExprState attrsIn (RelationalExprStateAttrsElems ctx attrs) = RelationalExprStateAttrsElems ctx (A.union attrsIn attrs)
87+--used to eval relationalexpr
88+type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a
90+runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either RelationalError a
91+runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))
93+reGraph :: RelationalExprM TransactionGraph
94+reGraph = asks re_graph
96+reContext :: RelationalExprM DatabaseContext
97+reContext = asks re_context
99+mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv
100+mkRelationalExprEnv ctx graph =
104+ re_extra = Nothing }
106+askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
109+mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
110+mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =
111+ e{ gre_extra = new_elems }
113+ new_elems = Just (Left newTuple)
114+ mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))
115+ newTuple = mkRelationTupleFromMap mergedTupMap
117+mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
118+mergeAttributesIntoGraphRefRelationalExprEnv attrsIn e = e { gre_extra = newattrs }
120+ newattrs = Just (Right (A.union attrsIn (envAttributes e)))
75type ResultAccumName = StringType
122type ResultAccumName = StringType
@@ -80,36 +127,103 @@ data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,
80 resultAccumResult :: Relation
127 resultAccumResult :: Relation
130+data DatabaseContextEvalState = DatabaseContextEvalState {
131+ dbc_context :: DatabaseContext, --new, alterable context for a new transaction
83−type DatabaseStateElems = (DatabaseContext, M.Map ResultAccumName ResultAccum, DirtyFlag)
132+ dbc_accum :: M.Map ResultAccumName ResultAccum,
133+ dbc_dirty :: DirtyFlag
85−type DatabaseState a = State DatabaseStateElems a
136+data DatabaseContextEvalEnv = DatabaseContextEvalEnv
137+ { dce_transId :: TransactionId,
138+ dce_graph :: TransactionGraph
87−getStateContext :: DatabaseState DatabaseContext
141+mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
88−getStateContext = do
142+mkDatabaseContextEvalEnv = DatabaseContextEvalEnv
89− (ctx,_, _) <- get
143+
90− pure ctx
144+type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a
146+runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState
147+runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> execRWST m env freshEnv))
149+ freshEnv = mkDatabaseContextEvalState ctx
152+dbcTransId :: DatabaseContextEvalMonad TransactionId
153+dbcTransId = dce_transId <$> RWS.ask
155+dbcGraph :: DatabaseContextEvalMonad TransactionGraph
156+dbcGraph = dce_graph <$> RWS.ask
158+dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
159+dbcRelationalExprEnv =
160+ mkRelationalExprEnv <$> getStateContext <*> dbcGraph
162+getStateContext :: DatabaseContextEvalMonad DatabaseContext
163+getStateContext = gets dbc_context
92−putStateContext :: DatabaseContext -> DatabaseState ()
165+putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()
93−putStateContext ctx = do
166+putStateContext ctx' = do
94− (_, accum, _) <- get
167+ s <- get
95− put (ctx, accum, True)
168+ put (s {dbc_context = ctx', dbc_dirty = True})
170+-- | The context is optionally passed down along in cases where the current context is uncommitted.
171+data GraphRefRelationalExprEnv =
172+ GraphRefRelationalExprEnv {
173+ gre_context :: Maybe DatabaseContext,
174+ gre_graph :: TransactionGraph,
175+ gre_extra :: Maybe (Either RelationTuple Attributes)
97−type RelationalExprState a = Reader RelationalExprStateElems a
178+type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a
180+gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction
181+gfTransForId tid = do
183+ lift $ except $ transactionForId tid graph
99−stateElemsContext :: RelationalExprStateElems -> DatabaseContext
185+gfDatabaseContextForMarker :: GraphRefTransactionMarker -> GraphRefRelationalExprM DatabaseContext
100−stateElemsContext (RelationalExprStateTupleElems ctx _) = ctx
186+gfDatabaseContextForMarker (TransactionMarker transId) = concreteDatabaseContext <$> gfTransForId transId
101−stateElemsContext (RelationalExprStateElems ctx) = ctx
187+gfDatabaseContextForMarker UncommittedContextMarker = do
102−stateElemsContext (RelationalExprStateAttrsElems ctx _) = ctx
188+ mctx <- gre_context <$> askEnv
190+ Nothing -> throwError NoUncommittedContextInEvalError
191+ Just ctx -> pure ctx
104−setStateElemsContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
193+runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a
105−setStateElemsContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
194+runGraphRefRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))
106−setStateElemsContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
107−setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
196+freshGraphRefRelationalExprEnv :: Maybe DatabaseContext -> TransactionGraph -> GraphRefRelationalExprEnv
197+freshGraphRefRelationalExprEnv mctx graph = GraphRefRelationalExprEnv {
203+gfGraph :: GraphRefRelationalExprM TransactionGraph
204+gfGraph = asks gre_graph
206+envContext :: RelationalExprEnv -> DatabaseContext
207+envContext = re_context
209+setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv
210+setEnvContext e ctx = e { re_context = ctx }
213+--full evaluation down the graph
214+eval :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
217+ eGfExpr <- processRelationalExpr expr
219+ Left err -> pure (Left err)
220+ Right gfExpr -> pure $ evalGraphRefRelationalExpr gfExpr (re_graph env)
109--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
223--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
110−evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
224+evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)
111evalRelationalExpr (RelationVariable name _) = do
225evalRelationalExpr (RelationVariable name _) = do
112− relvarTable <- fmap (relationVariables . stateElemsContext) ask
226+ relvarTable <- fmap (relationVariables . envContext) askEnv
113 return $ case M.lookup name relvarTable of
227 return $ case M.lookup name relvarTable of
114 Just res -> Right res
228 Just res -> Right res
115 Nothing -> Left $ RelVarNotDefinedError name
229 Nothing -> Left $ RelVarNotDefinedError name
@@ -121,7 +235,7 @@ evalRelationalExpr (Project attrNames expr) = do
121 Right attrNameSet -> do
235 Right attrNameSet -> do
122 rel <- evalRelationalExpr expr
236 rel <- evalRelationalExpr expr
123 case rel of
237 case rel of
124− Right rel2 -> pure $ project attrNameSet rel2
238+ Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)
125 Left err -> pure $ Left err
239 Left err -> pure $ Left err
127evalRelationalExpr (Union exprA exprB) = do
241evalRelationalExpr (Union exprA exprB) = do
@@ -131,7 +245,7 @@ evalRelationalExpr (Union exprA exprB) = do
131 Left err -> return $ Left err
245 Left err -> return $ Left err
132 Right relA2 -> case relB of
246 Right relA2 -> case relB of
133 Left err -> return $ Left err
247 Left err -> return $ Left err
134− Right relB2 -> return $ union relA2 relB2
248+ Right relB2 -> return $ Right (Union relA2 relB2)
136evalRelationalExpr (Join exprA exprB) = do
250evalRelationalExpr (Join exprA exprB) = do
137 relA <- evalRelationalExpr exprA
251 relA <- evalRelationalExpr exprA
@@ -140,7 +254,7 @@ evalRelationalExpr (Join exprA exprB) = do
140 Left err -> return $ Left err
254 Left err -> return $ Left err
141 Right relA2 -> case relB of
255 Right relA2 -> case relB of
142 Left err -> return $ Left err
256 Left err -> return $ Left err
143− Right relB2 -> return $ join relA2 relB2
257+ Right relB2 -> return $ Right (Join relA2 relB2)
145evalRelationalExpr (Difference exprA exprB) = do
259evalRelationalExpr (Difference exprA exprB) = do
146 relA <- evalRelationalExpr exprA
260 relA <- evalRelationalExpr exprA
@@ -149,33 +263,34 @@ evalRelationalExpr (Difference exprA exprB) = do
149 Left err -> return $ Left err
263 Left err -> return $ Left err
150 Right relA2 -> case relB of
264 Right relA2 -> case relB of
151 Left err -> return $ Left err
265 Left err -> return $ Left err
152− Right relB2 -> return $ difference relA2 relB2
266+ Right relB2 -> return $ Right (Difference relA2 relB2)
154evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
268evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
155 case mkRelation attributeSet tupleSet of
269 case mkRelation attributeSet tupleSet of
156− Right rel -> return $ Right rel
270+ Right rel -> return $ Right (ExistingRelation rel)
157 Left err -> return $ Left err
271 Left err -> return $ Left err
159evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
273evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
160− currentContext <- fmap stateElemsContext ask
274+ currentContext <- fmap envContext askEnv
161 let tConss = typeConstructorMapping currentContext
275 let tConss = typeConstructorMapping currentContext
162 -- 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
276 -- 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
163 runExceptT $ do
277 runExceptT $ do
164 mAttrs <- case mAttrExprs of
278 mAttrs <- case mAttrExprs of
165 Just _ ->
279 Just _ ->
166− Just . A.attributesFromList <$> mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)
280+ Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)
167 Nothing -> pure Nothing
281 Nothing -> pure Nothing
168 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
282 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
169 let attrs = fromMaybe firstTupleAttrs mAttrs
283 let attrs = fromMaybe firstTupleAttrs mAttrs
170 firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)
284 firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)
171− either throwE pure (mkRelation attrs (RelationTupleSet tuples))
285+ expr <- either throwE pure (mkRelation attrs (RelationTupleSet tuples))
286+ pure (ExistingRelation expr)
173−evalRelationalExpr (ExistingRelation rel) = pure (Right rel)
288+evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))
175evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
290evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
176 evald <- evalRelationalExpr relExpr
291 evald <- evalRelationalExpr relExpr
177 case evald of
292 case evald of
178− Right rel -> return $ rename oldAttrName newAttrName rel
293+ Right expr -> return $ Right (Rename oldAttrName newAttrName expr)
179 Left err -> return $ Left err
294 Left err -> return $ Left err
181evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
296evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
@@ -185,324 +300,365 @@ evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
185 Right oldAttrNameSet -> do
300 Right oldAttrNameSet -> do
186 evald <- evalRelationalExpr relExpr
301 evald <- evalRelationalExpr relExpr
187 case evald of
302 case evald of
188− Right rel -> return $ group oldAttrNameSet newAttrName rel
303+ Right expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)
189 Left err -> return $ Left err
304 Left err -> return $ Left err
191evalRelationalExpr (Ungroup attrName relExpr) = do
306evalRelationalExpr (Ungroup attrName relExpr) = do
192 evald <- evalRelationalExpr relExpr
307 evald <- evalRelationalExpr relExpr
193 case evald of
308 case evald of
194− Right rel -> return $ ungroup attrName rel
309+ Right expr -> return $ Right (Ungroup attrName expr)
195 Left err -> return $ Left err
310 Left err -> return $ Left err
197evalRelationalExpr (Restrict predicateExpr relExpr) = do
312evalRelationalExpr (Restrict predicateExpr relExpr) = do
198 evald <- evalRelationalExpr relExpr
313 evald <- evalRelationalExpr relExpr
314+ pred <- processRestrictionPredicateExpr predicateExpr
199 case evald of
315 case evald of
200 Left err -> return $ Left err
316 Left err -> return $ Left err
201− Right rel -> do
317+ Right expr ->
202− eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr
318+ pure $ Right (Restrict pred expr)
204− Left err -> return $ Left err
206− pure (restrict filterfunc rel)
208evalRelationalExpr (Equals relExprA relExprB) = do
320evalRelationalExpr (Equals relExprA relExprB) = do
209 evaldA <- evalRelationalExpr relExprA
321 evaldA <- evalRelationalExpr relExprA
210 evaldB <- evalRelationalExpr relExprB
322 evaldB <- evalRelationalExpr relExprB
211 case evaldA of
323 case evaldA of
212 Left err -> return $ Left err
324 Left err -> return $ Left err
213− Right relA -> case evaldB of
325+ Right exprA -> case evaldB of
214 Left err -> return $ Left err
326 Left err -> return $ Left err
215− Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse
327+ Right exprB -> return $ Right (Equals exprA exprB)
329+evalRelationalExpr (With views mainExpr) = do
332+ let addScopedView ctx (vname,vexpr) = if vname `M.member` relationVariables ctx then
333+ Left (RelVarAlreadyDefinedError vname)
335+ case runState (evalDatabaseContextExpr (Assign vname vexpr)) (freshDatabaseState ctx) of
336+ (Left err,_) -> Left err
337+ (Right (), (ctx',_,_)) -> Right ctx'
339+ case foldM addScopedView (stateElemsContext rstate) views of
340+ Left err -> return $ Left err
342+ let evalMainExpr expr = runReader (evalRelationalExpr expr) (RelationalExprEnv ctx'')
343+ case evalMainExpr mainExpr of
344+ Left err -> return $ Left err
345+ Right rel -> return $ Right rel
217--warning: copy-pasta from above- refactor
347--warning: copy-pasta from above- refactor
218evalRelationalExpr (NotEquals relExprA relExprB) = do
348evalRelationalExpr (NotEquals relExprA relExprB) = do
219 evaldA <- evalRelationalExpr relExprA
349 evaldA <- evalRelationalExpr relExprA
220 evaldB <- evalRelationalExpr relExprB
350 evaldB <- evalRelationalExpr relExprB
221 case evaldA of
351 case evaldA of
222 Left err -> return $ Left err
352 Left err -> return $ Left err
223− Right relA -> case evaldB of
353+ Right exprA -> case evaldB of
224 Left err -> return $ Left err
354 Left err -> return $ Left err
225− Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse
355+ Right exprB -> return $ Right (NotEquals exprA exprB)
227-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
357-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
228evalRelationalExpr (Extend tupleExpression relExpr) = do
358evalRelationalExpr (Extend tupleExpression relExpr) = do
230− let evald = runReader (evalRelationalExpr relExpr) rstate
359+ eExpr <- evalRelationalExpr relExpr
231− case evald of
360+ case eExpr of
232 Left err -> pure (Left err)
361 Left err -> pure (Left err)
233− Right rel -> do
362+ Right expr -> do
234− tupProc <- extendTupleExpressionProcessor rel tupleExpression
363+ tupProc <- processExtendTupleExpr tupleExpression
235− case tupProc of
364+ pure (Right (Extend tupProc expr))
236− Left err -> pure (Left err)
365+-}
237− Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel
239--helper function to process relation variable creation/assignment
366--helper function to process relation variable creation/assignment
240−setRelVar :: RelVarName -> Relation -> DatabaseState (Either RelationalError ())
367+setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
241−setRelVar relVarName rel = do
368+setRelVar relVarName relExpr = do
242 currentContext <- getStateContext
369 currentContext <- getStateContext
370+ --prevent recursive relvar definition by resolving references to relvars in previous states
371+ relExpr' <- resolve relExpr
243− let newRelVars = M.insert relVarName rel $ relationVariables currentContext
372+ let newRelVars = M.insert relVarName relExpr' $ relationVariables currentContext
244 potentialContext = currentContext { relationVariables = newRelVars }
373 potentialContext = currentContext { relationVariables = newRelVars }
245−
374+ --optimization: if the relexpr is unchanged, skip the update
375+ if M.lookup relVarName (relationVariables currentContext) == Just relExpr then
378+ --determine when to check constraints
246− case checkConstraints potentialContext of
381+ case checkConstraints potentialContext tid graph of
247− Left err -> pure (Left err)
382+ Left err -> dbErr err
249− putStateContext potentialContext
383+ Right _ -> putStateContext potentialContext
252-- 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
385-- 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
253−deleteRelVar :: RelVarName -> DatabaseState (Either RelationalError ())
386+deleteRelVar :: RelVarName -> DatabaseContextEvalMonad ()
254deleteRelVar relVarName = do
387deleteRelVar relVarName = do
255 currContext <- getStateContext
388 currContext <- getStateContext
256 let relVars = relationVariables currContext
389 let relVars = relationVariables currContext
257 if M.notMember relVarName relVars then
390 if M.notMember relVarName relVars then
258− pure (Right ())
391+ pure ()
260 let newRelVars = M.delete relVarName relVars
393 let newRelVars = M.delete relVarName relVars
261 newContext = currContext { relationVariables = newRelVars }
394 newContext = currContext { relationVariables = newRelVars }
262 putStateContext newContext
395 putStateContext newContext
263− pure (Right ())
396+ pure ()
265−evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Either RelationalError ())
398+evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
266−evalDatabaseContextExpr NoOperation = pure (Right ())
399+evalGraphRefDatabaseContextExpr NoOperation = pure ()
268−evalDatabaseContextExpr (Define relVarName attrExprs) = do
401+evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do
402+ context <- getStateContext
269 relvars <- fmap relationVariables getStateContext
403 relvars <- fmap relationVariables getStateContext
270 tConss <- fmap typeConstructorMapping getStateContext
404 tConss <- fmap typeConstructorMapping getStateContext
271− let eAttrs = map (evalAttrExpr tConss) attrExprs
405+ graph <- dbcGraph
272− attrErrs = lefts eAttrs
406+ let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)
273− attrsList = rights eAttrs
407+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
274− if not (null attrErrs) then
408+ case eAttrs of
275− pure (Left (someErrors attrErrs))
409+ Left err -> dbErr err
276− else do
410+ Right attrsList -> do
277− let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList
411+ lift $ except $ validateAttributes tConss (A.attributesFromList attrsList)
278− if not (null atomTypeErrs) then
279− pure (Left (someErrors atomTypeErrs))
281− case M.member relVarName relvars of
412+ case M.member relVarName relvars of
282− True -> pure (Left (RelVarAlreadyDefinedError relVarName))
413+ True -> dbErr (RelVarAlreadyDefinedError relVarName)
283− False -> setRelVar relVarName emptyRelation >> pure (Right ())
414+ False -> setRelVar relVarName (ExistingRelation emptyRelation)
285 attrs = A.attributesFromList attrsList
416 attrs = A.attributesFromList attrsList
286 emptyRelation = Relation attrs emptyTupleSet
417 emptyRelation = Relation attrs emptyTupleSet
288−evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
419+evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
290−evalDatabaseContextExpr (Assign relVarName expr) = do
421+evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do
291− -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
422+ graph <- re_graph <$> dbcRelationalExprEnv
292 context <- getStateContext
423 context <- getStateContext
293− let existingRelVar = M.lookup relVarName relVarTable
424+ let existingRelVar = M.lookup relVarName (relationVariables context)
294− relVarTable = relationVariables context
425+ reEnv = freshGraphRefRelationalExprEnv (Just context) graph
295− value = runReader (evalRelationalExpr expr) (RelationalExprStateElems context)
426+ eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)
297− Left err -> pure (Left err)
298− Right rel -> case existingRelVar of
427+ case existingRelVar of
299− Nothing -> setRelVar relVarName rel
428+ Nothing -> do
300− Just existingRel -> let expectedAttributes = attributes existingRel
429+ case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of
301− foundAttributes = attributes rel in
430+ Left err -> dbErr err
302− if A.attributesEqual expectedAttributes foundAttributes then
431+ Right reltype -> do
303− setRelVar relVarName rel
432+ lift $ except $ validateAttributes (typeConstructorMapping context) (attributes reltype)
304− else
433+ setRelVar relVarName expr
305− pure (Left (RelationTypeMismatchError expectedAttributes foundAttributes))
434+ Just existingRel -> do
306−
435+ let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)
307−evalDatabaseContextExpr (Insert relVarName relExpr) = do
436+ case eExpectedType of
308− context <- getStateContext
309− let unionexp = Union relExpr rv
310− rv = RelationVariable relVarName ()
311− unioned = runReader (evalRelationalExpr unionexp) (RelationalExprStateElems context)
312− origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)
314− Left err -> pure (Left err)
437+ Left err -> dbErr err
315− Right unioned' -> case origRel of
438+ Right expectedType ->
439+ case eNewExprType of
316− Left err -> pure (Left err)
440+ Left err -> dbErr err
317− Right origRel' -> if cardinality unioned' == cardinality origRel' then --no tuples actually inserted
441+ Right newExprType -> do
318− pure (Right ())
442+ if newExprType == expectedType then do
443+ lift $ except $ validateAttributes (typeConstructorMapping context) (attributes newExprType)
444+ setRelVar relVarName expr
320− evalDatabaseContextExpr $ Assign relVarName (ExistingRelation unioned')
446+ dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))
322−evalDatabaseContextExpr (Delete relVarName predicate) = do
448+evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do
323− context <- getStateContext
449+ gfExpr <- relVarByName relVarName
324− let rv = RelationVariable relVarName ()
450+ evalGraphRefDatabaseContextExpr (Assign relVarName
325− let updatedRel = runReader (evalRelationalExpr (Restrict (NotPredicate predicate) rv)) (RelationalExprStateElems context)
451+ (Union
326− origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)
452+ gfExpr
327− case updatedRel of
453+ relExpr))
328− Left err -> pure (Left err)
329− Right updatedRel' -> case origRel of
330− Left err -> pure (Left err)
331− Right origRel' -> if cardinality origRel' == cardinality updatedRel' then
334− setRelVar relVarName updatedRel'
455+evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do
456+ gfExpr <- relVarByName relVarName
457+ setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)
336--union of restricted+updated portion and the unrestricted+unupdated portion
459--union of restricted+updated portion and the unrestricted+unupdated portion
337−evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do
460+evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do
338− context <- getStateContext
461+ rvExpr <- relVarByName relVarName
339− let relVarTable = relationVariables context
462+ let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr
340− case M.lookup relVarName relVarTable of
463+ tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict
341− Nothing -> pure (Left (RelVarNotDefinedError relVarName))
464+ updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)
342− Just rel ->
465+ projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
343− case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of
466+ restrictedPortion = Restrict pred' rvExpr
344− Left err -> pure (Left err)
467+ updated = foldr (\(oldname, atomExpr) accum ->
345− Right predicateFunc -> do
468+ let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in
346− let ret = do
469+ updateAttr oldname procAtomExpr accum
347− restrictedPortion <- restrict predicateFunc rel
470+ ) restrictedPortion (M.toList atomExprMap)
348− if cardinality restrictedPortion == Finite 0 then
471+ -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
349− pure Nothing
472+ updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)
350− else do
473+ setRelVar relVarName (Union unrestrictedPortion updatedPortion)
351− unrestrictedPortion <- restrict (predicateFunc >=> (pure . not)) rel
352− updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion
353− updatedRel <- updatedPortion `union` unrestrictedPortion
354− pure (Just updatedRel)
356− Left err -> pure (Left err)
357− Right Nothing -> pure (Right ())
358− Right (Just updatedRel) -> setRelVar relVarName updatedRel
360−evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
475+evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
361 currContext <- getStateContext
476 currContext <- getStateContext
477+ transId <- dbcTransId
362 let currDeps = inclusionDependencies currContext
479 let currDeps = inclusionDependencies currContext
363 newDeps = M.insert newDepName newDep currDeps
480 newDeps = M.insert newDepName newDep currDeps
364 if M.member newDepName currDeps then
481 if M.member newDepName currDeps then
365− pure (Left (InclusionDependencyNameInUseError newDepName))
482+ dbErr (InclusionDependencyNameInUseError newDepName)
367 let potentialContext = currContext { inclusionDependencies = newDeps }
484 let potentialContext = currContext { inclusionDependencies = newDeps }
485+ -- if the potential context passes all constraints, then save it
486+ -- potential optimization: validate only the new constraint- all old constraints must already hold
368− case checkConstraints potentialContext of
487+ case checkConstraints potentialContext transId graph of
369− Left err -> pure (Left err)
488+ Left err -> dbErr err
370− Right _ -> do
489+ Right _ ->
371 putStateContext potentialContext
490 putStateContext potentialContext
374−evalDatabaseContextExpr (RemoveInclusionDependency depName) = do
492+evalGraphRefDatabaseContextExpr (RemoveInclusionDependency depName) = do
375 currContext <- getStateContext
493 currContext <- getStateContext
376 let currDeps = inclusionDependencies currContext
494 let currDeps = inclusionDependencies currContext
377 newDeps = M.delete depName currDeps
495 newDeps = M.delete depName currDeps
378 if M.notMember depName currDeps then
496 if M.notMember depName currDeps then
379− pure (Left (InclusionDependencyNameNotInUseError depName))
497+ dbErr (InclusionDependencyNameNotInUseError depName)
381 putStateContext $ currContext {inclusionDependencies = newDeps }
499 putStateContext $ currContext {inclusionDependencies = newDeps }
384-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
501-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
385−evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do
502+evalGraphRefDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do
386 currentContext <- getStateContext
503 currentContext <- getStateContext
387 let nots = notifications currentContext
504 let nots = notifications currentContext
388 if M.member notName nots then
505 if M.member notName nots then
389− pure (Left (NotificationNameInUseError notName))
506+ dbErr (NotificationNameInUseError notName)
391 let newNotifications = M.insert notName newNotification nots
508 let newNotifications = M.insert notName newNotification nots
392 newNotification = Notification { changeExpr = triggerExpr,
509 newNotification = Notification { changeExpr = triggerExpr,
393 reportOldExpr = resultOldExpr,
510 reportOldExpr = resultOldExpr,
394 reportNewExpr = resultNewExpr}
511 reportNewExpr = resultNewExpr}
395 putStateContext $ currentContext { notifications = newNotifications }
512 putStateContext $ currentContext { notifications = newNotifications }
398−evalDatabaseContextExpr (RemoveNotification notName) = do
514+evalGraphRefDatabaseContextExpr (RemoveNotification notName) = do
399 currentContext <- getStateContext
515 currentContext <- getStateContext
400 let nots = notifications currentContext
516 let nots = notifications currentContext
401 if M.notMember notName nots then
517 if M.notMember notName nots then
402− pure (Left (NotificationNameNotInUseError notName))
518+ dbErr (NotificationNameNotInUseError notName)
404 let newNotifications = M.delete notName nots
520 let newNotifications = M.delete notName nots
405 putStateContext $ currentContext { notifications = newNotifications }
521 putStateContext $ currentContext { notifications = newNotifications }
408-- | Adds type and data constructors to the database context.
524-- | Adds type and data constructors to the database context.
409-- validate that the type *and* constructor names are unique! not yet implemented!
525-- validate that the type *and* constructor names are unique! not yet implemented!
410−evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
526+evalGraphRefDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
411 currentContext <- getStateContext
527 currentContext <- getStateContext
412 let oldTypes = typeConstructorMapping currentContext
528 let oldTypes = typeConstructorMapping currentContext
413 tConsName = TCD.name tConsDef
529 tConsName = TCD.name tConsDef
414 -- validate that the constructor's types exist
530 -- validate that the constructor's types exist
415− case validateTypeConstructorDef tConsDef dConsDefList of
531+ case validateTypeConstructorDef tConsDef dConsDefList oldTypes of
416− errs@(_:_) -> pure (Left (someErrors errs))
532+ Left err -> throwError err
417− [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName))
533+ Right () | T.null tConsName || not (isUpper (T.head tConsName)) -> dbErr (InvalidAtomTypeName tConsName)
418− | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName))
534+ | isJust (findTypeConstructor tConsName oldTypes) -> dbErr (AtomTypeNameInUseError tConsName)
419 | otherwise -> do
535 | otherwise -> do
420 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
536 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
421 putStateContext $ currentContext { typeConstructorMapping = newTypes }
537 putStateContext $ currentContext { typeConstructorMapping = newTypes }
424-- | 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.
539-- | 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.
425−evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do
540+evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do
426 currentContext <- getStateContext
541 currentContext <- getStateContext
427 let oldTypes = typeConstructorMapping currentContext
542 let oldTypes = typeConstructorMapping currentContext
428 if isNothing (findTypeConstructor tConsName oldTypes) then
543 if isNothing (findTypeConstructor tConsName oldTypes) then
429− pure (Left (AtomTypeNameNotInUseError tConsName))
544+ dbErr (AtomTypeNameNotInUseError tConsName)
431 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
546 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
432 putStateContext $ currentContext { typeConstructorMapping = newTypes }
547 putStateContext $ currentContext { typeConstructorMapping = newTypes }
435−evalDatabaseContextExpr (MultipleExpr exprs) = do
549+evalGraphRefDatabaseContextExpr (MultipleExpr exprs) =
436 --the multiple expressions must pass the same context around- not the old unmodified context
550 --the multiple expressions must pass the same context around- not the old unmodified context
437− evald <- forM exprs evalDatabaseContextExpr
551+ mapM_ evalGraphRefDatabaseContextExpr exprs
438− --some lifting magic needed here
552+
440− [] -> pure (Right ())
441− errs -> pure (Left (someErrors errs))
443−evalDatabaseContextExpr (RemoveAtomFunction funcName) = do
553+evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do
444 currentContext <- getStateContext
554 currentContext <- getStateContext
445 let atomFuncs = atomFunctions currentContext
555 let atomFuncs = atomFunctions currentContext
446 case atomFunctionForName funcName atomFuncs of
556 case atomFunctionForName funcName atomFuncs of
447− Left err -> pure (Left err)
557+ Left err -> dbErr err
448− Right realFunc -> if isScriptedAtomFunction realFunc then do
559+ if isScriptedAtomFunction realFunc then do
449− let updatedFuncs = HS.delete realFunc atomFuncs
560+ let updatedFuncs = HS.delete realFunc atomFuncs
450− putStateContext (currentContext {atomFunctions = updatedFuncs })
561+ putStateContext (currentContext {atomFunctions = updatedFuncs })
453− pure (Left (PrecompiledFunctionRemoveError funcName))
563+ dbErr (PrecompiledFunctionRemoveError funcName)
455−evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
565+evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
456 context <- getStateContext
566 context <- getStateContext
457 let dbcFuncs = dbcFunctions context
567 let dbcFuncs = dbcFunctions context
458 case databaseContextFunctionForName funcName dbcFuncs of
568 case databaseContextFunctionForName funcName dbcFuncs of
459− Left err -> pure (Left err)
569+ Left err -> dbErr err
460− Right realFunc -> if isScriptedDatabaseContextFunction realFunc then do
571+ if isScriptedDatabaseContextFunction realFunc then do
461− let updatedFuncs = HS.delete realFunc dbcFuncs
572+ let updatedFuncs = HS.delete realFunc dbcFuncs
462− putStateContext (context { dbcFunctions = updatedFuncs })
573+ putStateContext (context { dbcFunctions = updatedFuncs })
465− pure (Left (PrecompiledFunctionRemoveError funcName))
575+ dbErr (PrecompiledFunctionRemoveError funcName)
467−evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
577+evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
468 context <- getStateContext
578 context <- getStateContext
469 --resolve atom arguments
580 --resolve atom arguments
470− let relExprState = mkRelationalExprState context
581+ let eAtomTypes = mapM (runGraphRefRelationalExprM gfEnv . typeForGraphRefAtomExpr emptyAttributes) atomArgExprs
471− eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs
472 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
582 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
583+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
473 case eFunc of
584 case eFunc of
474− Left err -> pure (Left err)
585+ Left err -> dbErr err
475 Right func -> do
586 Right func -> do
476 let expectedArgCount = length (dbcFuncType func)
587 let expectedArgCount = length (dbcFuncType func)
477 actualArgCount = length atomArgExprs
588 actualArgCount = length atomArgExprs
478 if expectedArgCount /= actualArgCount then
589 if expectedArgCount /= actualArgCount then
479− pure (Left (FunctionArgumentCountMismatchError expectedArgCount actualArgCount))
590+ dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
481 --check that the atom types are valid
592 --check that the atom types are valid
482− case lefts eAtomTypes of
593+ case eAtomTypes of
483− _:_ -> pure (Left (someErrors (lefts eAtomTypes)))
594+ Left err -> dbErr err
484− [] -> do
595+ Right atomTypes -> do
485− let atomTypes = rights eAtomTypes
596+ let mValidTypes = zipWith (\ expType actType
486− let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of
597+ -> case atomTypeVerify expType actType of
487− Left err -> Just err
598+ Left err -> Just err
488− Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)
600+ (dbcFuncType func) atomTypes
489− typeErrors = catMaybes mValidTypes
601+ typeErrors = catMaybes mValidTypes
490− eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
602+ eAtomArgs = map (runGraphRefRelationalExprM gfEnv . evalGraphRefAtomExpr emptyTuple) atomArgExprs
491 if length (lefts eAtomArgs) > 1 then
603 if length (lefts eAtomArgs) > 1 then
492− pure (Left (someErrors (lefts eAtomArgs)))
604+ dbErr (someErrors (lefts eAtomArgs))
493 else if not (null typeErrors) then
605 else if not (null typeErrors) then
494− pure (Left (someErrors typeErrors))
606+ dbErr (someErrors typeErrors)
496 case evalDatabaseContextFunction func (rights eAtomArgs) context of
608 case evalDatabaseContextFunction func (rights eAtomArgs) context of
497− Left err -> pure (Left err)
609+ Left err -> dbErr err
498− Right newContext -> putStateContext newContext >> pure (Right ())
610+ Right newContext -> putStateContext newContext
499−
611+data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv
500−evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
612+ { dbcio_transId :: TransactionId,
613+ dbcio_graph :: TransactionGraph,
614+ dbcio_mScriptSession :: Maybe ScriptSession
617+type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a
619+runDatabaseContextIOEvalMonad :: DatabaseContextIOEvalEnv -> DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ()) -> IO (Either RelationalError DatabaseContextEvalState)
620+runDatabaseContextIOEvalMonad env ctx m = do
621+ res <- runRWST m env freshState
623+ (Left err,_,_) -> pure (Left err)
624+ (Right (),s,_) -> pure (Right s)
626+ freshState = mkDatabaseContextEvalState ctx
628+requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)
629+requireScriptSession = do
631+ case dbcio_mScriptSession env of
632+ Nothing -> pure $ Left $ ScriptError ScriptCompilationDisabledError
633+ Just ss -> pure (Right ss)
635+putDBCIOContext :: DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ())
636+putDBCIOContext ctx = do
637+ RWS.modify (\dbstate -> dbstate { dbc_context = ctx})
640+getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
641+getDBCIOContext = dbc_context <$> RWS.get
643+getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv
644+getDBCIORelationalExprEnv = do
645+ context <- getDBCIOContext
646+ mkRelationalExprEnv context . dbcio_graph <$> RWS.ask
648+evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())
649+#if !defined(PM36_HASKELL_SCRIPTING)
650+evalGraphRefDatabaseContextIOExpr AddAtomFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
651+evalGraphRefDatabaseContextIOExpr AddDatabaseContextFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
652+evalGraphRefDatabaseContextIOExpr LoadAtomFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
653+evalGraphRefDatabaseContextIOExpr LoadDatabaseContextFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
501−evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) =
655+evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do
502− case mScriptSession of
656+ eScriptSession <- requireScriptSession
503− Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
657+ currentContext <- getDBCIOContext
658+ case eScriptSession of
659+ Left err -> pure (Left err)
504− Just scriptSession -> do
660+ Right scriptSession -> do
505− res <- try $ runGhc (Just libdir) $ do
661+ res <- liftIO $ try $ runGhc (Just libdir) $ do
506 setSession (hscEnv scriptSession)
662 setSession (hscEnv scriptSession)
507 let atomFuncs = atomFunctions currentContext
663 let atomFuncs = atomFunctions currentContext
508 case extractAtomFunctionType funcType of
664 case extractAtomFunctionType funcType of
@@ -528,12 +684,13 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam
528 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
684 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
529 Right eContext -> case eContext of
685 Right eContext -> case eContext of
530 Left err -> pure (Left err)
686 Left err -> pure (Left err)
531− Right context' -> pure (Right context')
687+ Right context' -> putDBCIOContext context'
533−evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) =
688+evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do
534− case mScriptSession of
689+ eScriptSession <- requireScriptSession
535− Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
690+ currentContext <- getDBCIOContext
691+ case eScriptSession of
692+ Left err -> pure (Left err)
536− Just scriptSession -> do
693+ Right scriptSession -> do
537 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
694 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
538 let last2Args = reverse (take 2 (reverse funcType))
695 let last2Args = reverse (take 2 (reverse funcType))
539 atomArgs = take (length funcType - 2) funcType
696 atomArgs = take (length funcType - 2) funcType
@@ -543,7 +700,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct
543 if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
700 if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
544 pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
701 pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
546− res <- try $ runGhc (Just libdir) $ do
703+ res <- liftIO $ try $ runGhc (Just libdir) $ do
547 setSession (hscEnv scriptSession)
704 setSession (hscEnv scriptSession)
548 eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
705 eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
549 pure $ case eCompiledFunc of
706 pure $ case eCompiledFunc of
@@ -568,68 +725,98 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct
568 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
725 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
569 Right eContext -> case eContext of
726 Right eContext -> case eContext of
570 Left err -> pure (Left err)
727 Left err -> pure (Left err)
571− Right context' -> pure (Right context')
728+ Right context' -> putDBCIOContext context'
572−evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do
729+evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do
730+ currentContext <- getDBCIOContext
573− eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
731+ eLoadFunc <- liftIO $ loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
574 case eLoadFunc of
732 case eLoadFunc of
575 Left LoadSymbolError -> pure (Left LoadFunctionError)
733 Left LoadSymbolError -> pure (Left LoadFunctionError)
576 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
734 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
577 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
735 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
578− in pure (Right newContext)
736+ in putDBCIOContext newContext
579−evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName funcName modPath) = do
737+evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName modPath) = do
738+ currentContext <- getDBCIOContext
580− eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
739+ eLoadFunc <- liftIO $ loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
581 case eLoadFunc of
740 case eLoadFunc of
582 Left LoadSymbolError -> pure (Left LoadFunctionError)
741 Left LoadSymbolError -> pure (Left LoadFunctionError)
583 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
742 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
584 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
743 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
585− in pure (Right newContext)
744+ in putDBCIOContext newContext
587−evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =
746+evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do
589− case runState ( evalDatabaseContextExpr (Define relVarName attrExprs)) (freshDatabaseState currentContext) of
748+ currentContext <- getDBCIOContext
750+ --create graph ref expr
751+ let gfExpr = Define relVarName attrExprs
752+ evalEnv = mkDatabaseContextEvalEnv (dbcio_transId env) (dbcio_graph env)
753+ graph = dbcio_graph env
754+ case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of
590− (Left err,_) -> pure (Left err)
755+ Left err -> pure (Left err)
591− (Right (), elems@(ctx,_,_)) -> do
756+ Right dbstate -> do
593 let existingRelVar = M.lookup relVarName relVarTable
758 let existingRelVar = M.lookup relVarName relVarTable
594− relVarTable = relationVariables ctx
759+ relVarTable = relationVariables (dbc_context dbstate)
595 case existingRelVar of
760 case existingRelVar of
596 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
761 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
597 Just existingRel -> do
762 Just existingRel -> do
598− let expectedAttributes = attributes existingRel
763+ let gfEnv = freshGraphRefRelationalExprEnv (Just currentContext) graph
764+ case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of
765+ Left err -> pure (Left err)
767+ let expectedAttributes = attributes relType
599− let tcMap = typeConstructorMapping ctx
768+ tcMap = typeConstructorMapping (dbc_context dbstate)
600− eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
769+ eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
601− case eitherRel of
770+ case eitherRel of
602− Left err -> pure $ Left err
771+ Left err -> pure $ Left err
603− Right rel ->
772+ Right rel ->
604− case runState (setRelVar relVarName rel) elems of
773+ case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of
605− (Left err,_) -> pure (Left err)
774+ Left err -> pure (Left err)
606− (Right (), (ctx',_,_)) -> pure $ Right ctx'
775+ Right dbstate' -> putDBCIOContext (dbc_context dbstate')
608−updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
778+updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple
609−updateTupleWithAtomExprs exprMap context tupIn = do
779+updateTupleWithAtomExprs exprMap context graph tupIn = do
610 --resolve all atom exprs
780 --resolve all atom exprs
611 atomsAssoc <- mapM (\(attrName, atomExpr) -> do
782 atomsAssoc <- mapM (\(attrName, atomExpr) -> do
783+ let atom = unimplemented
612− atom <- runReader (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
784+ --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)
613 pure (attrName, atom)
785 pure (attrName, atom)
614 ) (M.toList exprMap)
786 ) (M.toList exprMap)
615 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
787 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
617--run verification on all constraints
789--run verification on all constraints
618−checkConstraints :: DatabaseContext -> Either RelationalError ()
790+checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
619−checkConstraints context = do
791+checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
620 mapM_ (uncurry checkIncDep) (M.toList deps)
792 mapM_ (uncurry checkIncDep) (M.toList deps)
794+ potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)
795+ tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,
796+ utctDayTime = secondsToDiffTime 0 }
797+ tempSchemas = Schemas context M.empty
798+ tempTrans = Transaction U.nil tempTransInfo tempSchemas
799+ tempTransInfo = TransactionInfo { parents = transId NE.:| [],
623 deps = inclusionDependencies context
804 deps = inclusionDependencies context
624− eval expr = evalReader (evalRelationalExpr expr)
805+ -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment
625− evalReader f = runReader f (RelationalExprStateElems context)
626 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
806 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
807+ let process = runProcessExprM UncommittedContextMarker
808+ gfSubsetExpr = process (processRelationalExpr subsetExpr)
809+ gfSupersetExpr = process (processRelationalExpr supersetExpr)
627 --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.
810 --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.
628− typeSub <- evalReader (typeForRelationalExpr subsetExpr)
811+ let gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
629− typeSuper <- evalReader (typeForRelationalExpr supersetExpr)
812+ runGfRel = runGraphRefRelationalExprM gfEnv
813+ typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)
814+ typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)
630 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
815 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
631− let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)
816+ let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
632− case eval checkExpr of
817+ gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)
818+ gfEnv' = freshGraphRefRelationalExprEnv (Just context) potentialGraph
633 Left err -> Left err
820 Left err -> Left err
634 Right resultRel -> if resultRel == relationTrue then
821 Right resultRel -> if resultRel == relationTrue then
@@ -639,88 +826,90 @@ checkConstraints context = do
639-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing
826-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing
640-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
827-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
642−typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
829+typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation
643typeForRelationalExpr expr = do
830typeForRelationalExpr expr = do
645− let context = stateElemsContext rstate
646 --replace the relationVariables context element with a cloned set of relation devoid of tuples
831 --replace the relationVariables context element with a cloned set of relation devoid of tuples
647− let context' = contextWithEmptyTupleSets context
832+ --evalRelationalExpr could still return an existing relation with tuples, so strip them
648− rstate' = setStateElemsContext rstate context'
833+ graph <- reGraph
649− pure (runReader (evalRelationalExpr expr) rstate')
834+ context <- reContext
835+ let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)
836+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
837+ runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
651--returns a database context with all tuples removed
840--returns a database context with all tuples removed
652--this is useful for type checking and optimization
841--this is useful for type checking and optimization
653contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
843contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
654contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
844contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
656− relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
846+ relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)
658liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
849liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
659liftE v = do
850liftE v = do
660 y <- lift v
851 y <- lift v
661 case y of
852 case y of
662− Left err -> throwE err
853+ Left err -> throwError err
663 Right val -> pure val
854 Right val -> pure val
665{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
856{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
666−predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter)
857+predicateRestrictionFilter :: Attributes -> GraphRefRestrictionPredicateExpr -> GraphRefRelationalExprM RestrictionFilter
667−predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =
858+predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do
669− expr1v <- liftE (predicateRestrictionFilter attrs expr1)
859+ expr1v <- predicateRestrictionFilter attrs expr1
670− expr2v <- liftE (predicateRestrictionFilter attrs expr2)
860+ expr2v <- predicateRestrictionFilter attrs expr2
671− pure (\x -> do
861+ pure (\x -> do
672− ev1 <- expr1v x
862+ ev1 <- expr1v x
673− ev2 <- expr2v x
863+ ev2 <- expr2v x
674− pure (ev1 && ev2))
864+ pure (ev1 && ev2))
676−predicateRestrictionFilter attrs (OrPredicate expr1 expr2) =
866+predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do
678− expr1v <- liftE (predicateRestrictionFilter attrs expr1)
867+ expr1v <- predicateRestrictionFilter attrs expr1
679− expr2v <- liftE (predicateRestrictionFilter attrs expr2)
868+ expr2v <- predicateRestrictionFilter attrs expr2
680 pure (\x -> do
869 pure (\x -> do
681 ev1 <- expr1v x
870 ev1 <- expr1v x
682 ev2 <- expr2v x
871 ev2 <- expr2v x
683 pure (ev1 || ev2))
872 pure (ev1 || ev2))
685−predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))
874+predicateRestrictionFilter _ TruePredicate = pure (\_ -> pure True)
687−predicateRestrictionFilter attrs (NotPredicate expr) =
876+predicateRestrictionFilter attrs (NotPredicate expr) = do
689− exprv <- liftE (predicateRestrictionFilter attrs expr)
877+ exprv <- predicateRestrictionFilter attrs expr
690− pure (fmap not . exprv)
878+ pure (fmap not . exprv)
692--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here
880--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here
693predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do
881predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do
694− rstate <- ask
882+ renv <- askEnv
695− pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of
883+ let eval :: RelationTuple -> Either RelationalError Relation
885+ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in
886+ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)
887+ pure (\tup -> case eval tup of
696 Left err -> Left err
888 Left err -> Left err
697 Right rel -> if arity rel /= 0 then
889 Right rel -> if arity rel /= 0 then
698 Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
890 Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
700− pure (rel == relationTrue)))
892+ pure (rel == relationTrue))
702predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
894predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
703− rstate <- ask
895+ env <- askEnv
704− let (attrs', ctxtup') = case rstate of
896+ let attrs' = A.union attrs (envAttributes env)
705− RelationalExprStateElems _ -> (attrs, emptyTuple)
897+ ctxtup' = envTuple env
706− RelationalExprStateAttrsElems _ _ -> (attrs, emptyTuple)
707− RelationalExprStateTupleElems _ ctxtup -> (A.union attrs (tupleAttributes ctxtup), ctxtup)
709− atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr)
898+ atomExprType <- typeForGraphRefAtomExpr attrs' atomExpr
710− attr <- either throwE pure $ case A.attributeForName attrName attrs of
899+ attr <- lift $ except $ case A.attributeForName attrName attrs of
711 Right attr -> Right attr
900 Right attr -> Right attr
712 Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of
901 Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of
713 Right ctxattr -> Right ctxattr
902 Right ctxattr -> Right ctxattr
714 Left err2@(NoSuchAttributeNamesError _) -> Left err2
903 Left err2@(NoSuchAttributeNamesError _) -> Left err2
715 Left err -> Left err
904 Left err -> Left err
716 Left err -> Left err
905 Left err -> Left err
717− if atomExprType /= A.atomType attr then
906+ if atomExprType /= A.atomType attr then
718− throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
907+ throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
720 pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of
909 pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of
721 Right atomCmp -> atomCmp == atomIn
910 Right atomCmp -> atomCmp == atomIn
722 Left _ -> False
911 Left _ -> False
723− atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate
912+ atomEvald = runGraphRefRelationalExprM env (evalGraphRefAtomExpr tupleIn atomExpr)
725 pure $ case atomForAttributeName attrName tupleIn of
914 pure $ case atomForAttributeName attrName tupleIn of
726 Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of
915 Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of
@@ -731,48 +920,99 @@ predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr)
731-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
920-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
732predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
921predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
733 --merge attrs into the state attributes
922 --merge attrs into the state attributes
734− rstate <- ask
923+ renv <- askEnv
736− aType <- liftE (typeFromAtomExpr attrs atomExpr)
924+ aType <- typeForGraphRefAtomExpr attrs atomExpr
737− if aType /= BoolAtomType then
925+ if aType /= BoolAtomType then
738− throwE (AtomTypeMismatchError aType BoolAtomType)
926+ throwError (AtomTypeMismatchError aType BoolAtomType)
740 pure (\tupleIn ->
928 pure (\tupleIn ->
741− pure $ case runReader (evalAtomExpr tupleIn atomExpr) rstate of
929+ case runGraphRefRelationalExprM renv (evalGraphRefAtomExpr tupleIn atomExpr) of
742− Left _ -> False
930+ Left err -> Left err
743− Right boolAtomValue -> boolAtomValue == BoolAtom True)
931+ Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))
745tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
933tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
746tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then
934tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then
747− Left (error "SPAMMIT" $ AttributeNameInUseError attrName)
935+ Left (AttributeNameInUseError attrName)
749 Right rel
937 Right rel
751−extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
939+extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)
752−extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
940+extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) =
753− rstate <- ask
941+-- renv <- askEnv
754 -- check that the attribute name is not in use
942 -- check that the attribute name is not in use
755 case tupleExprCheckNewAttrName newAttrName relIn of
943 case tupleExprCheckNewAttrName newAttrName relIn of
756− Left err -> pure (Left err)
944+ Left err -> throwError err
757− Right _ -> runExceptT $ do
945+ Right _ -> do
758− atomExprType <- liftE (typeFromAtomExpr (attributes relIn) atomExpr)
946+ atomExprType <- typeForGraphRefAtomExpr (attributes relIn) atomExpr
759− atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)
947+ atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType
760 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
948 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
761 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
949 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
762− pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of
950+ env <- ask
763− Left err -> Left err
951+ pure (newAndOldAttrs, \tup -> do
952+ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup env
953+ atom <- runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr tup atomExpr)
764− Right atom -> Right (tupleAtomExtend newAttrName atom tup)
954+ Right (tupleAtomExtend newAttrName atom tup)
957+evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
958+evalGraphRefAtomExpr tupIn (AttributeAtomExpr attrName) =
959+ case atomForAttributeName attrName tupIn of
960+ Right atom -> pure atom
961+ Left err@(NoSuchAttributeNamesError _) -> do
963+ case gre_extra env of
964+ Nothing -> throwError err
965+ Just (Left ctxtup) -> lift $ except $ atomForAttributeName attrName ctxtup
966+ Just (Right _) -> throwError err
967+ Left err -> throwError err
968+evalGraphRefAtomExpr _ (NakedAtomExpr atom) = pure atom
969+evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName arguments tid) = do
970+ argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments
971+ context <- gfDatabaseContextForMarker tid
972+ let functions = atomFunctions context
973+ func <- lift $ except (atomFunctionForName funcName functions)
974+ let expectedArgCount = length (atomFuncType func) - 1
975+ actualArgCount = length argTypes
976+ safeInit [] = [] -- different behavior from normal init
977+ safeInit xs = init xs
978+ if expectedArgCount /= actualArgCount then
979+ throwError (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
981+ let zippedArgs = zip (safeInit (atomFuncType func)) argTypes
982+ mapM_ (\(expType, actType) ->
983+ lift $ except (atomTypeVerify expType actType)) zippedArgs
984+ evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments
985+ case evalAtomFunction func evaldArgs of
986+ Left err -> throwError (AtomFunctionUserError err)
988+ --validate that the result matches the expected type
989+ _ <- lift $ except (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))
991+evalGraphRefAtomExpr tupIn (RelationAtomExpr relExpr) = do
992+ --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes
994+ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env
995+ relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)
996+ pure (RelationAtom relAtom)
997+evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do --why is the tid unused here? suspicious
998+ let mergeEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn
999+ aType <- local mergeEnv (typeForGraphRefAtomExpr (tupleAttributes tupIn) cons)
1000+ argAtoms <- local mergeEnv $
1001+ mapM (evalGraphRefAtomExpr tupIn) dConsArgs
1002+ pure (ConstructedAtom dConsName aType argAtoms)
767−evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)
1005+evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom
1006+evalAtomExpr tupIn expr =
768evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
1010evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
769 Right atom -> pure (Right atom)
1011 Right atom -> pure (Right atom)
770 err@(Left (NoSuchAttributeNamesError _)) -> do
1012 err@(Left (NoSuchAttributeNamesError _)) -> do
771 rstate <- ask
1013 rstate <- ask
772− case rstate of
1014+ let stateTup = stateTuple rstate
773− RelationalExprStateElems _ -> pure err
774− RelationalExprStateAttrsElems _ _ -> pure err
775− RelationalExprStateTupleElems _ ctxtup -> pure (atomForAttributeName attrName ctxtup)
1015+ pure (atomForAttributeName attrName stateTup)
776 Left err -> pure (Left err)
1016 Left err -> pure (Left err)
777evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
1017evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
778evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
1018evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
@@ -783,13 +1023,15 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
783 func <- either throwE pure (atomFunctionForName funcName functions)
1023 func <- either throwE pure (atomFunctionForName funcName functions)
784 let expectedArgCount = length (atomFuncType func) - 1
1024 let expectedArgCount = length (atomFuncType func) - 1
785 actualArgCount = length argTypes
1025 actualArgCount = length argTypes
787 safeInit [] = [] -- different behavior from normal init
1026 safeInit [] = [] -- different behavior from normal init
788− safeInit (_:xs) = safeInit xs
1027+ safeInit xs = init xs
789 if expectedArgCount /= actualArgCount then
1028 if expectedArgCount /= actualArgCount then
790 throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
1029 throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
1031+ let zippedArgs = zip (safeInit (atomFuncType func)) argTypes
1032+ mapM_ (\(expType, eActType) -> do
1033+ actType <- either throwE pure eActType
792− mapM_ (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))
1034+ either throwE pure (atomTypeVerify expType actType)) zippedArgs
793 evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments
1035 evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments
794 case evalAtomFunction func evaldArgs of
1036 case evalAtomFunction func evaldArgs of
795 Left err -> throwE (AtomFunctionUserError err)
1037 Left err -> throwE (AtomFunctionUserError err)
@@ -810,124 +1052,182 @@ evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExcept
810 aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
1052 aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
811 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
1053 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
812 pure (ConstructedAtom dConsName aType argAtoms)
1054 pure (ConstructedAtom dConsName aType argAtoms)
814−typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)
1056+typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
815−typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
1057+typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do
816− rstate <- ask
1058+ renv <- askEnv
817 case A.atomTypeForAttributeName attrName attrs of
1059 case A.atomTypeForAttributeName attrName attrs of
818− Right aType -> pure (Right aType)
1060+ Right aType -> pure aType
819− Left err@(NoSuchAttributeNamesError _) -> case rstate of
1061+ Left err@(NoSuchAttributeNamesError _) ->
1062+ let envTup = envTuple renv
1063+ envAttrs = envAttributes renv in
820− RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of
1064+ case A.attributeForName attrName envAttrs of
821− Left err' -> pure (Left err')
822− Right attr -> pure (Right (A.atomType attr))
1065+ Right attr -> pure (A.atomType attr)
823− RelationalExprStateElems _ -> pure (Left err)
824− RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of
1066+ Left _ -> case atomForAttributeName attrName envTup of
825− Left err' -> pure (Left err')
1067+ Right atom -> pure (atomTypeForAtom atom)
826− Right atom -> pure (Right (atomTypeForAtom atom))
1068+ Left _ -> --throwError (traceStack (show ("typeForGRAtomExpr", attrs, envTup)) err)
827− Left err -> pure (Left err)
1070+ Left err -> throwError err
828−typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
1072+typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)
829−typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
1073+typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do
830− context <- fmap stateElemsContext ask
1074+ funcs <- atomFunctions <$> gfDatabaseContextForMarker transId
831− let funcs = atomFunctions context
832 case atomFunctionForName funcName funcs of
1075 case atomFunctionForName funcName funcs of
833− Left err -> pure (Left err)
1076+ Left err -> throwError err
834 Right func -> do
1077 Right func -> do
835 let funcRetType = last (atomFuncType func)
1078 let funcRetType = last (atomFuncType func)
836 funcArgTypes = init (atomFuncType func)
1079 funcArgTypes = init (atomFuncType func)
837− eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs
1080+ argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs
838− case lefts eArgTypes of
839− errs@(_:_) -> pure (Left (someErrors errs))
841− let eTvMap = resolveTypeVariables funcArgTypes argTypes
1081+ let eTvMap = resolveTypeVariables funcArgTypes argTypes
842− argTypes = rights eArgTypes
843− case eTvMap of
1082+ case eTvMap of
844− Left err -> pure (Left err)
1083+ Left err -> throwError err
845− Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
1084+ Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName tvMap funcRetType
846−typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do
1085+typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do
847− rstate <- lift ask
1086+ relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)
848− relType <- either throwE pure (runReader (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))
849 pure (RelationAtomType (attributes relType))
1087 pure (RelationAtomType (attributes relType))
850-- grab the type of the data constructor, then validate that the args match the expected types
1088-- grab the type of the data constructor, then validate that the args match the expected types
851−typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
1089+typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =
852− runExceptT $ do
1090+ do
853− argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs
1091+ argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs
854− context <- fmap stateElemsContext (lift ask)
1092+ tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid
855− either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
1093+ lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes
857-- | Validate that the type of the AtomExpr matches the expected type.
1095-- | Validate that the type of the AtomExpr matches the expected type.
858−verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
1096+verifyGraphRefAtomExprTypes :: Relation -> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
859−verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
1097+verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do
860− rstate <- lift ask
1098+ env <- askEnv
861 case A.atomTypeForAttributeName attrName (attributes relIn) of
1099 case A.atomTypeForAttributeName attrName (attributes relIn) of
862− Right aType -> either throwE pure (atomTypeVerify expectedType aType)
1100+ Right aType -> lift $ except $ atomTypeVerify expectedType aType
863− (Left err@(NoSuchAttributeNamesError _)) -> case rstate of
1101+ (Left err@(NoSuchAttributeNamesError _)) ->
864− RelationalExprStateTupleElems _ _ -> throwE err
1102+ let attrs' = envAttributes env in
865− RelationalExprStateElems _ -> throwE err
1103+ if attrs' == emptyAttributes then
866− RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of
1106+ case A.attributeForName attrName attrs' of
867− Left err' -> throwE err'
1107+ Left err' -> throwError err'
868− Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
1108+ Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)
869− Left err -> throwE err
1109+ Left err -> throwError err
1111+verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =
870−verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
1112+ lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)
871−verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
1113+verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) expectedType = do
872− rstate <- ask
1114+ context <- gfDatabaseContextForMarker tid
873 let functions = atomFunctions context
1115 let functions = atomFunctions context
874− context = stateElemsContext rstate
876− func <- either throwE pure (atomFunctionForName funcName functions)
1116+ func <- lift $ except $ atomFunctionForName funcName functions
877− let expectedArgTypes = atomFuncType func
1117+ let expectedArgTypes = atomFuncType func
878− funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of
1118+ funcArgVerifier (atomExpr, expectedType2, argCount) = do
1119+ let handler :: RelationalError -> GraphRefRelationalExprM AtomType
879− Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)
1120+ handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)
880− Left err -> throwE err
1121+ handler err = throwError err
881− Right x -> pure x
1122+ verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler
882− ) $ zip3 funcArgExprs expectedArgTypes [1..]
1123+ funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]
883− if length funcArgTypes /= length expectedArgTypes - 1 then
1124+ if length funcArgTypes /= length expectedArgTypes - 1 then
884− throwE (AtomTypeCountError funcArgTypes expectedArgTypes)
1125+ throwError (AtomTypeCountError funcArgTypes expectedArgTypes)
886− either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
1127+ lift $ except $ atomTypeVerify expectedType (last expectedArgTypes)
887−verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
1128+verifyGraphRefAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType =
888− rstate <- lift ask
1129+ do
889− relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
1130+ let mergedAttrsEnv e = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) e
1131+ relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)
890− either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
1132+ lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType))
891−verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do
1133+verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do
892− cType <- liftE (typeFromAtomExpr (attributes rel) cons)
1134+ cType <- typeForGraphRefAtomExpr (attributes rel) cons
893− either throwE pure (atomTypeVerify expectedType cType)
1135+ lift $ except $ atomTypeVerify expectedType cType
895-- | Look up the type's name and create a new attribute.
1137-- | Look up the type's name and create a new attribute.
896−evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute
1138+evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
897−evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do
1139+evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do
1140+ tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker transId
898− aType <- atomTypeForTypeConstructorValidate True tCons aTypes M.empty
1141+ aType <- lift $ except $ atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
899− validateAtomType aType aTypes
1142+ lift $ except $ validateAtomType aType tConsMap
900− Right (Attribute attrName aType)
1143+ pure $ Attribute attrName aType
902−evalAttrExpr _ (NakedAttributeExpr attr) = Right attr
1145+evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure attr
904−evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
1147+-- for tuple type concrete resolution (Nothing ==> Maybe Int) when the attributes hint is Nothing, we need to first process all the tuples, then extract the concrete types on a per-attribute basis, then reprocess the tuples to include the concrete types
1148+evalGraphRefTupleExprs :: Maybe Attributes -> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]
1149+evalGraphRefTupleExprs _ (TupleExprs _ []) = pure []
1150+evalGraphRefTupleExprs mAttrs (TupleExprs fixedMarker tupleExprL) = do
1151+ tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprL
1152+ finalAttrs <- case mAttrs of
1153+ Just attrs -> pure attrs
1156+ [] -> pure emptyAttributes
1157+ (headTuple:tailTuples) -> do
1158+ --gather up resolved atom types or throw an error if an attribute cannot be made concrete from the inferred types- this could still fail if the type cannot be inferred (e.g. from [Nothing, Nothing])
1160+ processTupleAttrs (tupAttr, accAttr) =
1161+ --if the attribute is a constructedatomtype, we can recurse into it to potentially resolve type variables
1162+ if isResolvedAttribute accAttr && tupAttr == accAttr then
1165+ lift $ except $ resolveAttributes accAttr tupAttr
1166+ mostResolvedTypes <-
1167+ foldM (\acc tup -> do
1168+ let zipped = zip (V.toList $ tupleAttributes tup) acc
1169+ accNames = S.fromList $ map A.attributeName acc
1170+ tupNames = A.attributeNameSet (tupleAttributes tup)
1171+ attrNamesDiff = S.union (S.difference accNames tupNames) (S.difference tupNames accNames)
1172+ unless (null attrNamesDiff) (throwError (AttributeNamesMismatchError attrNamesDiff))
1173+ nextTupleAttrs <- mapM processTupleAttrs zipped
1174+ let diff = A.attributesDifference (A.attributesFromList nextTupleAttrs) (A.attributesFromList acc)
1175+ if diff == A.emptyAttributes then
1176+ pure nextTupleAttrs
1178+ throwError (TupleAttributeTypeMismatchError diff)
1179+ ) (V.toList $ tupleAttributes headTuple) tailTuples
1180+ pure (A.attributesFromList mostResolvedTypes)
1181+ --strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same
1182+ tConsMap <- case singularTransactions tupleExprL of
1183+ SingularTransactionRef commonTransId ->
1184+ typeConstructorMapping <$> gfDatabaseContextForMarker commonTransId
1185+ NoTransactionsRef ->
1186+ typeConstructorMapping <$> gfDatabaseContextForMarker fixedMarker
1187+ -- if there are multiple transaction markers in the TupleExprs, then we can't assume a single type constructor mapping- this could be improved in the future, but if all the tuples are fully resolved, then we don't need further resolution
1188+ _ -> throwError TupleExprsReferenceMultipleMarkersError
1189+ lift $ except $ validateAttributes tConsMap finalAttrs
1190+ mapM (lift . except . resolveTypesInTuple finalAttrs tConsMap) tuples
1193+--resolveAttributes (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",IntegerAtomType),("b",TypeVariableType "b")]))) (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",TypeVariableType "a"),("b",TextAtomType)])))
1195+evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple
905−evalTupleExpr attrs (TupleExpr tupMap) = do
1196+evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do
906− context <- fmap stateElemsContext ask
908 -- 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
1197 -- 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
909 -- 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
1198 -- 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
1199+ let attrs = fromMaybe A.emptyAttributes mAttrs
910− attrAtoms <- mapM (\(attrName, aExpr) -> do
1200+ resolveOneAtom (attrName, aExpr) =
911− newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)
1201+ do
1202+ --provided when the relation header is available
1203+ let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs
1204+ unresolvedType <- typeForGraphRefAtomExpr attrs aExpr
1205+ resolvedType <- case eExpectedAtomType of
1206+ Left _ -> pure unresolvedType
1207+ Right typeHint -> lift $ except $ resolveAtomType typeHint unresolvedType
1208+ --resolve atom typevars based on resolvedType?
912− newAtom <- liftE (evalAtomExpr emptyTuple aExpr)
1209+ newAtom <- evalGraphRefAtomExpr emptyTuple aExpr
913− pure (attrName, newAtom, newAtomType)
1210+ pure (attrName, newAtom, resolvedType)
914− ) (M.toList tupMap)
1211+ attrAtoms <- mapM resolveOneAtom (M.toList tupMap)
915− let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
1212+ let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
916− atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
1213+ atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
917− tup = mkRelationTuple tupAttrs atoms
1214+ tup = mkRelationTuple tupAttrs atoms
918− tConss = typeConstructorMapping context
919− finalAttrs = fromMaybe tupAttrs attrs
1215+ finalAttrs = fromMaybe tupAttrs mAttrs
920 --verify that the attributes match
1216 --verify that the attributes match
921− when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)
1217+ when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)
1218+ --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held
922− tup' <- either throwE pure (resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup))
1219+ --tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))
1220+ let tup' = reorderTuple finalAttrs tup
1221+ --TODO: restore type resolution
923− _ <- either throwE pure (validateTuple tup' tConss)
1222+-- _ <- lift $ except (validateTuple tup' tConss)
924− pure tup'
1223+ pure tup'
926−evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))
1226+evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))
927evalAttributeNames attrNames expr = do
1227evalAttributeNames attrNames expr = do
928 eExprType <- typeForRelationalExpr expr
1228 eExprType <- typeForRelationalExpr expr
929 case eExprType of
1229 case eExprType of
930− Left err -> pure (Left err)
1230+ Left err -> throwError err
931 Right exprTyp -> do
1231 Right exprTyp -> do
932 let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
1232 let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
933 case attrNames of
1233 case attrNames of
@@ -970,4 +1270,346 @@ evalAttributeNames attrNames expr = do
970 case eAttrExprType of
1270 case eAttrExprType of
971 Left err -> pure (Left err)
1271 Left err -> pure (Left err)
972 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
1272 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
1275+--temporary implementation until we have a proper planner+executor
1276+evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
1277+evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
1278+ mAttrs <- case mAttrExprs of
1280+ Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)
1281+ Nothing -> pure Nothing
1282+ tuples <- evalGraphRefTupleExprs mAttrs tupleExprs
1283+ let attrs = fromMaybe firstTupleAttrs mAttrs
1284+ firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)
1285+ lift $ except $ mkRelation attrs (RelationTupleSet tuples)
1286+evalGraphRefRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
1287+ lift $ except $ mkRelation attributeSet tupleSet
1288+evalGraphRefRelationalExpr (ExistingRelation rel) = pure rel
1289+evalGraphRefRelationalExpr (RelationVariable name tid) = do
1290+ ctx <- gfDatabaseContextForMarker tid
1291+ case M.lookup name (relationVariables ctx) of
1292+ Nothing -> throwError (RelVarNotDefinedError name)
1293+ Just rv -> evalGraphRefRelationalExpr rv
1294+evalGraphRefRelationalExpr (Project attrNames expr) = do
1295+ attrNameSet <- evalGraphRefAttributeNames attrNames expr
1296+ rel <- evalGraphRefRelationalExpr expr
1297+ lift $ except $ project attrNameSet rel
1298+evalGraphRefRelationalExpr (Union exprA exprB) = do
1299+ relA <- evalGraphRefRelationalExpr exprA
1300+ relB <- evalGraphRefRelationalExpr exprB
1301+ lift $ except $ union relA relB
1302+evalGraphRefRelationalExpr (Join exprA exprB) = do
1303+ relA <- evalGraphRefRelationalExpr exprA
1304+ relB <- evalGraphRefRelationalExpr exprB
1305+ lift $ except $ join relA relB
1306+evalGraphRefRelationalExpr (Rename oldName newName expr) = do
1307+ rel <- evalGraphRefRelationalExpr expr
1308+ lift $ except $ rename oldName newName rel
1309+evalGraphRefRelationalExpr (Difference exprA exprB) = do
1310+ relA <- evalGraphRefRelationalExpr exprA
1311+ relB <- evalGraphRefRelationalExpr exprB
1312+ lift $ except $ difference relA relB
1313+evalGraphRefRelationalExpr (Group groupAttrNames newAttrName expr) = do
1314+ groupNames <- evalGraphRefAttributeNames groupAttrNames expr
1315+ rel <- evalGraphRefRelationalExpr expr
1316+ lift $ except $ group groupNames newAttrName rel
1317+evalGraphRefRelationalExpr (Ungroup groupAttrName expr) = do
1318+ rel <- evalGraphRefRelationalExpr expr
1319+ lift $ except $ ungroup groupAttrName rel
1320+evalGraphRefRelationalExpr (Restrict predExpr expr) = do
1321+ rel <- evalGraphRefRelationalExpr expr
1322+ filt <- predicateRestrictionFilter (attributes rel) predExpr
1323+ lift $ except $ restrict filt rel
1324+evalGraphRefRelationalExpr (Equals exprA exprB) = do
1325+ relA <- evalGraphRefRelationalExpr exprA
1326+ relB <- evalGraphRefRelationalExpr exprB
1327+ pure $ if relA == relB then relationTrue else relationFalse
1328+evalGraphRefRelationalExpr (NotEquals exprA exprB) = do
1329+ relA <- evalGraphRefRelationalExpr exprA
1330+ relB <- evalGraphRefRelationalExpr exprB
1331+ pure $ if relA == relB then relationFalse else relationTrue
1332+evalGraphRefRelationalExpr (Extend extendTupleExpr expr) = do
1333+ rel <- evalGraphRefRelationalExpr expr
1334+ (newAttrs, tupProc) <- extendGraphRefTupleExpressionProcessor rel extendTupleExpr
1335+ lift $ except $ relMogrify tupProc newAttrs rel
1336+evalGraphRefRelationalExpr expr@With{} =
1337+ --strategy A: add relation variables to the contexts in the graph
1338+ --strategy B: drop in macros in place (easier programmatically)
1339+ --strategy B implementation
1340+ evalGraphRefRelationalExpr (substituteWithNameMacros [] expr)
1342+dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext
1343+dbContextForTransId tid graph = do
1344+ trans <- transactionForId tid graph
1345+ pure (concreteDatabaseContext trans)
1347+transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
1348+transactionForId tid graph
1350+ Left RootTransactionTraversalError
1351+ | S.null matchingTrans =
1352+ Left $ NoSuchTransactionError tid
1354+ Right $ head (S.toList matchingTrans)
1356+ matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
1358+typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
1359+typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet
1360+typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))
1361+typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
1362+ mAttrs <- case mAttrExprs of
1363+ Just attrExprs -> do
1364+ attrs <- mapM evalGraphRefAttributeExpr attrExprs
1365+ pure (Just (attributesFromList attrs))
1366+ Nothing -> pure Nothing
1367+ tuples <- evalGraphRefTupleExprs mAttrs tupleExprs
1368+ let retAttrs = case tuples of
1369+ (tup:_) -> tupleAttributes tup
1370+ [] -> fromMaybe A.emptyAttributes mAttrs
1371+ pure $ emptyRelationWithAttrs retAttrs
1373+typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do
1374+ relVars <- relationVariables <$> gfDatabaseContextForMarker tid
1375+ case M.lookup rvName relVars of
1376+ Nothing -> throwError (RelVarNotDefinedError rvName)
1378+ typeForGraphRefRelationalExpr rvExpr
1379+typeForGraphRefRelationalExpr (Project attrNames expr) = do
1380+ exprType' <- typeForGraphRefRelationalExpr expr
1381+ projectionAttrs <- evalGraphRefAttributeNames attrNames expr
1382+ lift $ except $ project projectionAttrs exprType'
1383+typeForGraphRefRelationalExpr (Union exprA exprB) = do
1384+ exprA' <- typeForGraphRefRelationalExpr exprA
1385+ exprB' <- typeForGraphRefRelationalExpr exprB
1386+ lift $ except $ union exprA' exprB'
1387+typeForGraphRefRelationalExpr (Join exprA exprB) = do
1388+ exprA' <- typeForGraphRefRelationalExpr exprA
1389+ exprB' <- typeForGraphRefRelationalExpr exprB
1390+ lift $ except $ join exprA' exprB'
1391+typeForGraphRefRelationalExpr (Rename oldAttr newAttr expr) = do
1392+ expr' <- typeForGraphRefRelationalExpr expr
1393+ lift $ except $ rename oldAttr newAttr expr'
1394+typeForGraphRefRelationalExpr (Difference exprA exprB) = do
1395+ exprA' <- typeForGraphRefRelationalExpr exprA
1396+ exprB' <- typeForGraphRefRelationalExpr exprB
1397+ lift $ except $ difference exprA' exprB'
1398+typeForGraphRefRelationalExpr (Group groupNames attrName expr) = do
1399+ expr' <- typeForGraphRefRelationalExpr expr
1400+ groupNames' <- evalGraphRefAttributeNames groupNames expr
1401+ lift $ except $ group groupNames' attrName expr'
1402+typeForGraphRefRelationalExpr (Ungroup groupAttrName expr) = do
1403+ expr' <- typeForGraphRefRelationalExpr expr
1404+ lift $ except $ ungroup groupAttrName expr'
1405+typeForGraphRefRelationalExpr (Restrict pred' expr) = do
1406+ expr' <- typeForGraphRefRelationalExpr expr
1407+ filt <- predicateRestrictionFilter (attributes expr') pred'
1408+ lift $ except $ restrict filt expr'
1409+typeForGraphRefRelationalExpr Equals{} =
1411+typeForGraphRefRelationalExpr NotEquals{} =
1413+typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do
1414+ rel <- typeForGraphRefRelationalExpr expr
1415+ evalGraphRefRelationalExpr (Extend extendTupleExpr (ExistingRelation rel))
1416+typeForGraphRefRelationalExpr expr@(With withs _) = do
1417+ let expr' = substituteWithNameMacros [] expr
1418+ checkMacroName (WithNameExpr macroName tid) = do
1419+ rvs <- relationVariables <$> gfDatabaseContextForMarker tid
1420+ case M.lookup macroName rvs of
1421+ Just _ -> lift $ except $ Left (RelVarAlreadyDefinedError macroName) --this error does not include the transaction marker, but should be good enough to identify the cause
1423+ mapM_ (checkMacroName . fst) withs
1424+ typeForGraphRefRelationalExpr expr'
1426+evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)
1427+evalGraphRefAttributeNames attrNames expr = do
1428+ exprType' <- typeForGraphRefRelationalExpr expr
1429+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType')))
1431+ AttributeNames names ->
1432+ case A.projectionAttributesForNames names (attributes exprType') of
1433+ Left err -> throwError err
1434+ Right attrs -> pure (S.fromList (V.toList (A.attributeNames attrs)))
1436+ InvertedAttributeNames names -> do
1437+ let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
1438+ if not (S.null nonExistentAttributeNames) then
1439+ throwError $ AttributeNamesMismatchError nonExistentAttributeNames
1441+ pure (A.nonMatchingAttributeNameSet names typeNameSet)
1443+ UnionAttributeNames namesA namesB -> do
1444+ nameSetA <- evalGraphRefAttributeNames namesA expr
1445+ nameSetB <- evalGraphRefAttributeNames namesB expr
1446+ pure (S.union nameSetA nameSetB)
1448+ IntersectAttributeNames namesA namesB -> do
1449+ nameSetA <- evalGraphRefAttributeNames namesA expr
1450+ nameSetB <- evalGraphRefAttributeNames namesB expr
1451+ pure (S.intersection nameSetA nameSetB)
1453+ RelationalExprAttributeNames attrExpr -> do
1454+ attrExprType <- typeForGraphRefRelationalExpr attrExpr
1455+ pure (A.attributeNameSet (attributes attrExprType))
1457+evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
1458+evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
1459+ tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid
1460+ case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of
1461+ Left err -> throwError err
1463+ case validateAtomType aType tConsMap of
1464+ Left err -> throwError err
1465+ Right _ -> pure (Attribute attrName aType)
1466+evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr
1468+mkEmptyRelVars :: RelationVariables -> RelationVariables
1469+mkEmptyRelVars = M.map mkEmptyRelVar
1471+ mkEmptyRelVar expr@MakeRelationFromExprs{} = expr --do not truncate here because we might lose essential type information in emptying the tuples
1472+ mkEmptyRelVar (MakeStaticRelation attrs _) = MakeStaticRelation attrs emptyTupleSet
1473+ mkEmptyRelVar (ExistingRelation rel) = ExistingRelation (emptyRelationWithAttrs (attributes rel))
1474+ mkEmptyRelVar rv@RelationVariable{} = Restrict (NotPredicate TruePredicate) rv
1475+ mkEmptyRelVar (Project attrNames expr) = Project attrNames (mkEmptyRelVar expr)
1476+ mkEmptyRelVar (Union exprA exprB) = Union (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
1477+ mkEmptyRelVar (Join exprA exprB) = Join (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
1478+ mkEmptyRelVar (Rename nameA nameB expr) = Rename nameA nameB (mkEmptyRelVar expr)
1479+ mkEmptyRelVar (Difference exprA exprB) = Difference (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
1480+ mkEmptyRelVar (Group attrNames attrName expr) = Group attrNames attrName (mkEmptyRelVar expr)
1481+ mkEmptyRelVar (Ungroup attrName expr) = Ungroup attrName (mkEmptyRelVar expr)
1482+ mkEmptyRelVar (Restrict pred' expr) = Restrict pred' (mkEmptyRelVar expr)
1483+ mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
1484+ mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)
1485+ mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)
1486+ mkEmptyRelVar (With macros expr) = With (map (second mkEmptyRelVar) macros) (mkEmptyRelVar expr)
1489+dbErr :: RelationalError -> DatabaseContextEvalMonad ()
1490+dbErr err = lift (except (Left err))
1492+-- | Return a Relation describing the relation variables.
1493+relationVariablesAsRelation :: DatabaseContext -> TransactionGraph -> Either RelationalError Relation
1494+relationVariablesAsRelation ctx graph = do
1495+ let subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]
1496+ attrs = A.attributesFromList [Attribute "name" TextAtomType,
1497+ Attribute "attributes" (RelationAtomType subrelAttrs)]
1498+ relVars = relationVariables ctx
1499+ mkRvDesc (rvName, gfExpr) = do
1500+ let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph
1501+ gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
1502+ pure (rvName, gfType)
1503+ relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]
1504+ attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]
1505+ attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of
1506+ Left err -> error ("relationVariablesAsRelation pooped " ++ show err)
1507+ Right rel -> RelationAtom rel
1508+ rvs <- mapM mkRvDesc (M.toList relVars)
1509+ let tups = map relVarToAtomList rvs
1510+ mkRelationFromList attrs tups
1512+-- | An unoptimized variant of evalGraphRefRelationalExpr for testing.
1513+evalRelationalExpr :: RelationalExpr -> RelationalExprM Relation
1514+evalRelationalExpr expr = do
1516+ context <- reContext
1517+ let expr' = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)
1518+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
1519+ case runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr expr') of
1520+ Left err -> throwError err
1521+ Right rel -> pure rel
1524+relVarByName :: RelVarName -> GraphRefRelationalExprM GraphRefRelationalExpr
1526+ relvars <- relationVariables <$> getStateContext
1527+ case M.lookup relVarName relvars of
1528+ Nothing -> dbErr (RelVarNotDefinedError relVarName)
1529+ Just gfexpr -> pure gfExpr
1532+class (MonadError RelationalError m, Monad m) => DatabaseContextM m where
1533+ getContext :: m DatabaseContext
1535+instance DatabaseContextM (ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity)) where
1536+ getContext = gfDatabaseContextForMarker UncommittedContextMarker
1538+instance DatabaseContextM (RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity)) where
1539+ getContext = getStateContext
1541+relVarByName :: DatabaseContextM m => RelVarName -> m GraphRefRelationalExpr
1542+relVarByName rvName = do
1543+ relvars <- relationVariables <$> getContext
1544+ case M.lookup rvName relvars of
1545+ Nothing -> throwError (RelVarNotDefinedError rvName)
1546+ Just gfexpr -> pure gfexpr
1548+-- | resolve UncommittedTransactionMarker whenever possible- this is important in the DatabaseContext in order to mitigate self-referencing loops for updates
1549+class ResolveGraphRefTransactionMarker a where
1550+ resolve :: a -> DatabaseContextEvalMonad a
1553+instance ResolveGraphRefTransactionMarker GraphRefRelationalExpr where
1554+ resolve (MakeRelationFromExprs mAttrs tupleExprs) =
1555+ MakeRelationFromExprs mAttrs <$> resolve tupleExprs
1556+ resolve orig@MakeStaticRelation{} = pure orig
1557+ resolve orig@ExistingRelation{} = pure orig
1558+ resolve orig@(RelationVariable rvName UncommittedContextMarker) = do
1559+ rvMap <- relationVariables <$> getStateContext
1560+ case M.lookup rvName rvMap of
1561+ Nothing -> pure orig
1562+ Just resolvedRv -> resolve resolvedRv
1563+ resolve orig@RelationVariable{} = pure orig
1564+ resolve (Project attrNames relExpr) = Project <$> resolve attrNames <*> resolve relExpr
1565+ resolve (Union exprA exprB) = Union <$> resolve exprA <*> resolve exprB
1566+ resolve (Join exprA exprB) = Join <$> resolve exprA <*> resolve exprB
1567+ resolve (Rename attrA attrB expr) = Rename attrA attrB <$> resolve expr
1568+ resolve (Difference exprA exprB) = Difference <$> resolve exprA <*> resolve exprB
1569+ resolve (Group namesA nameB expr) = Group <$> resolve namesA <*> pure nameB <*> resolve expr
1570+ resolve (Ungroup nameA expr) = Ungroup nameA <$> resolve expr
1571+ resolve (Restrict restrictExpr relExpr) = Restrict <$> resolve restrictExpr <*> resolve relExpr
1572+ resolve (Equals exprA exprB) = Equals <$> resolve exprA <*> resolve exprB
1573+ resolve (NotEquals exprA exprB) = NotEquals <$> resolve exprA <*> resolve exprB
1574+ resolve (Extend extendExpr relExpr) = Extend <$> resolve extendExpr <*> resolve relExpr
1575+ resolve (With withExprs relExpr) = With <$> mapM (\(nam, expr) -> (,) <$> resolve nam <*> resolve expr) withExprs <*> resolve relExpr
1577+instance ResolveGraphRefTransactionMarker GraphRefTupleExprs where
1578+ resolve (TupleExprs marker tupleExprs) =
1579+ TupleExprs marker <$> mapM resolve tupleExprs
1581+instance ResolveGraphRefTransactionMarker GraphRefTupleExpr where
1582+ resolve (TupleExpr tupMap) = do
1583+ tupMap' <- mapM (\(attrName, expr) -> (,) attrName <$> resolve expr ) (M.toList tupMap)
1584+ pure (TupleExpr (M.fromList tupMap'))
1586+instance ResolveGraphRefTransactionMarker GraphRefAttributeNames where
1587+ resolve orig@AttributeNames{} = pure orig
1588+ resolve orig@InvertedAttributeNames{} = pure orig
1589+ resolve (UnionAttributeNames namesA namesB) = UnionAttributeNames <$> resolve namesA <*> resolve namesB
1590+ resolve (IntersectAttributeNames namesA namesB) = IntersectAttributeNames <$> resolve namesA <*> resolve namesB
1591+ resolve (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> resolve expr
1593+instance ResolveGraphRefTransactionMarker GraphRefRestrictionPredicateExpr where
1594+ resolve TruePredicate = pure TruePredicate
1595+ resolve (AndPredicate exprA exprB) = AndPredicate <$> resolve exprA <*> resolve exprB
1596+ resolve (OrPredicate exprA exprB) = OrPredicate <$> resolve exprA <*> resolve exprB
1597+ resolve (NotPredicate expr) = NotPredicate <$> resolve expr
1598+ resolve (RelationalExprPredicate expr) = RelationalExprPredicate <$> resolve expr
1599+ resolve (AtomExprPredicate expr) = AtomExprPredicate <$> resolve expr
1600+ resolve (AttributeEqualityPredicate nam expr)= AttributeEqualityPredicate nam <$> resolve expr
1602+instance ResolveGraphRefTransactionMarker GraphRefExtendTupleExpr where
1603+ resolve (AttributeExtendTupleExpr nam atomExpr) = AttributeExtendTupleExpr nam <$> resolve atomExpr
1605+instance ResolveGraphRefTransactionMarker GraphRefWithNameExpr where
1606+ resolve orig@WithNameExpr{} = pure orig -- match uncommitted marker?
1608+instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where
1609+ resolve orig@AttributeAtomExpr{} = pure orig
1610+ resolve orig@NakedAtomExpr{} = pure orig
1611+ resolve (FunctionAtomExpr nam atomExprs marker) =
1612+ FunctionAtomExpr nam <$> mapM resolve atomExprs <*> pure marker
1613+ resolve (RelationAtomExpr expr) = RelationAtomExpr <$> resolve expr
1614+ resolve (ConstructedAtomExpr dConsName atomExprs marker) =
1615+ ConstructedAtomExpr dConsName <$> mapM resolve atomExprs <*> pure marker