@@ -57,34 +57,42 @@ freshDatabaseState context = DatabaseStateElems {
5757 } --future work: propagate return accumulator
5858
5959-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
60−data RelationalExprStateElems = RelationalExprStateTupleElems {
60+data RelationalExprStateElems = RelationalExprStateElems {
6161 elems_context :: DatabaseContext,
6262 elems_graph :: TransactionGraph,
6363 elems_extra :: Maybe (Either RelationTuple Attributes) }
6464
65+stateTuple :: RelationalExprStateElems -> RelationTuple
66+stateTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (elems_extra e))
67+
68+stateAttributes :: RelationalExprStateElems -> Attributes
69+stateAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (elems_extra e))
6570{-
6671data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
6772 RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
6873 RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation
6974 -}
7075
71−instance Show RelationalExprStateElems where
72− show e@RelationalExprStateTupleElems{..} = "RelationalExprStateTupleElems " ++ show (elems_extra e)
76+instance Show RelationalExprStateElems where show e@RelationalExprStateElems{} = "RelationalExprStateElems " ++ show (elems_extra e)
7377
74−mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems
75−mkRelationalExprState = RelationalExprStateElems
78+mkRelationalExprState :: DatabaseContext -> TransactionGraph -> RelationalExprStateElems
79+mkRelationalExprState ctx graph = RelationalExprStateElems
80+ { elems_context = ctx,
81+ elems_graph = graph,
82+ elems_extra = Nothing }
7683
7784mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems
78−mergeTuplesIntoRelationalExprState tupIn e@RelationalExprStateElems{..} =
79− e{elems_extra = <$> elems_extra e } RelationalExprStateTupleElems ctx tupIn
80−mergeTuplesIntoRelationalExprState _ st@(RelationalExprStateAttrsElems _ _) = st
81−mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateTupleElems ctx existingTuple) = let mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap existingTuple) in
82− RelationalExprStateTupleElems ctx (mkRelationTupleFromMap mergedTupMap)
85+mergeTuplesIntoRelationalExprState tupIn e@RelationalExprStateElems{} =
86+ e{elems_extra = new_elems }
87+ where
88+ new_elems = Just (Left newTuple)
89+ mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (stateTuple e))
90+ newTuple = mkRelationTupleFromMap mergedTupMap
8391
8492mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprStateElems -> RelationalExprStateElems
85−mergeAttributesIntoRelationalExprState attrs (RelationalExprStateElems ctx) = RelationalExprStateAttrsElems ctx attrs
86−mergeAttributesIntoRelationalExprState _ st@(RelationalExprStateTupleElems _ _) = st
87−mergeAttributesIntoRelationalExprState attrsIn (RelationalExprStateAttrsElems ctx attrs) = RelationalExprStateAttrsElems ctx (A.union attrsIn attrs)
93+mergeAttributesIntoRelationalExprState attrsIn e@RelationalExprStateElems{} = e{elems_extra = newattrs }
94+ where
95+ newattrs = Just (Right (A.union attrsIn (stateAttributes e)))
8896
8997type ResultAccumName = StringType
9098
@@ -113,14 +121,10 @@ putStateContext ctx' = do
113121type RelationalExprState a = Reader RelationalExprStateElems a
114122
115123stateElemsContext :: RelationalExprStateElems -> DatabaseContext
116−stateElemsContext (RelationalExprStateTupleElems ctx _) = ctx
117−stateElemsContext (RelationalExprStateElems ctx) = ctx
118−stateElemsContext (RelationalExprStateAttrsElems ctx _) = ctx
124+stateElemsContext = elems_context
119125
120126setStateElemsContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
121−setStateElemsContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
122−setStateElemsContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
123−setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
127+setStateElemsContext e ctx = e { elems_context = ctx }
124128
125129--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
126130evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)
@@ -323,10 +327,10 @@ evalDatabaseContextExpr (Undefine relVarName) _ _ = deleteRelVar relVarName
323327evalDatabaseContextExpr (Assign relVarName expr) transId graph = do
324328 context <- getStateContext
325329 let existingRelVar = M.lookup relVarName (relationVariables context)
326− relExprState = mkRelationalExprState context
330+ relExprState = mkRelationalExprState context graph
327331 case existingRelVar of
328332 Nothing -> do
329− let ervExpr = runReader (evalRelationalExpr expr) relExprState
333+ let ervExpr = runReader (evalRelationalExpr expr) relExprState
330334 case ervExpr of
331335 Left err -> pure (Left err)
332336 Right rvExpr -> setRelVar relVarName rvExpr transId graph
@@ -354,7 +358,7 @@ evalDatabaseContextExpr (Insert relVarName relExpr) tid graph =
354358evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do
355359 ctx <- getStateContext
356360 let rv = RelationVariable relVarName transId
357− rvState = mkRelationalExprState ctx
361+ rvState = mkRelationalExprState ctx graph
358362 case runReader (processRestrictionPredicateExpr predicate) rvState of
359363 Left err -> pure (Left err)
360364 Right graphRefPredicate ->
@@ -363,7 +367,7 @@ evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do
363367--union of restricted+updated portion and the unrestricted+unupdated portion
364368evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId graph = do
365369 context <- getStateContext
366− let rvState = mkRelationalExprState context
370+ let rvState = mkRelationalExprState context graph
367371 relVarTable = relationVariables context
368372 case runReader (processRestrictionPredicateExpr restrictionPredicateExpr) rvState of
369373 Left err -> pure (Left err)
@@ -492,10 +496,10 @@ evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) _ _ = do
492496 else
493497 pure (Left (PrecompiledFunctionRemoveError funcName))
494498
495−evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) _ _ = do
499+evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) _ graph = do
496500 context <- getStateContext
497501 --resolve atom arguments
498− let relExprState = mkRelationalExprState context
502+ let relExprState = mkRelationalExprState context graph
499503 eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs
500504 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
501505 case eFunc of
@@ -636,11 +640,11 @@ evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelatio
636640 (Left err,_) -> pure (Left err)
637641 (Right (), elems') -> pure $ Right (context elems)
638642
639−updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
640−updateTupleWithAtomExprs exprMap context tupIn = do
643+updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple
644+updateTupleWithAtomExprs exprMap context graph tupIn = do
641645 --resolve all atom exprs
642646 atomsAssoc <- mapM (\(attrName, atomExpr) -> do
643− atom <- runReader (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
647+ atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)
644648 pure (attrName, atom)
645649 ) (M.toList exprMap)
646650 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
@@ -658,7 +662,7 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
658662
659663 deps = inclusionDependencies context
660664 eval expr = evalReader (evalRelationalExpr expr)
661− evalReader f = runReader f (RelationalExprStateElems context)
665+ evalReader f = runReader f (mkRelationalExprState context graph)
662666 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
663667 let gfSubsetExpr = processRelationalExpr subsetExpr transId
664668 gfSupersetExpr = processRelationalExpr supersetExpr transId
@@ -741,10 +745,8 @@ predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do
741745
742746predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
743747 rstate <- ask
744− let (attrs', ctxtup') = case rstate of
745− RelationalExprStateElems _ -> (attrs, emptyTuple)
746− RelationalExprStateAttrsElems _ _ -> (attrs, emptyTuple)
747− RelationalExprStateTupleElems _ ctxtup -> (A.union attrs (tupleAttributes ctxtup), ctxtup)
748+ let attrs' = stateAttributes rstate
749+ ctxtup' = stateTuple rstate
748750 runExceptT $ do
749751 atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr)
750752 attr <- either throwE pure $ case A.attributeForName attrName attrs of
@@ -809,10 +811,8 @@ evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attr
809811 Right atom -> pure (Right atom)
810812 err@(Left (NoSuchAttributeNamesError _)) -> do
811813 rstate <- ask
812− case rstate of
813− RelationalExprStateElems _ -> pure err
814− RelationalExprStateAttrsElems _ _ -> pure err
815− RelationalExprStateTupleElems _ ctxtup -> pure (atomForAttributeName attrName ctxtup)
814+ let stateTup = stateTuple rstate
815+ pure (atomForAttributeName attrName stateTup)
816816 Left err -> pure (Left err)
817817evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
818818evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
@@ -858,15 +858,15 @@ typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
858858 rstate <- ask
859859 case A.atomTypeForAttributeName attrName attrs of
860860 Right aType -> pure (Right aType)
861− Left err@(NoSuchAttributeNamesError _) -> case rstate of
862− RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of
863− Left err' -> pure (Left err')
864− Right attr -> pure (Right (A.atomType attr))
865− RelationalExprStateElems _ -> pure (Left err)
866− RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of
867− Left err' -> pure (Left err')
861+ Left err@(NoSuchAttributeNamesError _) ->
862+ let stateTup = stateTuple rstate
863+ stateAttrs = stateAttributes rstate in
864+ case A.attributeForName attrName stateAttrs of
865+ Right attr -> pure (Right (A.atomType attr))
866+ Left _ -> case atomForAttributeName attrName tup of
868867 Right atom -> pure (Right (atomTypeForAtom atom))
869− Left err -> pure (Left err)
868+ Left _ -> pure (Left err)
869+
870870typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
871871typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
872872 context <- fmap stateElemsContext ask
@@ -902,13 +902,14 @@ verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT
902902 rstate <- lift ask
903903 case A.atomTypeForAttributeName attrName (attributes relIn) of
904904 Right aType -> either throwE pure (atomTypeVerify expectedType aType)
905− (Left err@(NoSuchAttributeNamesError _)) -> case rstate of
906− RelationalExprStateTupleElems _ _ -> throwE err
907− RelationalExprStateElems _ -> throwE err
908− RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of
909− Left err' -> throwE err'
910− Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
911− Left err -> throwE err
905+ (Left err@(NoSuchAttributeNamesError _)) ->
906+ let attrs' = stateAttrs rstate in
907+ if attrs' == emptyAttributes then
908+ throwE err
909+ else
910+ case A.attributeForName attrName attrs of
911+ Left err' -> throwE err'
912+ Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
912913verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
913914verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
914915 rstate <- ask