@@ -23,10 +23,31 @@ import qualified Data.Text as T
2323import qualified Data.Vector as V
2424import qualified ProjectM36.TypeConstructorDef as TCD
2525import Control.Monad.Trans.Except
26+import Control.Monad.Trans.Reader
2627
2728import GHC
2829import GHC.Paths
2930
31+data DatabaseContextExprDetails = CountUpdatedTuples
32+
33+databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc
34+databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTups
35+ where
36+ attrs = A.attributesFromList [Attribute "count" IntAtomType]
37+ existingTuple = case singletonTuple relIn of
38+ Just t -> t
39+ Nothing -> error "impossible counting error in singletonTuple"
40+ existingCount = case V.head (tupleAtoms existingTuple) of
41+ IntAtom v -> v
42+ _ -> error "impossible counting error in tupleAtoms"
43+ newTups = case mkTupleSetFromList attrs [[IntAtom (existingCount + 1)]] of
44+ Left err -> error ("impossible counting error in " ++ show err)
45+ Right ts -> ts
46+
47+-- | 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
50+
3051-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
3152data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
3253 RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
@@ -51,24 +72,53 @@ mergeAttributesIntoRelationalExprState attrs (RelationalExprStateElems ctx) = Re
5172mergeAttributesIntoRelationalExprState _ st@(RelationalExprStateTupleElems _ _) = st
5273mergeAttributesIntoRelationalExprState attrsIn (RelationalExprStateAttrsElems ctx attrs) = RelationalExprStateAttrsElems ctx (A.union attrsIn attrs)
5374
54−type DatabaseState a = State DatabaseContext a
75+type ResultAccumName = StringType
76+
77+type ResultAccumFunc = (RelationTuple -> Relation -> Relation) -> Relation -> Relation
5578
56−type RelationalExprState a = State RelationalExprStateElems a
79+data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,
80+ resultAccumResult :: Relation
81+ }
5782
58−stateContext :: RelationalExprStateElems -> DatabaseContext
59−stateContext (RelationalExprStateTupleElems ctx _) = ctx
60−stateContext (RelationalExprStateElems ctx) = ctx
61−stateContext (RelationalExprStateAttrsElems ctx _) = ctx
83+type DatabaseStateElems = (DatabaseContext, M.Map ResultAccumName ResultAccum, DirtyFlag)
6284
63−setStateContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
64−setStateContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
65−setStateContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
66−setStateContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
85+type DatabaseState a = State DatabaseStateElems a
86+
87+getStateContext :: DatabaseState (DatabaseContext)
88+getStateContext = do
89+ (ctx,_, _) <- get
90+ pure ctx
91+
92+putStateContext :: DatabaseContext -> DatabaseState ()
93+putStateContext ctx = do
94+ (_, accum, flag) <- get
95+ put (ctx, accum, flag)
96+
97+-- indicates that the underlying database context has changed and warrants a new commit
98+putDirtyFlag :: DatabaseState ()
99+putDirtyFlag = do
100+ (ctx, accum, flag) <- get
101+ if flag then
102+ pure ()
103+ else
104+ put (ctx, accum, True)
105+
106+type RelationalExprState a = Reader RelationalExprStateElems a
107+
108+stateElemsContext :: RelationalExprStateElems -> DatabaseContext
109+stateElemsContext (RelationalExprStateTupleElems ctx _) = ctx
110+stateElemsContext (RelationalExprStateElems ctx) = ctx
111+stateElemsContext (RelationalExprStateAttrsElems ctx _) = ctx
112+
113+setStateElemsContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
114+setStateElemsContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
115+setStateElemsContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
116+setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
67117
68118--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
69119evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
70120evalRelationalExpr (RelationVariable name _) = do
71− relvarTable <- liftM (relationVariables . stateContext) get
121+ relvarTable <- liftM (relationVariables . stateElemsContext) ask
72122 return $ case M.lookup name relvarTable of
73123 Just res -> Right res
74124 Nothing -> Left $ RelVarNotDefinedError name
@@ -112,7 +162,7 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do
112162 Left err -> return $ Left err
113163
114164evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
115− currentContext <- liftM stateContext get
165+ currentContext <- liftM stateElemsContext ask
116166 let tConss = typeConstructorMapping currentContext
117167 -- 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
118168 runExceptT $ do
@@ -177,8 +227,8 @@ evalRelationalExpr (NotEquals relExprA relExprB) = do
177227
178228-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
179229evalRelationalExpr (Extend tupleExpression relExpr) = do
180− rstate <- get
181− let evald = evalState (evalRelationalExpr relExpr) rstate
230+ rstate <- ask
231+ let evald = runReader (evalRelationalExpr relExpr) rstate
182232 case evald of
183233 Left err -> pure (Left err)
184234 Right rel -> do
@@ -190,37 +240,39 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do
190240--helper function to process relation variable creation/assignment
191241setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)
192242setRelVar relVarName rel = do
193− currentContext <- get
243+ currentContext <- getStateContext
194244 let newRelVars = M.insert relVarName rel $ relationVariables currentContext
195245 potentialContext = currentContext { relationVariables = newRelVars }
196246
197247 case checkConstraints potentialContext of
198248 Just err -> return $ Just err
199249 Nothing -> do
200− put potentialContext
250+ putStateContext potentialContext
251+ putDirtyFlag
201252 return Nothing
202253
203254-- 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
204255deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)
205256deleteRelVar relVarName = do
206− currContext <- get
257+ currContext <- getStateContext
207258 let newRelVars = M.delete relVarName (relationVariables currContext)
208259 newContext = currContext { relationVariables = newRelVars }
209− put newContext
210− return Nothing
260+ putStateContext newContext
261+ putDirtyFlag
262+ pure Nothing
211263
212264evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Maybe RelationalError)
213265evalDatabaseContextExpr NoOperation = pure Nothing
214266
215267evalDatabaseContextExpr (Define relVarName attrExprs) = do
216− relvars <- liftM relationVariables get
217− tConss <- liftM typeConstructorMapping get
268+ relvars <- liftM relationVariables getStateContext
269+ tConss <- liftM typeConstructorMapping getStateContext
218270 let eAttrs = map (evalAttrExpr tConss) attrExprs
219271 case lefts eAttrs of
220272 err:_ -> pure (Just err)
221273 [] -> case M.member relVarName relvars of
222274 True -> return (Just (RelVarAlreadyDefinedError relVarName))
223− False -> setRelVar relVarName emptyRelation
275+ False -> setRelVar relVarName emptyRelation >> putDirtyFlag >> pure Nothing
224276 where
225277 attrs = A.attributesFromList (rights eAttrs)
226278 emptyRelation = Relation attrs emptyTupleSet
@@ -230,10 +282,10 @@ evalDatabaseContextExpr (Undefine relVarName) = do
230282
231283evalDatabaseContextExpr (Assign relVarName expr) = do
232284 -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
233− context <- get
285+ context <- getStateContext
234286 let existingRelVar = M.lookup relVarName relVarTable
235287 relVarTable = relationVariables context
236− value = evalState (evalRelationalExpr expr) (RelationalExprStateElems context)
288+ value = runReader (evalRelationalExpr expr) (RelationalExprStateElems context)
237289 case value of
238290 Left err -> return $ Just err
239291 Right rel -> case existingRelVar of
@@ -248,20 +300,20 @@ evalDatabaseContextExpr (Assign relVarName expr) = do
248300evalDatabaseContextExpr (Insert relVarName relExpr) = evalDatabaseContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName ()))
249301
250302evalDatabaseContextExpr (Delete relVarName predicate) = do
251− context <- get
252− let updatedRel = evalState (evalRelationalExpr (Restrict (NotPredicate predicate) (RelationVariable relVarName ()))) (RelationalExprStateElems context)
303+ context <- getStateContext
304+ let updatedRel = runReader (evalRelationalExpr (Restrict (NotPredicate predicate) (RelationVariable relVarName ()))) (RelationalExprStateElems context)
253305 case updatedRel of
254306 Left err -> return $ Just err
255307 Right rel -> setRelVar relVarName rel
256308
257309--union of restricted+updated portion and the unrestricted+unupdated portion
258310evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do
259− context <- get
311+ context <- getStateContext
260312 let relVarTable = relationVariables context
261313 case M.lookup relVarName relVarTable of
262314 Nothing -> return $ Just (RelVarNotDefinedError relVarName)
263315 Just rel -> do
264− case evalState (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of
316+ case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of
265317 Left err -> return $ Just err
266318 Right predicateFunc -> do
267319 case makeUpdatedRel rel of
@@ -275,7 +327,7 @@ evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr)
275327 union updatedPortion unrestrictedPortion
276328
277329evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
278− currContext <- get
330+ currContext <- getStateContext
279331 let currDeps = inclusionDependencies currContext
280332 newDeps = M.insert newDepName newDep currDeps
281333 if M.member newDepName currDeps then
@@ -285,22 +337,22 @@ evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
285337 case checkConstraints potentialContext of
286338 Just err -> return $ Just err
287339 Nothing -> do
288− put potentialContext
340+ putStateContext potentialContext
289341 return Nothing
290342
291343evalDatabaseContextExpr (RemoveInclusionDependency depName) = do
292− currContext <- get
344+ currContext <- getStateContext
293345 let currDeps = inclusionDependencies currContext
294346 newDeps = M.delete depName currDeps
295347 if M.notMember depName currDeps then
296348 return $ Just (InclusionDependencyNameNotInUseError depName)
297349 else do
298− put $ currContext {inclusionDependencies = newDeps }
350+ putStateContext $ currContext {inclusionDependencies = newDeps }
299351 return Nothing
300352
301353-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
302354evalDatabaseContextExpr (AddNotification notName triggerExpr resultExpr) = do
303− currentContext <- get
355+ currentContext <- getStateContext
304356 let nots = notifications currentContext
305357 if M.member notName nots then
306358 return $ Just (NotificationNameInUseError notName)
@@ -308,23 +360,23 @@ evalDatabaseContextExpr (AddNotification notName triggerExpr resultExpr) = do
308360 let newNotifications = M.insert notName newNotification nots
309361 newNotification = Notification { changeExpr = triggerExpr,
310362 reportExpr = resultExpr }
311− put $ currentContext { notifications = newNotifications }
363+ putStateContext $ currentContext { notifications = newNotifications }
312364 return Nothing
313365
314366evalDatabaseContextExpr (RemoveNotification notName) = do
315− currentContext <- get
367+ currentContext <- getStateContext
316368 let nots = notifications currentContext
317369 if M.notMember notName nots then
318370 return $ Just (NotificationNameNotInUseError notName)
319371 else do
320372 let newNotifications = M.delete notName nots
321− put $ currentContext { notifications = newNotifications }
373+ putStateContext $ currentContext { notifications = newNotifications }
322374 return Nothing
323375
324376-- | Adds type and data constructors to the database context.
325377-- validate that the type *and* constructor names are unique! not yet implemented!
326378evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
327− currentContext <- get
379+ currentContext <- getStateContext
328380 let oldTypes = typeConstructorMapping currentContext
329381 tConsName = TCD.name tConsDef
330382 -- validate that the constructor's types exist
@@ -337,18 +389,18 @@ evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
337389 pure $ Just (AtomTypeNameInUseError tConsName)
338390 else do
339391 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
340− put $ currentContext { typeConstructorMapping = newTypes }
392+ putStateContext $ currentContext { typeConstructorMapping = newTypes }
341393 pure Nothing
342394
343395-- | 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.
344396evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do
345− currentContext <- get
397+ currentContext <- getStateContext
346398 let oldTypes = typeConstructorMapping currentContext
347399 if findTypeConstructor tConsName oldTypes == Nothing then
348400 pure $ Just (AtomTypeNameNotInUseError tConsName)
349401 else do
350402 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
351− put $ currentContext { typeConstructorMapping = newTypes }
403+ putStateContext $ currentContext { typeConstructorMapping = newTypes }
352404 pure Nothing
353405
354406evalDatabaseContextExpr (MultipleExpr exprs) = do
@@ -360,35 +412,35 @@ evalDatabaseContextExpr (MultipleExpr exprs) = do
360412 err:_ -> return $ Just err
361413
362414evalDatabaseContextExpr (RemoveAtomFunction funcName) = do
363− currentContext <- get
415+ currentContext <- getStateContext
364416 let atomFuncs = atomFunctions currentContext
365417 case atomFunctionForName funcName atomFuncs of
366418 Left err -> pure (Just err)
367419 Right realFunc -> if isScriptedAtomFunction realFunc then do
368420 let updatedFuncs = HS.delete realFunc atomFuncs
369− put (currentContext {atomFunctions = updatedFuncs })
421+ putStateContext (currentContext {atomFunctions = updatedFuncs })
370422 pure Nothing
371423 else
372424 pure (Just (PrecompiledFunctionRemoveError funcName))
373425
374426
375427evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
376− context <- get
428+ context <- getStateContext
377429 let dbcFuncs = dbcFunctions context
378430 case databaseContextFunctionForName funcName dbcFuncs of
379431 Left err -> pure (Just err)
380432 Right realFunc -> if isScriptedDatabaseContextFunction realFunc then do
381433 let updatedFuncs = HS.delete realFunc dbcFuncs
382− put (context { dbcFunctions = updatedFuncs })
434+ putStateContext (context { dbcFunctions = updatedFuncs })
383435 pure Nothing
384436 else
385437 pure (Just (PrecompiledFunctionRemoveError funcName))
386438
387439evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
388− context <- get
440+ context <- getStateContext
389441 --resolve atom arguments
390442 let relExprState = mkRelationalExprState context
391− eAtomTypes = map (\atomExpr -> evalState (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs
443+ eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs
392444 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
393445 case eFunc of
394446 Left err -> pure (Just err)
@@ -407,7 +459,7 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) =
407459 Left err -> Just err
408460 Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)
409461 typeErrors = catMaybes mValidTypes
410− eAtomArgs = map (\arg -> evalState (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
462+ eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
411463 if length (lefts eAtomArgs) > 1 then
412464 pure (Just (someErrors (lefts eAtomArgs)))
413465 else if length typeErrors > 0 then
@@ -415,7 +467,7 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) =
415467 else do
416468 case evalDatabaseContextFunction func (rights eAtomArgs) context of
417469 Left err -> pure (Just err)
418− Right newContext -> put newContext >> pure Nothing
470+ Right newContext -> putStateContext newContext >> pure Nothing
419471
420472evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
421473evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do
@@ -495,7 +547,7 @@ updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext ->
495547updateTupleWithAtomExprs exprMap context tupIn = do
496548 --resolve all atom exprs
497549 atomsAssoc <- mapM (\(attrName, atomExpr) -> do
498− atom <- evalState (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
550+ atom <- runReader (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
499551 pure (attrName, atom)
500552 ) (M.toList exprMap)
501553 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
@@ -508,7 +560,7 @@ checkConstraints context = case failures of
508560 where
509561 failures = M.elems $ M.mapMaybeWithKey checkIncDep deps
510562 deps = inclusionDependencies context
511− eval expr = evalState (evalRelationalExpr expr) (RelationalExprStateElems context)
563+ eval expr = runReader (evalRelationalExpr expr) (RelationalExprStateElems context)
512564 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
513565 let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)
514566 case eval checkExpr of
@@ -523,12 +575,12 @@ checkConstraints context = case failures of
523575
524576typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
525577typeForRelationalExpr expr = do
526− rstate <- get
527− let context = stateContext rstate
578+ rstate <- ask
579+ let context = stateElemsContext rstate
528580 --replace the relationVariables context element with a cloned set of relation devoid of tuples
529581 let context' = contextWithEmptyTupleSets context
530− rstate' = setStateContext rstate context'
531− pure (evalState (evalRelationalExpr expr) rstate')
582+ rstate' = setStateElemsContext rstate context'
583+ pure (runReader (evalRelationalExpr expr) rstate')
532584
533585--returns a database context with all tuples removed
534586--this is useful for type checking and optimization
@@ -577,7 +629,7 @@ predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = runExceptT $ do
577629
578630predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
579631 --merge attrs into the state attributes
580− rstate <- get
632+ rstate <- ask
581633 runExceptT $ do
582634 atomExprType <- liftE (typeFromAtomExpr attrs atomExpr)
583635 attr <- either throwE pure (A.attributeForName attrName attrs)
@@ -587,21 +639,21 @@ predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr)
587639 pure $ \tupleIn -> case atomForAttributeName attrName tupleIn of
588640 Left _ -> False
589641 Right atomIn ->
590− let atomEvald = evalState (evalAtomExpr tupleIn atomExpr) rstate in
642+ let atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate in
591643 case atomEvald of
592644 Right atomCmp -> atomCmp == atomIn
593645 Left _ -> False
594646-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
595647predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
596648 --merge attrs into the state attributes
597− rstate <- get
649+ rstate <- ask
598650 runExceptT $ do
599651 aType <- liftE (typeFromAtomExpr attrs atomExpr)
600652 if aType /= BoolAtomType then
601653 throwE (AtomTypeMismatchError aType BoolAtomType)
602654 else
603655 pure (\tupleIn -> do
604− case evalState (evalAtomExpr tupleIn atomExpr) rstate of
656+ case runReader (evalAtomExpr tupleIn atomExpr) rstate of
605657 Left _ -> False
606658 Right boolAtomValue -> boolAtomValue == BoolAtom True)
607659
@@ -613,7 +665,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName
613665
614666extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
615667extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
616− rstate <- get
668+ rstate <- ask
617669 -- check that the attribute name is not in use
618670 case tupleExprCheckNewAttrName newAttrName relIn of
619671 Left err -> pure (Left err)
@@ -622,7 +674,7 @@ extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomE
622674 atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)
623675 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
624676 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
625− pure $ (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case evalState (evalAtomExpr tup atomExpr) substate of
677+ pure $ (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of
626678 Left err -> Left err
627679 Right atom -> Right (tupleAtomExtend newAttrName atom tup)
628680 )
@@ -631,7 +683,7 @@ evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either Relatio
631683evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
632684 Right atom -> pure (Right atom)
633685 err@(Left (NoSuchAttributeNamesError _)) -> do
634− rstate <- get
686+ rstate <- ask
635687 case rstate of
636688 RelationalExprStateElems _ -> pure err
637689 RelationalExprStateAttrsElems _ _ -> pure err
@@ -640,7 +692,7 @@ evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attr
640692evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
641693evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
642694 argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments
643− context <- liftM stateContext get
695+ context <- liftM stateElemsContext ask
644696 runExceptT $ do
645697 let functions = atomFunctions context
646698 func <- either throwE pure (atomFunctionForName funcName functions)
@@ -659,22 +711,22 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
659711 Right result -> pure result
660712evalAtomExpr tupIn (RelationAtomExpr relExpr) = do
661713 --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes
662− rstate <- get
714+ rstate <- ask
663715 runExceptT $ do
664716 let newState = mergeTuplesIntoRelationalExprState tupIn rstate
665− relAtom <- either throwE pure (evalState (evalRelationalExpr relExpr) newState)
717+ relAtom <- either throwE pure (runReader (evalRelationalExpr relExpr) newState)
666718 pure (RelationAtom relAtom)
667719evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do
668− rstate <- get
720+ rstate <- lift ask
669721 let newState = mergeTuplesIntoRelationalExprState tupIn rstate
670− aType <- either throwE pure (evalState (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
671− argAtoms <- mapM (\arg -> either throwE pure (evalState (evalAtomExpr tupIn arg) newState)) dConsArgs
722+ aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
723+ argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
672724 pure (ConstructedAtom dConsName aType argAtoms)
673725
674726typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)
675727typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
676728 --first, check if the attribute is in the immediate attributes
677− rstate <- get
729+ rstate <- ask
678730 case A.atomTypeForAttributeName attrName attrs of
679731 Right aType -> pure (Right aType)
680732 Left err@(NoSuchAttributeNamesError _) -> case rstate of
@@ -688,7 +740,7 @@ typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
688740 Left err -> pure (Left err)
689741typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
690742typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
691− context <- liftM stateContext get
743+ context <- liftM stateElemsContext ask
692744 let funcs = atomFunctions context
693745 case atomFunctionForName funcName funcs of
694746 Left err -> pure (Left err)
@@ -705,21 +757,21 @@ typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
705757 Left err -> pure (Left err)
706758 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
707759typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do
708− rstate <- get
709− relType <- either throwE pure (evalState (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))
760+ rstate <- lift ask
761+ relType <- either throwE pure (runReader (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))
710762 pure (RelationAtomType (attributes relType))
711763-- grab the type of the data constructor, then validate that the args match the expected types
712764typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
713765 runExceptT $ do
714766 argsTypes <- mapM (\arg -> liftE (typeFromAtomExpr attrs arg)) dConsArgs
715− context <- liftM stateContext get
767+ context <- liftM stateElemsContext (lift ask)
716768 aType <- either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
717769 pure aType
718770
719771-- | Validate that the type of the AtomExpr matches the expected type.
720772verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
721773verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
722− rstate <- get
774+ rstate <- lift ask
723775 case A.atomTypeForAttributeName attrName (attributes relIn) of
724776 Right aType -> pure aType
725777 (Left err@(NoSuchAttributeNamesError _)) -> case rstate of
@@ -731,13 +783,13 @@ verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT
731783 Left err -> throwE err
732784verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
733785verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
734− rstate <- get
786+ rstate <- ask
735787 let functions = atomFunctions context
736− context = stateContext rstate
788+ context = stateElemsContext rstate
737789 runExceptT $ do
738790 func <- either throwE pure (atomFunctionForName funcName functions)
739791 let expectedArgTypes = atomFuncType func
740− funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case evalState (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of
792+ funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of
741793 Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)
742794 Left err -> throwE (err)
743795 Right x -> pure x
@@ -747,8 +799,8 @@ verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedTyp
747799 else do
748800 either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
749801verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
750− rstate <- get
751− relType <- either throwE pure (evalState (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
802+ rstate <- lift ask
803+ relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
752804 either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
753805verifyAtomExprTypes rel cons@(ConstructedAtomExpr _ _ _) expectedType = runExceptT $ do
754806 cType <- liftE (typeFromAtomExpr (attributes rel) cons)
@@ -763,23 +815,24 @@ evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do
763815evalAttrExpr _ (NakedAttributeExpr attr) = Right attr
764816
765817evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
766−evalTupleExpr attrs (TupleExpr tupMap) = runExceptT $ do
818+evalTupleExpr attrs (TupleExpr tupMap) = do
819+ context <- liftM stateElemsContext ask
820+ runExceptT $ do
767821 -- 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
768822 -- 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
769− context <- liftM stateContext get
770− attrAtoms <- mapM (\(attrName, aExpr) -> do
771− newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)
772− newAtom <- liftE (evalAtomExpr emptyTuple aExpr)
773− pure (attrName, newAtom, newAtomType)
774− ) (M.toList tupMap)
775− let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
776− atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
777− tup = mkRelationTuple tupAttrs atoms
778− tConss = typeConstructorMapping context
779− finalAttrs = fromMaybe tupAttrs attrs
780− --verify that the attributes match
781− when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)
782− tup' <- either throwE pure (resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup))
783− _ <- either throwE pure (validateTuple tup' tConss)
784− pure tup'
823+ attrAtoms <- mapM (\(attrName, aExpr) -> do
824+ newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)
825+ newAtom <- liftE (evalAtomExpr emptyTuple aExpr)
826+ pure (attrName, newAtom, newAtomType)
827+ ) (M.toList tupMap)
828+ let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
829+ atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
830+ tup = mkRelationTuple tupAttrs atoms
831+ tConss = typeConstructorMapping context
832+ finalAttrs = fromMaybe tupAttrs attrs
833+ --verify that the attributes match
834+ when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)
835+ tup' <- either throwE pure (resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup))
836+ _ <- either throwE pure (validateTuple tup' tConss)
837+ pure tup'
785838