@@ -1,34 +1,50 @@
11{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FlexibleContexts #-}
24module ProjectM36.RelationalExpression where
35import ProjectM36.Relation
46import ProjectM36.Tuple
57import ProjectM36.TupleSet
68import ProjectM36.Base
9+import qualified Data.UUID as U
710import ProjectM36.Error
811import ProjectM36.AtomType
9−import ProjectM36.Attribute (emptyAttributes)
12+import ProjectM36.Attribute (emptyAttributes, attributesFromList)
1013import ProjectM36.ScriptSession
1114import ProjectM36.DataTypes.Primitive
1215import ProjectM36.AtomFunction
1316import ProjectM36.DatabaseContextFunction
1417import ProjectM36.Arbitrary
18+import ProjectM36.GraphRefRelationalExpr
19+import ProjectM36.Transaction
1520import qualified ProjectM36.Attribute as A
1621import qualified Data.Map as M
1722import qualified Data.HashSet as HS
1823import qualified Data.Set as S
1924import Control.Monad.State hiding (join)
20−import Control.Exception
25+import Data.Bifunctor (second)
2126import Data.Maybe
2227import Data.Either
2328import Data.Char (isUpper)
29+import Data.Time
30+import qualified Data.List.NonEmpty as NE
31+import Data.Functor.Identity
2432import qualified Data.Text as T
2533import qualified Data.Vector as V
2634import qualified ProjectM36.TypeConstructorDef as TCD
27−import Control.Monad.Trans.Except
28−import Control.Monad.Trans.Reader
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)
38+import Control.Monad.Trans.Except (except)
39+import Control.Monad.Reader as R hiding (join)
40+import ProjectM36.NormalizeExpr
41+import ProjectM36.WithNameExpr
2942import Test.QuickCheck
30−import GHC
43+#ifdef PM36_HASKELL_SCRIPTING
44+import GHC hiding (getContext)
45+import Control.Exception
3146import GHC.Paths
47+#endif
3248
3349data DatabaseContextExprDetails = CountUpdatedTuples
3450
@@ -45,32 +61,63 @@ databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTu
4561 Right ts -> ts
4662
4763-- | Used to start a fresh database state for a new database context expression.
48−freshDatabaseState :: DatabaseContext -> DatabaseStateElems
49−freshDatabaseState ctx = (ctx, M.empty, False) --future work: propagate return accumulator
64+mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
65+mkDatabaseContextEvalState context = DatabaseContextEvalState {
66+ dbc_context = context,
67+ dbc_accum = M.empty,
68+ dbc_dirty = False
69+ } --future work: propagate return accumulator
5070
5171-- 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
53− RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
54− RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation
55−
56−instance Show RelationalExprStateElems where
57− show (RelationalExprStateTupleElems _ tup) = "RelationalExprStateTupleElems " ++ show tup
58− show (RelationalExprStateAttrsElems _ attrs) = "RelationalExprStateAttrsElems" ++ show attrs
59− show (RelationalExprStateElems _) = "RelationalExprStateElems"
60−
61−mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems
62−mkRelationalExprState = RelationalExprStateElems
63−
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)
72+data RelationalExprEnv = RelationalExprEnv {
73+ re_context :: DatabaseContext,
74+ re_graph :: TransactionGraph,
75+ re_extra :: Maybe (Either RelationTuple Attributes)
76+ }
77+
78+envTuple :: GraphRefRelationalExprEnv -> RelationTuple
79+envTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (gre_extra e))
80+
81+envAttributes :: GraphRefRelationalExprEnv -> Attributes
82+envAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (gre_extra e))
6983
70−mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprStateElems -> RelationalExprStateElems
71−mergeAttributesIntoRelationalExprState attrs (RelationalExprStateElems ctx) = RelationalExprStateAttrsElems ctx attrs
72−mergeAttributesIntoRelationalExprState _ st@(RelationalExprStateTupleElems _ _) = st
73−mergeAttributesIntoRelationalExprState attrsIn (RelationalExprStateAttrsElems ctx attrs) = RelationalExprStateAttrsElems ctx (A.union attrsIn attrs)
84+instance Show RelationalExprEnv where
85+ show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)
86+
87+--used to eval relationalexpr
88+type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a
89+
90+runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either RelationalError a
91+runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))
92+
93+reGraph :: RelationalExprM TransactionGraph
94+reGraph = asks re_graph
95+
96+reContext :: RelationalExprM DatabaseContext
97+reContext = asks re_context
98+
99+mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv
100+mkRelationalExprEnv ctx graph =
101+ RelationalExprEnv
102+ { re_context = ctx,
103+ re_graph = graph,
104+ re_extra = Nothing }
105+
106+askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
107+askEnv = R.ask
108+
109+mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
110+mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =
111+ e{ gre_extra = new_elems }
112+ where
113+ new_elems = Just (Left newTuple)
114+ mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))
115+ newTuple = mkRelationTupleFromMap mergedTupMap
116+
117+mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
118+mergeAttributesIntoGraphRefRelationalExprEnv attrsIn e = e { gre_extra = newattrs }
119+ where
120+ newattrs = Just (Right (A.union attrsIn (envAttributes e)))
74121
75122type ResultAccumName = StringType
76123
@@ -80,36 +127,103 @@ data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,
80127 resultAccumResult :: Relation
81128 }
82129
83−type DatabaseStateElems = (DatabaseContext, M.Map ResultAccumName ResultAccum, DirtyFlag)
130+data DatabaseContextEvalState = DatabaseContextEvalState {
131+ dbc_context :: DatabaseContext, --new, alterable context for a new transaction
132+ dbc_accum :: M.Map ResultAccumName ResultAccum,
133+ dbc_dirty :: DirtyFlag
134+ }
84135
85−type DatabaseState a = State DatabaseStateElems a
136+data DatabaseContextEvalEnv = DatabaseContextEvalEnv
137+ { dce_transId :: TransactionId,
138+ dce_graph :: TransactionGraph
139+ }
86140
87−getStateContext :: DatabaseState DatabaseContext
88−getStateContext = do
89− (ctx,_, _) <- get
90− pure ctx
91−
92−putStateContext :: DatabaseContext -> DatabaseState ()
93−putStateContext ctx = do
94− (_, accum, _) <- get
95− put (ctx, accum, True)
141+mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
142+mkDatabaseContextEvalEnv = DatabaseContextEvalEnv
143+
144+type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a
145+
146+runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState
147+runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> execRWST m env freshEnv))
148+ where
149+ freshEnv = mkDatabaseContextEvalState ctx
150+
151+
152+dbcTransId :: DatabaseContextEvalMonad TransactionId
153+dbcTransId = dce_transId <$> RWS.ask
154+
155+dbcGraph :: DatabaseContextEvalMonad TransactionGraph
156+dbcGraph = dce_graph <$> RWS.ask
157+
158+dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
159+dbcRelationalExprEnv =
160+ mkRelationalExprEnv <$> getStateContext <*> dbcGraph
161+
162+getStateContext :: DatabaseContextEvalMonad DatabaseContext
163+getStateContext = gets dbc_context
164+
165+putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()
166+putStateContext ctx' = do
167+ s <- get
168+ put (s {dbc_context = ctx', dbc_dirty = True})
169+
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)
176+ }
96177
97−type RelationalExprState a = Reader RelationalExprStateElems a
178+type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a
179+
180+gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction
181+gfTransForId tid = do
182+ graph <- gfGraph
183+ lift $ except $ transactionForId tid graph
98184
99−stateElemsContext :: RelationalExprStateElems -> DatabaseContext
100−stateElemsContext (RelationalExprStateTupleElems ctx _) = ctx
101−stateElemsContext (RelationalExprStateElems ctx) = ctx
102−stateElemsContext (RelationalExprStateAttrsElems ctx _) = ctx
185+gfDatabaseContextForMarker :: GraphRefTransactionMarker -> GraphRefRelationalExprM DatabaseContext
186+gfDatabaseContextForMarker (TransactionMarker transId) = concreteDatabaseContext <$> gfTransForId transId
187+gfDatabaseContextForMarker UncommittedContextMarker = do
188+ mctx <- gre_context <$> askEnv
189+ case mctx of
190+ Nothing -> throwError NoUncommittedContextInEvalError
191+ Just ctx -> pure ctx
103192
104−setStateElemsContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
105−setStateElemsContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
106−setStateElemsContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
107−setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
193+runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a
194+runGraphRefRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))
108195
196+freshGraphRefRelationalExprEnv :: Maybe DatabaseContext -> TransactionGraph -> GraphRefRelationalExprEnv
197+freshGraphRefRelationalExprEnv mctx graph = GraphRefRelationalExprEnv {
198+ gre_context = mctx,
199+ gre_graph = graph,
200+ gre_extra = Nothing
201+ }
202+
203+gfGraph :: GraphRefRelationalExprM TransactionGraph
204+gfGraph = asks gre_graph
205+
206+envContext :: RelationalExprEnv -> DatabaseContext
207+envContext = re_context
208+
209+setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv
210+setEnvContext e ctx = e { re_context = ctx }
211+
212+{-
213+--full evaluation down the graph
214+eval :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
215+eval expr = do
216+ env <- askEnv
217+ eGfExpr <- processRelationalExpr expr
218+ case eGfExpr of
219+ Left err -> pure (Left err)
220+ Right gfExpr -> pure $ evalGraphRefRelationalExpr gfExpr (re_graph env)
221+-}
222+{-
109223--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)
111225evalRelationalExpr (RelationVariable name _) = do
112− relvarTable <- fmap (relationVariables . stateElemsContext) ask
226+ relvarTable <- fmap (relationVariables . envContext) askEnv
113227 return $ case M.lookup name relvarTable of
114228 Just res -> Right res
115229 Nothing -> Left $ RelVarNotDefinedError name
@@ -121,7 +235,7 @@ evalRelationalExpr (Project attrNames expr) = do
121235 Right attrNameSet -> do
122236 rel <- evalRelationalExpr expr
123237 case rel of
124− Right rel2 -> pure $ project attrNameSet rel2
238+ Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)
125239 Left err -> pure $ Left err
126240
127241evalRelationalExpr (Union exprA exprB) = do
@@ -131,7 +245,7 @@ evalRelationalExpr (Union exprA exprB) = do
131245 Left err -> return $ Left err
132246 Right relA2 -> case relB of
133247 Left err -> return $ Left err
134− Right relB2 -> return $ union relA2 relB2
248+ Right relB2 -> return $ Right (Union relA2 relB2)
135249
136250evalRelationalExpr (Join exprA exprB) = do
137251 relA <- evalRelationalExpr exprA
@@ -140,7 +254,7 @@ evalRelationalExpr (Join exprA exprB) = do
140254 Left err -> return $ Left err
141255 Right relA2 -> case relB of
142256 Left err -> return $ Left err
143− Right relB2 -> return $ join relA2 relB2
257+ Right relB2 -> return $ Right (Join relA2 relB2)
144258
145259evalRelationalExpr (Difference exprA exprB) = do
146260 relA <- evalRelationalExpr exprA
@@ -149,33 +263,34 @@ evalRelationalExpr (Difference exprA exprB) = do
149263 Left err -> return $ Left err
150264 Right relA2 -> case relB of
151265 Left err -> return $ Left err
152− Right relB2 -> return $ difference relA2 relB2
266+ Right relB2 -> return $ Right (Difference relA2 relB2)
153267
154268evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
155269 case mkRelation attributeSet tupleSet of
156− Right rel -> return $ Right rel
270+ Right rel -> return $ Right (ExistingRelation rel)
157271 Left err -> return $ Left err
158272
159273evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
160− currentContext <- fmap stateElemsContext ask
274+ currentContext <- fmap envContext askEnv
161275 let tConss = typeConstructorMapping currentContext
162276 -- 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
163277 runExceptT $ do
164278 mAttrs <- case mAttrExprs of
165279 Just _ ->
166− Just . A.attributesFromList <$> mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)
280+ Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)
167281 Nothing -> pure Nothing
168282 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
169283 let attrs = fromMaybe firstTupleAttrs mAttrs
170284 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)
172287
173−evalRelationalExpr (ExistingRelation rel) = pure (Right rel)
288+evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))
174289
175290evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
176291 evald <- evalRelationalExpr relExpr
177292 case evald of
178− Right rel -> return $ rename oldAttrName newAttrName rel
293+ Right expr -> return $ Right (Rename oldAttrName newAttrName expr)
179294 Left err -> return $ Left err
180295
181296evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
@@ -185,324 +300,365 @@ evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
185300 Right oldAttrNameSet -> do
186301 evald <- evalRelationalExpr relExpr
187302 case evald of
188− Right rel -> return $ group oldAttrNameSet newAttrName rel
303+ Right expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)
189304 Left err -> return $ Left err
190305
191306evalRelationalExpr (Ungroup attrName relExpr) = do
192307 evald <- evalRelationalExpr relExpr
193308 case evald of
194− Right rel -> return $ ungroup attrName rel
309+ Right expr -> return $ Right (Ungroup attrName expr)
195310 Left err -> return $ Left err
196311
197312evalRelationalExpr (Restrict predicateExpr relExpr) = do
198313 evald <- evalRelationalExpr relExpr
314+ pred <- processRestrictionPredicateExpr predicateExpr
199315 case evald of
200316 Left err -> return $ Left err
201− Right rel -> do
202− eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr
203− case eFilterFunc of
204− Left err -> return $ Left err
205− Right filterfunc ->
206− pure (restrict filterfunc rel)
317+ Right expr ->
318+ pure $ Right (Restrict pred expr)
207319
208320evalRelationalExpr (Equals relExprA relExprB) = do
209321 evaldA <- evalRelationalExpr relExprA
210322 evaldB <- evalRelationalExpr relExprB
211323 case evaldA of
212324 Left err -> return $ Left err
213− Right relA -> case evaldB of
325+ Right exprA -> case evaldB of
214326 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)
328+{-
329+evalRelationalExpr (With views mainExpr) = do
330+ rstate <- ask
331+
332+ let addScopedView ctx (vname,vexpr) = if vname `M.member` relationVariables ctx then
333+ Left (RelVarAlreadyDefinedError vname)
334+ else
335+ case runState (evalDatabaseContextExpr (Assign vname vexpr)) (freshDatabaseState ctx) of
336+ (Left err,_) -> Left err
337+ (Right (), (ctx',_,_)) -> Right ctx'
216338
339+ case foldM addScopedView (stateElemsContext rstate) views of
340+ Left err -> return $ Left err
341+ Right ctx'' -> do
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
346+-}
217347--warning: copy-pasta from above- refactor
218348evalRelationalExpr (NotEquals relExprA relExprB) = do
219349 evaldA <- evalRelationalExpr relExprA
220350 evaldB <- evalRelationalExpr relExprB
221351 case evaldA of
222352 Left err -> return $ Left err
223− Right relA -> case evaldB of
353+ Right exprA -> case evaldB of
224354 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)
226356
227357-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
228358evalRelationalExpr (Extend tupleExpression relExpr) = do
229− rstate <- ask
230− let evald = runReader (evalRelationalExpr relExpr) rstate
231− case evald of
359+ eExpr <- evalRelationalExpr relExpr
360+ case eExpr of
232361 Left err -> pure (Left err)
233− Right rel -> do
234− tupProc <- extendTupleExpressionProcessor rel tupleExpression
235− case tupProc of
236− Left err -> pure (Left err)
237− Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel
238−
362+ Right expr -> do
363+ tupProc <- processExtendTupleExpr tupleExpression
364+ pure (Right (Extend tupProc expr))
365+-}
239366--helper function to process relation variable creation/assignment
240−setRelVar :: RelVarName -> Relation -> DatabaseState (Either RelationalError ())
241−setRelVar relVarName rel = do
367+setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
368+setRelVar relVarName relExpr = do
242369 currentContext <- getStateContext
243− let newRelVars = M.insert relVarName rel $ relationVariables currentContext
370+ --prevent recursive relvar definition by resolving references to relvars in previous states
371+ relExpr' <- resolve relExpr
372+ let newRelVars = M.insert relVarName relExpr' $ relationVariables currentContext
244373 potentialContext = currentContext { relationVariables = newRelVars }
245−
246− case checkConstraints potentialContext of
247− Left err -> pure (Left err)
248− Right _ -> do
249− putStateContext potentialContext
250− return (Right ())
374+ --optimization: if the relexpr is unchanged, skip the update
375+ if M.lookup relVarName (relationVariables currentContext) == Just relExpr then
376+ pure ()
377+ else do
378+ --determine when to check constraints
379+ graph <- dbcGraph
380+ tid <- dbcTransId
381+ case checkConstraints potentialContext tid graph of
382+ Left err -> dbErr err
383+ Right _ -> putStateContext potentialContext
251384
252385-- 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 ()
254387deleteRelVar relVarName = do
255388 currContext <- getStateContext
256389 let relVars = relationVariables currContext
257390 if M.notMember relVarName relVars then
258− pure (Right ())
391+ pure ()
259392 else do
260393 let newRelVars = M.delete relVarName relVars
261394 newContext = currContext { relationVariables = newRelVars }
262395 putStateContext newContext
263− pure (Right ())
396+ pure ()
264397
265−evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Either RelationalError ())
266−evalDatabaseContextExpr NoOperation = pure (Right ())
398+evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
399+evalGraphRefDatabaseContextExpr NoOperation = pure ()
267400
268−evalDatabaseContextExpr (Define relVarName attrExprs) = do
401+evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do
402+ context <- getStateContext
269403 relvars <- fmap relationVariables getStateContext
270404 tConss <- fmap typeConstructorMapping getStateContext
271− let eAttrs = map (evalAttrExpr tConss) attrExprs
272− attrErrs = lefts eAttrs
273− attrsList = rights eAttrs
274− if not (null attrErrs) then
275− pure (Left (someErrors attrErrs))
276− else do
277− let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList
278− if not (null atomTypeErrs) then
279− pure (Left (someErrors atomTypeErrs))
280− else
281− case M.member relVarName relvars of
282− True -> pure (Left (RelVarAlreadyDefinedError relVarName))
283− False -> setRelVar relVarName emptyRelation >> pure (Right ())
405+ graph <- dbcGraph
406+ let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)
407+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
408+ case eAttrs of
409+ Left err -> dbErr err
410+ Right attrsList -> do
411+ lift $ except $ validateAttributes tConss (A.attributesFromList attrsList)
412+ case M.member relVarName relvars of
413+ True -> dbErr (RelVarAlreadyDefinedError relVarName)
414+ False -> setRelVar relVarName (ExistingRelation emptyRelation)
284415 where
285416 attrs = A.attributesFromList attrsList
286417 emptyRelation = Relation attrs emptyTupleSet
287418
288−evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
419+evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
289420
290−evalDatabaseContextExpr (Assign relVarName expr) = do
291− -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
421+evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do
422+ graph <- re_graph <$> dbcRelationalExprEnv
292423 context <- getStateContext
293− let existingRelVar = M.lookup relVarName relVarTable
294− relVarTable = relationVariables context
295− value = runReader (evalRelationalExpr expr) (RelationalExprStateElems context)
296− case value of
297− Left err -> pure (Left err)
298− Right rel -> case existingRelVar of
299− Nothing -> setRelVar relVarName rel
300− Just existingRel -> let expectedAttributes = attributes existingRel
301− foundAttributes = attributes rel in
302− if A.attributesEqual expectedAttributes foundAttributes then
303− setRelVar relVarName rel
304− else
305− pure (Left (RelationTypeMismatchError expectedAttributes foundAttributes))
306−
307−evalDatabaseContextExpr (Insert relVarName relExpr) = do
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)
313− case unioned of
314− Left err -> pure (Left err)
315− Right unioned' -> case origRel of
316− Left err -> pure (Left err)
317− Right origRel' -> if cardinality unioned' == cardinality origRel' then --no tuples actually inserted
318− pure (Right ())
319− else
320− evalDatabaseContextExpr $ Assign relVarName (ExistingRelation unioned')
424+ let existingRelVar = M.lookup relVarName (relationVariables context)
425+ reEnv = freshGraphRefRelationalExprEnv (Just context) graph
426+ eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)
427+ case existingRelVar of
428+ Nothing -> do
429+ case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of
430+ Left err -> dbErr err
431+ Right reltype -> do
432+ lift $ except $ validateAttributes (typeConstructorMapping context) (attributes reltype)
433+ setRelVar relVarName expr
434+ Just existingRel -> do
435+ let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)
436+ case eExpectedType of
437+ Left err -> dbErr err
438+ Right expectedType ->
439+ case eNewExprType of
440+ Left err -> dbErr err
441+ Right newExprType -> do
442+ if newExprType == expectedType then do
443+ lift $ except $ validateAttributes (typeConstructorMapping context) (attributes newExprType)
444+ setRelVar relVarName expr
445+ else
446+ dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))
321447
322−evalDatabaseContextExpr (Delete relVarName predicate) = do
323− context <- getStateContext
324− let rv = RelationVariable relVarName ()
325− let updatedRel = runReader (evalRelationalExpr (Restrict (NotPredicate predicate) rv)) (RelationalExprStateElems context)
326− origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)
327− case updatedRel of
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
332− pure (Right ())
333− else
334− setRelVar relVarName updatedRel'
448+evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do
449+ gfExpr <- relVarByName relVarName
450+ evalGraphRefDatabaseContextExpr (Assign relVarName
451+ (Union
452+ gfExpr
453+ relExpr))
335454
455+evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do
456+ gfExpr <- relVarByName relVarName
457+ setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)
458+
336459--union of restricted+updated portion and the unrestricted+unupdated portion
337−evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do
338− context <- getStateContext
339− let relVarTable = relationVariables context
340− case M.lookup relVarName relVarTable of
341− Nothing -> pure (Left (RelVarNotDefinedError relVarName))
342− Just rel ->
343− case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of
344− Left err -> pure (Left err)
345− Right predicateFunc -> do
346− let ret = do
347− restrictedPortion <- restrict predicateFunc rel
348− if cardinality restrictedPortion == Finite 0 then
349− pure Nothing
350− else do
351− unrestrictedPortion <- restrict (predicateFunc >=> (pure . not)) rel
352− updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion
353− updatedRel <- updatedPortion `union` unrestrictedPortion
354− pure (Just updatedRel)
355− case ret of
356− Left err -> pure (Left err)
357− Right Nothing -> pure (Right ())
358− Right (Just updatedRel) -> setRelVar relVarName updatedRel
460+evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do
461+ rvExpr <- relVarByName relVarName
462+ let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr
463+ tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict
464+ updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)
465+ projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
466+ restrictedPortion = Restrict pred' rvExpr
467+ updated = foldr (\(oldname, atomExpr) accum ->
468+ let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in
469+ updateAttr oldname procAtomExpr accum
470+ ) restrictedPortion (M.toList atomExprMap)
471+ -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
472+ updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)
473+ setRelVar relVarName (Union unrestrictedPortion updatedPortion)
359474
360−evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
475+evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
361476 currContext <- getStateContext
477+ transId <- dbcTransId
478+ graph <- dbcGraph
362479 let currDeps = inclusionDependencies currContext
363480 newDeps = M.insert newDepName newDep currDeps
364481 if M.member newDepName currDeps then
365− pure (Left (InclusionDependencyNameInUseError newDepName))
482+ dbErr (InclusionDependencyNameInUseError newDepName)
366483 else do
367484 let potentialContext = currContext { inclusionDependencies = newDeps }
368− case checkConstraints potentialContext of
369− Left err -> pure (Left err)
370− Right _ -> do
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
487+ case checkConstraints potentialContext transId graph of
488+ Left err -> dbErr err
489+ Right _ ->
371490 putStateContext potentialContext
372− return (Right ())
373491
374−evalDatabaseContextExpr (RemoveInclusionDependency depName) = do
492+evalGraphRefDatabaseContextExpr (RemoveInclusionDependency depName) = do
375493 currContext <- getStateContext
376494 let currDeps = inclusionDependencies currContext
377495 newDeps = M.delete depName currDeps
378496 if M.notMember depName currDeps then
379− pure (Left (InclusionDependencyNameNotInUseError depName))
380− else do
497+ dbErr (InclusionDependencyNameNotInUseError depName)
498+ else
381499 putStateContext $ currContext {inclusionDependencies = newDeps }
382− return (Right ())
383500
384501-- | 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
386503 currentContext <- getStateContext
387504 let nots = notifications currentContext
388505 if M.member notName nots then
389− pure (Left (NotificationNameInUseError notName))
506+ dbErr (NotificationNameInUseError notName)
390507 else do
391508 let newNotifications = M.insert notName newNotification nots
392509 newNotification = Notification { changeExpr = triggerExpr,
393510 reportOldExpr = resultOldExpr,
394511 reportNewExpr = resultNewExpr}
395512 putStateContext $ currentContext { notifications = newNotifications }
396− return (Right ())
397513
398−evalDatabaseContextExpr (RemoveNotification notName) = do
514+evalGraphRefDatabaseContextExpr (RemoveNotification notName) = do
399515 currentContext <- getStateContext
400516 let nots = notifications currentContext
401517 if M.notMember notName nots then
402− pure (Left (NotificationNameNotInUseError notName))
518+ dbErr (NotificationNameNotInUseError notName)
403519 else do
404520 let newNotifications = M.delete notName nots
405521 putStateContext $ currentContext { notifications = newNotifications }
406− pure (Right ())
522+
407523
408524-- | Adds type and data constructors to the database context.
409525-- validate that the type *and* constructor names are unique! not yet implemented!
410−evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
526+evalGraphRefDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
411527 currentContext <- getStateContext
412528 let oldTypes = typeConstructorMapping currentContext
413529 tConsName = TCD.name tConsDef
414530 -- validate that the constructor's types exist
415− case validateTypeConstructorDef tConsDef dConsDefList of
416− errs@(_:_) -> pure (Left (someErrors errs))
417− [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName))
418− | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName))
531+ case validateTypeConstructorDef tConsDef dConsDefList oldTypes of
532+ Left err -> throwError err
533+ Right () | T.null tConsName || not (isUpper (T.head tConsName)) -> dbErr (InvalidAtomTypeName tConsName)
534+ | isJust (findTypeConstructor tConsName oldTypes) -> dbErr (AtomTypeNameInUseError tConsName)
419535 | otherwise -> do
420536 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
421537 putStateContext $ currentContext { typeConstructorMapping = newTypes }
422− pure (Right ())
423538
424539-- | 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
426541 currentContext <- getStateContext
427542 let oldTypes = typeConstructorMapping currentContext
428543 if isNothing (findTypeConstructor tConsName oldTypes) then
429− pure (Left (AtomTypeNameNotInUseError tConsName))
544+ dbErr (AtomTypeNameNotInUseError tConsName)
430545 else do
431546 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
432547 putStateContext $ currentContext { typeConstructorMapping = newTypes }
433− pure (Right ())
434548
435−evalDatabaseContextExpr (MultipleExpr exprs) = do
549+evalGraphRefDatabaseContextExpr (MultipleExpr exprs) =
436550 --the multiple expressions must pass the same context around- not the old unmodified context
437− evald <- forM exprs evalDatabaseContextExpr
438− --some lifting magic needed here
439− case lefts evald of
440− [] -> pure (Right ())
441− errs -> pure (Left (someErrors errs))
442−
443−evalDatabaseContextExpr (RemoveAtomFunction funcName) = do
551+ mapM_ evalGraphRefDatabaseContextExpr exprs
552+
553+evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do
444554 currentContext <- getStateContext
445555 let atomFuncs = atomFunctions currentContext
446556 case atomFunctionForName funcName atomFuncs of
447− Left err -> pure (Left err)
448− Right realFunc -> if isScriptedAtomFunction realFunc then do
449− let updatedFuncs = HS.delete realFunc atomFuncs
450− putStateContext (currentContext {atomFunctions = updatedFuncs })
451− pure (Right ())
452− else
453− pure (Left (PrecompiledFunctionRemoveError funcName))
557+ Left err -> dbErr err
558+ Right realFunc ->
559+ if isScriptedAtomFunction realFunc then do
560+ let updatedFuncs = HS.delete realFunc atomFuncs
561+ putStateContext (currentContext {atomFunctions = updatedFuncs })
562+ else
563+ dbErr (PrecompiledFunctionRemoveError funcName)
454564
455−evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
565+evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
456566 context <- getStateContext
457567 let dbcFuncs = dbcFunctions context
458568 case databaseContextFunctionForName funcName dbcFuncs of
459− Left err -> pure (Left err)
460− Right realFunc -> if isScriptedDatabaseContextFunction realFunc then do
461− let updatedFuncs = HS.delete realFunc dbcFuncs
462− putStateContext (context { dbcFunctions = updatedFuncs })
463− pure (Right ())
464− else
465− pure (Left (PrecompiledFunctionRemoveError funcName))
569+ Left err -> dbErr err
570+ Right realFunc ->
571+ if isScriptedDatabaseContextFunction realFunc then do
572+ let updatedFuncs = HS.delete realFunc dbcFuncs
573+ putStateContext (context { dbcFunctions = updatedFuncs })
574+ else
575+ dbErr (PrecompiledFunctionRemoveError funcName)
466576
467−evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
577+evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
468578 context <- getStateContext
579+ graph <- dbcGraph
469580 --resolve atom arguments
470− let relExprState = mkRelationalExprState context
471− eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs
581+ let eAtomTypes = mapM (runGraphRefRelationalExprM gfEnv . typeForGraphRefAtomExpr emptyAttributes) atomArgExprs
472582 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
583+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
473584 case eFunc of
474− Left err -> pure (Left err)
585+ Left err -> dbErr err
475586 Right func -> do
476587 let expectedArgCount = length (dbcFuncType func)
477588 actualArgCount = length atomArgExprs
478589 if expectedArgCount /= actualArgCount then
479− pure (Left (FunctionArgumentCountMismatchError expectedArgCount actualArgCount))
590+ dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
480591 else
481592 --check that the atom types are valid
482− case lefts eAtomTypes of
483− _:_ -> pure (Left (someErrors (lefts eAtomTypes)))
484− [] -> do
485− let atomTypes = rights eAtomTypes
486− let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of
487− Left err -> Just err
488− Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)
489− typeErrors = catMaybes mValidTypes
490− eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
593+ case eAtomTypes of
594+ Left err -> dbErr err
595+ Right atomTypes -> do
596+ let mValidTypes = zipWith (\ expType actType
597+ -> case atomTypeVerify expType actType of
598+ Left err -> Just err
599+ Right _ -> Nothing)
600+ (dbcFuncType func) atomTypes
601+ typeErrors = catMaybes mValidTypes
602+ eAtomArgs = map (runGraphRefRelationalExprM gfEnv . evalGraphRefAtomExpr emptyTuple) atomArgExprs
491603 if length (lefts eAtomArgs) > 1 then
492− pure (Left (someErrors (lefts eAtomArgs)))
604+ dbErr (someErrors (lefts eAtomArgs))
493605 else if not (null typeErrors) then
494− pure (Left (someErrors typeErrors))
606+ dbErr (someErrors typeErrors)
495607 else
496608 case evalDatabaseContextFunction func (rights eAtomArgs) context of
497− Left err -> pure (Left err)
498− Right newContext -> putStateContext newContext >> pure (Right ())
499−
500−evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
501−evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) =
502− case mScriptSession of
503− Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
504− Just scriptSession -> do
505− res <- try $ runGhc (Just libdir) $ do
609+ Left err -> dbErr err
610+ Right newContext -> putStateContext newContext
611+data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv
612+ { dbcio_transId :: TransactionId,
613+ dbcio_graph :: TransactionGraph,
614+ dbcio_mScriptSession :: Maybe ScriptSession
615+ }
616+
617+type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a
618+
619+runDatabaseContextIOEvalMonad :: DatabaseContextIOEvalEnv -> DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ()) -> IO (Either RelationalError DatabaseContextEvalState)
620+runDatabaseContextIOEvalMonad env ctx m = do
621+ res <- runRWST m env freshState
622+ case res of
623+ (Left err,_,_) -> pure (Left err)
624+ (Right (),s,_) -> pure (Right s)
625+ where
626+ freshState = mkDatabaseContextEvalState ctx
627+
628+requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)
629+requireScriptSession = do
630+ env <- RWS.ask
631+ case dbcio_mScriptSession env of
632+ Nothing -> pure $ Left $ ScriptError ScriptCompilationDisabledError
633+ Just ss -> pure (Right ss)
634+
635+putDBCIOContext :: DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ())
636+putDBCIOContext ctx = do
637+ RWS.modify (\dbstate -> dbstate { dbc_context = ctx})
638+ pure (Right ())
639+
640+getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
641+getDBCIOContext = dbc_context <$> RWS.get
642+
643+getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv
644+getDBCIORelationalExprEnv = do
645+ context <- getDBCIOContext
646+ mkRelationalExprEnv context . dbcio_graph <$> RWS.ask
647+
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))
654+#else
655+evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do
656+ eScriptSession <- requireScriptSession
657+ currentContext <- getDBCIOContext
658+ case eScriptSession of
659+ Left err -> pure (Left err)
660+ Right scriptSession -> do
661+ res <- liftIO $ try $ runGhc (Just libdir) $ do
506662 setSession (hscEnv scriptSession)
507663 let atomFuncs = atomFunctions currentContext
508664 case extractAtomFunctionType funcType of
@@ -528,12 +684,13 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam
528684 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
529685 Right eContext -> case eContext of
530686 Left err -> pure (Left err)
531− Right context' -> pure (Right context')
532−
533−evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) =
534− case mScriptSession of
535− Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
536− Just scriptSession -> do
687+ Right context' -> putDBCIOContext context'
688+evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do
689+ eScriptSession <- requireScriptSession
690+ currentContext <- getDBCIOContext
691+ case eScriptSession of
692+ Left err -> pure (Left err)
693+ Right scriptSession -> do
537694 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
538695 let last2Args = reverse (take 2 (reverse funcType))
539696 atomArgs = take (length funcType - 2) funcType
@@ -543,7 +700,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct
543700 if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
544701 pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
545702 else do
546− res <- try $ runGhc (Just libdir) $ do
703+ res <- liftIO $ try $ runGhc (Just libdir) $ do
547704 setSession (hscEnv scriptSession)
548705 eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
549706 pure $ case eCompiledFunc of
@@ -568,68 +725,98 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct
568725 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
569726 Right eContext -> case eContext of
570727 Left err -> pure (Left err)
571− Right context' -> pure (Right context')
572−evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do
573− eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
728+ Right context' -> putDBCIOContext context'
729+evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do
730+ currentContext <- getDBCIOContext
731+ eLoadFunc <- liftIO $ loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
574732 case eLoadFunc of
575733 Left LoadSymbolError -> pure (Left LoadFunctionError)
576734 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
577735 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
578− in pure (Right newContext)
579−evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName funcName modPath) = do
580− eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
736+ in putDBCIOContext newContext
737+evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName modPath) = do
738+ currentContext <- getDBCIOContext
739+ eLoadFunc <- liftIO $ loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
581740 case eLoadFunc of
582741 Left LoadSymbolError -> pure (Left LoadFunctionError)
583742 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
584743 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
585− in pure (Right newContext)
586−
587−evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =
744+ in putDBCIOContext newContext
745+#endif
746+evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do
588747 --Define
589− case runState ( evalDatabaseContextExpr (Define relVarName attrExprs)) (freshDatabaseState currentContext) of
590− (Left err,_) -> pure (Left err)
591− (Right (), elems@(ctx,_,_)) -> do
748+ currentContext <- getDBCIOContext
749+ env <- RWS.ask
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
755+ Left err -> pure (Left err)
756+ Right dbstate -> do
592757 --Assign
593758 let existingRelVar = M.lookup relVarName relVarTable
594− relVarTable = relationVariables ctx
759+ relVarTable = relationVariables (dbc_context dbstate)
595760 case existingRelVar of
596761 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
597762 Just existingRel -> do
598− let expectedAttributes = attributes existingRel
599− let tcMap = typeConstructorMapping ctx
600− eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
601− case eitherRel of
602− Left err -> pure $ Left err
603− Right rel ->
604− case runState (setRelVar relVarName rel) elems of
605− (Left err,_) -> pure (Left err)
606− (Right (), (ctx',_,_)) -> pure $ Right ctx'
607−
608−updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
609−updateTupleWithAtomExprs exprMap context tupIn = do
763+ let gfEnv = freshGraphRefRelationalExprEnv (Just currentContext) graph
764+ case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of
765+ Left err -> pure (Left err)
766+ Right relType -> do
767+ let expectedAttributes = attributes relType
768+ tcMap = typeConstructorMapping (dbc_context dbstate)
769+ eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
770+ case eitherRel of
771+ Left err -> pure $ Left err
772+ Right rel ->
773+ case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of
774+ Left err -> pure (Left err)
775+ Right dbstate' -> putDBCIOContext (dbc_context dbstate')
776+
777+{-
778+updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple
779+updateTupleWithAtomExprs exprMap context graph tupIn = do
610780 --resolve all atom exprs
781+ let
611782 atomsAssoc <- mapM (\(attrName, atomExpr) -> do
612− atom <- runReader (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
783+ let atom = unimplemented
784+ --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)
613785 pure (attrName, atom)
614786 ) (M.toList exprMap)
615787 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
616−
788+-}
617789--run verification on all constraints
618−checkConstraints :: DatabaseContext -> Either RelationalError ()
619−checkConstraints context = do
790+checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
791+checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
620792 mapM_ (uncurry checkIncDep) (M.toList deps)
621− pure ()
622793 where
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.:| [],
800+ stamp = tempStamp,
801+ merkleHash = mempty
802+ }
803+
623804 deps = inclusionDependencies context
624− eval expr = evalReader (evalRelationalExpr expr)
625− evalReader f = runReader f (RelationalExprStateElems context)
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
626806 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
807+ let process = runProcessExprM UncommittedContextMarker
808+ gfSubsetExpr = process (processRelationalExpr subsetExpr)
809+ gfSupersetExpr = process (processRelationalExpr supersetExpr)
627810 --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)
629− typeSuper <- evalReader (typeForRelationalExpr supersetExpr)
811+ let gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
812+ runGfRel = runGraphRefRelationalExprM gfEnv
813+ typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)
814+ typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)
630815 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
631− let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)
632− case eval checkExpr of
816+ let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
817+ gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)
818+ gfEnv' = freshGraphRefRelationalExprEnv (Just context) potentialGraph
819+ case gfEvald of
633820 Left err -> Left err
634821 Right resultRel -> if resultRel == relationTrue then
635822 pure ()
@@ -639,88 +826,90 @@ checkConstraints context = do
639826-- 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
640827-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
641828
642−typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
829+typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation
643830typeForRelationalExpr expr = do
644− rstate <- ask
645− let context = stateElemsContext rstate
646831 --replace the relationVariables context element with a cloned set of relation devoid of tuples
647− let context' = contextWithEmptyTupleSets context
648− rstate' = setStateElemsContext rstate context'
649− pure (runReader (evalRelationalExpr expr) rstate')
832+ --evalRelationalExpr could still return an existing relation with tuples, so strip them
833+ graph <- reGraph
834+ context <- reContext
835+ let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)
836+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph
837+ runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
838+ lift $ except runGf
650839
651840--returns a database context with all tuples removed
652841--this is useful for type checking and optimization
842+{-
653843contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
654844contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
655845 where
656− relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
846+ relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)
847+-}
657848
658849liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
659850liftE v = do
660851 y <- lift v
661852 case y of
662− Left err -> throwE err
853+ Left err -> throwError err
663854 Right val -> pure val
664855
665856{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
666−predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter)
667−predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =
668− runExceptT $ do
669− expr1v <- liftE (predicateRestrictionFilter attrs expr1)
670− expr2v <- liftE (predicateRestrictionFilter attrs expr2)
671− pure (\x -> do
672− ev1 <- expr1v x
673− ev2 <- expr2v x
674− pure (ev1 && ev2))
857+predicateRestrictionFilter :: Attributes -> GraphRefRestrictionPredicateExpr -> GraphRefRelationalExprM RestrictionFilter
858+predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do
859+ expr1v <- predicateRestrictionFilter attrs expr1
860+ expr2v <- predicateRestrictionFilter attrs expr2
861+ pure (\x -> do
862+ ev1 <- expr1v x
863+ ev2 <- expr2v x
864+ pure (ev1 && ev2))
675865
676−predicateRestrictionFilter attrs (OrPredicate expr1 expr2) =
677− runExceptT $ do
678− expr1v <- liftE (predicateRestrictionFilter attrs expr1)
679− expr2v <- liftE (predicateRestrictionFilter attrs expr2)
866+predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do
867+ expr1v <- predicateRestrictionFilter attrs expr1
868+ expr2v <- predicateRestrictionFilter attrs expr2
680869 pure (\x -> do
681870 ev1 <- expr1v x
682871 ev2 <- expr2v x
683872 pure (ev1 || ev2))
684873
685−predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))
874+predicateRestrictionFilter _ TruePredicate = pure (\_ -> pure True)
686875
687−predicateRestrictionFilter attrs (NotPredicate expr) =
688− runExceptT $ do
689− exprv <- liftE (predicateRestrictionFilter attrs expr)
690− pure (fmap not . exprv)
876+predicateRestrictionFilter attrs (NotPredicate expr) = do
877+ exprv <- predicateRestrictionFilter attrs expr
878+ pure (fmap not . exprv)
691879
692880--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
693881predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do
694− rstate <- ask
695− pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of
882+ renv <- askEnv
883+ let eval :: RelationTuple -> Either RelationalError Relation
884+ eval tup =
885+ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in
886+ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)
887+ pure (\tup -> case eval tup of
696888 Left err -> Left err
697889 Right rel -> if arity rel /= 0 then
698890 Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
699891 else
700− pure (rel == relationTrue)))
892+ pure (rel == relationTrue))
701893
702894predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
703− rstate <- ask
704− let (attrs', ctxtup') = case rstate of
705− RelationalExprStateElems _ -> (attrs, emptyTuple)
706− RelationalExprStateAttrsElems _ _ -> (attrs, emptyTuple)
707− RelationalExprStateTupleElems _ ctxtup -> (A.union attrs (tupleAttributes ctxtup), ctxtup)
708− runExceptT $ do
709− atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr)
710− attr <- either throwE pure $ case A.attributeForName attrName attrs of
895+ env <- askEnv
896+ let attrs' = A.union attrs (envAttributes env)
897+ ctxtup' = envTuple env
898+ atomExprType <- typeForGraphRefAtomExpr attrs' atomExpr
899+ attr <- lift $ except $ case A.attributeForName attrName attrs of
711900 Right attr -> Right attr
712901 Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of
713902 Right ctxattr -> Right ctxattr
714903 Left err2@(NoSuchAttributeNamesError _) -> Left err2
715904 Left err -> Left err
716905 Left err -> Left err
717− if atomExprType /= A.atomType attr then
718− throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
719− else
906+ if atomExprType /= A.atomType attr then
907+ throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
908+ else
720909 pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of
721910 Right atomCmp -> atomCmp == atomIn
722911 Left _ -> False
723− atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate
912+ atomEvald = runGraphRefRelationalExprM env (evalGraphRefAtomExpr tupleIn atomExpr)
724913 in
725914 pure $ case atomForAttributeName attrName tupleIn of
726915 Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of
@@ -731,48 +920,99 @@ predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr)
731920-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
732921predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
733922 --merge attrs into the state attributes
734− rstate <- ask
735− runExceptT $ do
736− aType <- liftE (typeFromAtomExpr attrs atomExpr)
737− if aType /= BoolAtomType then
738− throwE (AtomTypeMismatchError aType BoolAtomType)
739− else
923+ renv <- askEnv
924+ aType <- typeForGraphRefAtomExpr attrs atomExpr
925+ if aType /= BoolAtomType then
926+ throwError (AtomTypeMismatchError aType BoolAtomType)
927+ else
740928 pure (\tupleIn ->
741− pure $ case runReader (evalAtomExpr tupleIn atomExpr) rstate of
742− Left _ -> False
743− Right boolAtomValue -> boolAtomValue == BoolAtom True)
929+ case runGraphRefRelationalExprM renv (evalGraphRefAtomExpr tupleIn atomExpr) of
930+ Left err -> Left err
931+ Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))
744932
745933tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
746934tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then
747− Left (error "SPAMMIT" $ AttributeNameInUseError attrName)
935+ Left (AttributeNameInUseError attrName)
748936 else
749937 Right rel
750938
751−extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
752−extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
753− rstate <- ask
939+extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)
940+extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) =
941+-- renv <- askEnv
754942 -- check that the attribute name is not in use
755943 case tupleExprCheckNewAttrName newAttrName relIn of
756− Left err -> pure (Left err)
757− Right _ -> runExceptT $ do
758− atomExprType <- liftE (typeFromAtomExpr (attributes relIn) atomExpr)
759− atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)
944+ Left err -> throwError err
945+ Right _ -> do
946+ atomExprType <- typeForGraphRefAtomExpr (attributes relIn) atomExpr
947+ atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType
760948 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
761949 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
762− pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of
763− Left err -> Left err
764− Right atom -> Right (tupleAtomExtend newAttrName atom tup)
950+ env <- ask
951+ pure (newAndOldAttrs, \tup -> do
952+ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup env
953+ atom <- runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr tup atomExpr)
954+ Right (tupleAtomExtend newAttrName atom tup)
765955 )
766956
767−evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)
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
962+ env <- askEnv
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)
980+ else do
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)
987+ Right result -> do
988+ --validate that the result matches the expected type
989+ _ <- lift $ except (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))
990+ pure 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
993+ env <- ask
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)
1003+
1004+{-
1005+evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom
1006+evalAtomExpr tupIn expr =
1007+ -}
1008+{-
1009+
7681010evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
7691011 Right atom -> pure (Right atom)
7701012 err@(Left (NoSuchAttributeNamesError _)) -> do
7711013 rstate <- ask
772− case rstate of
773− RelationalExprStateElems _ -> pure err
774− RelationalExprStateAttrsElems _ _ -> pure err
775− RelationalExprStateTupleElems _ ctxtup -> pure (atomForAttributeName attrName ctxtup)
1014+ let stateTup = stateTuple rstate
1015+ pure (atomForAttributeName attrName stateTup)
7761016 Left err -> pure (Left err)
7771017evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
7781018evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
@@ -783,13 +1023,15 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
7831023 func <- either throwE pure (atomFunctionForName funcName functions)
7841024 let expectedArgCount = length (atomFuncType func) - 1
7851025 actualArgCount = length argTypes
786− safeInit [_] = []
7871026 safeInit [] = [] -- different behavior from normal init
788− safeInit (_:xs) = safeInit xs
1027+ safeInit xs = init xs
7891028 if expectedArgCount /= actualArgCount then
7901029 throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
7911030 else do
792− mapM_ (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))
1031+ let zippedArgs = zip (safeInit (atomFuncType func)) argTypes
1032+ mapM_ (\(expType, eActType) -> do
1033+ actType <- either throwE pure eActType
1034+ either throwE pure (atomTypeVerify expType actType)) zippedArgs
7931035 evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments
7941036 case evalAtomFunction func evaldArgs of
7951037 Left err -> throwE (AtomFunctionUserError err)
@@ -810,124 +1052,182 @@ evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExcept
8101052 aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
8111053 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
8121054 pure (ConstructedAtom dConsName aType argAtoms)
813−
814−typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)
815−typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
816− rstate <- ask
1055+-}
1056+typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
1057+typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do
1058+ renv <- askEnv
8171059 case A.atomTypeForAttributeName attrName attrs of
818− Right aType -> pure (Right aType)
819− Left err@(NoSuchAttributeNamesError _) -> case rstate of
820− RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of
821− Left err' -> pure (Left err')
822− Right attr -> pure (Right (A.atomType attr))
823− RelationalExprStateElems _ -> pure (Left err)
824− RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of
825− Left err' -> pure (Left err')
826− Right atom -> pure (Right (atomTypeForAtom atom))
827− Left err -> pure (Left err)
828−typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
829−typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
830− context <- fmap stateElemsContext ask
831− let funcs = atomFunctions context
1060+ Right aType -> pure aType
1061+ Left err@(NoSuchAttributeNamesError _) ->
1062+ let envTup = envTuple renv
1063+ envAttrs = envAttributes renv in
1064+ case A.attributeForName attrName envAttrs of
1065+ Right attr -> pure (A.atomType attr)
1066+ Left _ -> case atomForAttributeName attrName envTup of
1067+ Right atom -> pure (atomTypeForAtom atom)
1068+ Left _ -> --throwError (traceStack (show ("typeForGRAtomExpr", attrs, envTup)) err)
1069+ throwError err
1070+ Left err -> throwError err
1071+
1072+typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)
1073+typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do
1074+ funcs <- atomFunctions <$> gfDatabaseContextForMarker transId
8321075 case atomFunctionForName funcName funcs of
833− Left err -> pure (Left err)
1076+ Left err -> throwError err
8341077 Right func -> do
8351078 let funcRetType = last (atomFuncType func)
8361079 funcArgTypes = init (atomFuncType func)
837− eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs
838− case lefts eArgTypes of
839− errs@(_:_) -> pure (Left (someErrors errs))
840− [] -> do
841− let eTvMap = resolveTypeVariables funcArgTypes argTypes
842− argTypes = rights eArgTypes
843− case eTvMap of
844− Left err -> pure (Left err)
845− Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
846−typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do
847− rstate <- lift ask
848− relType <- either throwE pure (runReader (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))
1080+ argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs
1081+ let eTvMap = resolveTypeVariables funcArgTypes argTypes
1082+ case eTvMap of
1083+ Left err -> throwError err
1084+ Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName tvMap funcRetType
1085+typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do
1086+ relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)
8491087 pure (RelationAtomType (attributes relType))
8501088-- grab the type of the data constructor, then validate that the args match the expected types
851−typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
852− runExceptT $ do
853− argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs
854− context <- fmap stateElemsContext (lift ask)
855− either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
1089+typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =
1090+ do
1091+ argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs
1092+ tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid
1093+ lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes
8561094
8571095-- | Validate that the type of the AtomExpr matches the expected type.
858−verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
859−verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
860− rstate <- lift ask
1096+verifyGraphRefAtomExprTypes :: Relation -> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
1097+verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do
1098+ env <- askEnv
8611099 case A.atomTypeForAttributeName attrName (attributes relIn) of
862− Right aType -> either throwE pure (atomTypeVerify expectedType aType)
863− (Left err@(NoSuchAttributeNamesError _)) -> case rstate of
864− RelationalExprStateTupleElems _ _ -> throwE err
865− RelationalExprStateElems _ -> throwE err
866− RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of
867− Left err' -> throwE err'
868− Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
869− Left err -> throwE err
870−verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
871−verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
872− rstate <- ask
1100+ Right aType -> lift $ except $ atomTypeVerify expectedType aType
1101+ (Left err@(NoSuchAttributeNamesError _)) ->
1102+ let attrs' = envAttributes env in
1103+ if attrs' == emptyAttributes then
1104+ throwError err
1105+ else
1106+ case A.attributeForName attrName attrs' of
1107+ Left err' -> throwError err'
1108+ Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)
1109+ Left err -> throwError err
1110+
1111+verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =
1112+ lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)
1113+verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) expectedType = do
1114+ context <- gfDatabaseContextForMarker tid
8731115 let functions = atomFunctions context
874− context = stateElemsContext rstate
875− runExceptT $ do
876− func <- either throwE pure (atomFunctionForName funcName functions)
877− let expectedArgTypes = atomFuncType func
878− funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of
879− Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)
880− Left err -> throwE err
881− Right x -> pure x
882− ) $ zip3 funcArgExprs expectedArgTypes [1..]
883− if length funcArgTypes /= length expectedArgTypes - 1 then
884− throwE (AtomTypeCountError funcArgTypes expectedArgTypes)
1116+ func <- lift $ except $ atomFunctionForName funcName functions
1117+ let expectedArgTypes = atomFuncType func
1118+ funcArgVerifier (atomExpr, expectedType2, argCount) = do
1119+ let handler :: RelationalError -> GraphRefRelationalExprM AtomType
1120+ handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)
1121+ handler err = throwError err
1122+ verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler
1123+ funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]
1124+ if length funcArgTypes /= length expectedArgTypes - 1 then
1125+ throwError (AtomTypeCountError funcArgTypes expectedArgTypes)
8851126 else
886− either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
887−verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
888− rstate <- lift ask
889− relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
890− either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
891−verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do
892− cType <- liftE (typeFromAtomExpr (attributes rel) cons)
893− either throwE pure (atomTypeVerify expectedType cType)
1127+ lift $ except $ atomTypeVerify expectedType (last expectedArgTypes)
1128+verifyGraphRefAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType =
1129+ do
1130+ let mergedAttrsEnv e = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) e
1131+ relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)
1132+ lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType))
1133+verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do
1134+ cType <- typeForGraphRefAtomExpr (attributes rel) cons
1135+ lift $ except $ atomTypeVerify expectedType cType
8941136
8951137-- | Look up the type's name and create a new attribute.
896−evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute
897−evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do
898− aType <- atomTypeForTypeConstructorValidate True tCons aTypes M.empty
899− validateAtomType aType aTypes
900− Right (Attribute attrName aType)
1138+evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
1139+evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do
1140+ tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker transId
1141+ aType <- lift $ except $ atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
1142+ lift $ except $ validateAtomType aType tConsMap
1143+ pure $ Attribute attrName aType
9011144
902−evalAttrExpr _ (NakedAttributeExpr attr) = Right attr
903−
904−evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
905−evalTupleExpr attrs (TupleExpr tupMap) = do
906− context <- fmap stateElemsContext ask
907− runExceptT $ do
1145+evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure attr
1146+
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
1154+ Nothing ->
1155+ case tuples of
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])
1159+ let
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
1163+ pure accAttr
1164+ else
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
1177+ else
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
1191+
1192+
1193+--resolveAttributes (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",IntegerAtomType),("b",TypeVariableType "b")]))) (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",TypeVariableType "a"),("b",TextAtomType)])))
1194+
1195+evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple
1196+evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do
9081197 -- 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
9091198 -- 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
910− attrAtoms <- mapM (\(attrName, aExpr) -> do
911− newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)
912− newAtom <- liftE (evalAtomExpr emptyTuple aExpr)
913− pure (attrName, newAtom, newAtomType)
914− ) (M.toList tupMap)
915− let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
916− atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
917− tup = mkRelationTuple tupAttrs atoms
918− tConss = typeConstructorMapping context
919− finalAttrs = fromMaybe tupAttrs attrs
1199+ let attrs = fromMaybe A.emptyAttributes mAttrs
1200+ resolveOneAtom (attrName, 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?
1209+ newAtom <- evalGraphRefAtomExpr emptyTuple aExpr
1210+ pure (attrName, newAtom, resolvedType)
1211+ attrAtoms <- mapM resolveOneAtom (M.toList tupMap)
1212+ let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
1213+ atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
1214+ tup = mkRelationTuple tupAttrs atoms
1215+ finalAttrs = fromMaybe tupAttrs mAttrs
9201216 --verify that the attributes match
921− when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)
922− tup' <- either throwE pure (resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup))
923− _ <- either throwE pure (validateTuple tup' tConss)
924− pure tup'
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
1219+ --tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))
1220+ let tup' = reorderTuple finalAttrs tup
1221+ --TODO: restore type resolution
1222+-- _ <- lift $ except (validateTuple tup' tConss)
1223+ pure tup'
9251224
926−evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))
1225+{-
1226+evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))
9271227evalAttributeNames attrNames expr = do
9281228 eExprType <- typeForRelationalExpr expr
9291229 case eExprType of
930− Left err -> pure (Left err)
1230+ Left err -> throwError err
9311231 Right exprTyp -> do
9321232 let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
9331233 case attrNames of
@@ -970,4 +1270,346 @@ evalAttributeNames attrNames expr = do
9701270 case eAttrExprType of
9711271 Left err -> pure (Left err)
9721272 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
973−
1273+-}
1274+
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
1279+ Just _ ->
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)
1341+
1342+dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext
1343+dbContextForTransId tid graph = do
1344+ trans <- transactionForId tid graph
1345+ pure (concreteDatabaseContext trans)
1346+
1347+transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
1348+transactionForId tid graph
1349+ | tid == U.nil =
1350+ Left RootTransactionTraversalError
1351+ | S.null matchingTrans =
1352+ Left $ NoSuchTransactionError tid
1353+ | otherwise =
1354+ Right $ head (S.toList matchingTrans)
1355+ where
1356+ matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
1357+
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
1372+
1373+typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do
1374+ relVars <- relationVariables <$> gfDatabaseContextForMarker tid
1375+ case M.lookup rvName relVars of
1376+ Nothing -> throwError (RelVarNotDefinedError rvName)
1377+ Just rvExpr ->
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{} =
1410+ pure relationFalse
1411+typeForGraphRefRelationalExpr NotEquals{} =
1412+ pure relationFalse
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
1422+ Nothing -> pure ()
1423+ mapM_ (checkMacroName . fst) withs
1424+ typeForGraphRefRelationalExpr expr'
1425+
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')))
1430+ case attrNames of
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)))
1435+
1436+ InvertedAttributeNames names -> do
1437+ let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
1438+ if not (S.null nonExistentAttributeNames) then
1439+ throwError $ AttributeNamesMismatchError nonExistentAttributeNames
1440+ else
1441+ pure (A.nonMatchingAttributeNameSet names typeNameSet)
1442+
1443+ UnionAttributeNames namesA namesB -> do
1444+ nameSetA <- evalGraphRefAttributeNames namesA expr
1445+ nameSetB <- evalGraphRefAttributeNames namesB expr
1446+ pure (S.union nameSetA nameSetB)
1447+
1448+ IntersectAttributeNames namesA namesB -> do
1449+ nameSetA <- evalGraphRefAttributeNames namesA expr
1450+ nameSetB <- evalGraphRefAttributeNames namesB expr
1451+ pure (S.intersection nameSetA nameSetB)
1452+
1453+ RelationalExprAttributeNames attrExpr -> do
1454+ attrExprType <- typeForGraphRefRelationalExpr attrExpr
1455+ pure (A.attributeNameSet (attributes attrExprType))
1456+
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
1462+ Right aType -> do
1463+ case validateAtomType aType tConsMap of
1464+ Left err -> throwError err
1465+ Right _ -> pure (Attribute attrName aType)
1466+evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr
1467+
1468+mkEmptyRelVars :: RelationVariables -> RelationVariables
1469+mkEmptyRelVars = M.map mkEmptyRelVar
1470+ where
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)
1487+
1488+
1489+dbErr :: RelationalError -> DatabaseContextEvalMonad ()
1490+dbErr err = lift (except (Left err))
1491+
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
1511+
1512+-- | An unoptimized variant of evalGraphRefRelationalExpr for testing.
1513+evalRelationalExpr :: RelationalExpr -> RelationalExprM Relation
1514+evalRelationalExpr expr = do
1515+ graph <- reGraph
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
1522+
1523+{-
1524+relVarByName :: RelVarName -> GraphRefRelationalExprM GraphRefRelationalExpr
1525+relVarByName = do
1526+ relvars <- relationVariables <$> getStateContext
1527+ case M.lookup relVarName relvars of
1528+ Nothing -> dbErr (RelVarNotDefinedError relVarName)
1529+ Just gfexpr -> pure gfExpr
1530+-}
1531+
1532+class (MonadError RelationalError m, Monad m) => DatabaseContextM m where
1533+ getContext :: m DatabaseContext
1534+
1535+instance DatabaseContextM (ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity)) where
1536+ getContext = gfDatabaseContextForMarker UncommittedContextMarker
1537+
1538+instance DatabaseContextM (RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity)) where
1539+ getContext = getStateContext
1540+
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
1547+
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
1551+
1552+-- s := s union t
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
1576+
1577+instance ResolveGraphRefTransactionMarker GraphRefTupleExprs where
1578+ resolve (TupleExprs marker tupleExprs) =
1579+ TupleExprs marker <$> mapM resolve tupleExprs
1580+
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'))
1585+
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
1592+
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
1601+
1602+instance ResolveGraphRefTransactionMarker GraphRefExtendTupleExpr where
1603+ resolve (AttributeExtendTupleExpr nam atomExpr) = AttributeExtendTupleExpr nam <$> resolve atomExpr
1604+
1605+instance ResolveGraphRefTransactionMarker GraphRefWithNameExpr where
1606+ resolve orig@WithNameExpr{} = pure orig -- match uncommitted marker?
1607+
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