@@ -18,7 +18,7 @@ import qualified ProjectM36.Attribute as A
1818import qualified Data.Map as M
1919import qualified Data.HashSet as HS
2020import qualified Data.Set as S
21−import Control.Monad.Trans.RWS.Strict as RWS
21+import Control.Monad.RWS.Strict as RWS
2222import Control.Monad.Trans.Class (lift)
2323import Control.Exception
2424import Data.Maybe
@@ -27,8 +27,10 @@ import Data.Char (isUpper)
2727import qualified Data.Text as T
2828import qualified Data.Vector as V
2929import qualified ProjectM36.TypeConstructorDef as TCD
30−import Control.Monad.Trans.Except
31−import Control.Monad.Trans.Reader as R
30+import Control.Monad.Except
31+import Control.Monad.Trans.Except (except)
32+import Control.Monad.Reader as R
33+import ProjectM36.NormalizeExpr
3234import Test.QuickCheck
3335import GHC
3436import GHC.Paths
@@ -38,6 +40,9 @@ import qualified Data.List.NonEmpty as NE
3840import Data.Functor.Identity
3941import Control.Monad
4042import Control.Monad.IO.Class
43+#if __GLASGOW_HASKELL__ <= 802
44+import Data.Monoid
45+#endif
4146
4247data DatabaseContextExprDetails = CountUpdatedTuples
4348
@@ -69,15 +74,35 @@ data RelationalExprEnv = RelationalExprEnv {
6974 re_extra :: Maybe (Either RelationTuple Attributes)
7075 }
7176
72−stateTuple :: RelationalExprEnv -> RelationTuple
73−stateTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (re_extra e))
77+envTuple :: GraphRefRelationalExprEnv -> RelationTuple
78+envTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (gre_extra e))
7479
75−stateAttributes :: RelationalExprEnv -> Attributes
76−stateAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (re_extra e))
80+envAttributes :: GraphRefRelationalExprEnv -> Attributes
81+envAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (gre_extra e))
7782
7883instance Show RelationalExprEnv where
7984 show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)
8085
86+--used to eval relationalexpr
87+type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a
88+
89+reGraph :: RelationalExprM TransactionGraph
90+reGraph = re_graph <$> R.ask
91+
92+gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction
93+gfTransForId tid = do
94+ graph <- gfGraph
95+ lift $ except $ transactionForId tid graph
96+
97+currentTrans :: RelationalExprM Transaction
98+currentTrans = do
99+ tid <- re_currentTransId <$> R.ask
100+ graph <- re_graph <$> R.ask
101+ lift $ except $ transactionForId tid graph
102+
103+reTransId :: RelationalExprM TransactionId
104+reTransId = re_currentTransId <$> R.ask
105+
81106mkRelationalExprEnv :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprEnv
82107mkRelationalExprEnv ctx currentTransId graph =
83108 RelationalExprEnv
@@ -86,27 +111,21 @@ mkRelationalExprEnv ctx currentTransId graph =
86111 re_currentTransId = currentTransId,
87112 re_extra = Nothing }
88113
89−askEnv :: RelationalExprState RelationalExprEnv
114+askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
90115askEnv = R.ask
91116
92−currentTrans :: RelationalExprState (Either RelationalError Transaction)
93−currentTrans = do
94− tid <- re_currentTransId <$> R.ask
95− graph <- re_graph <$> R.ask
96− pure (transactionForId tid graph)
97−
98−mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprEnv -> RelationalExprEnv
99−mergeTuplesIntoRelationalExprState tupIn e@RelationalExprEnv{} =
100− e{re_extra = new_elems }
117+mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
118+mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =
119+ e{ gre_extra = new_elems }
101120 where
102121 new_elems = Just (Left newTuple)
103− mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (stateTuple e))
122+ mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))
104123 newTuple = mkRelationTupleFromMap mergedTupMap
105124
106−mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprEnv -> RelationalExprEnv
107−mergeAttributesIntoRelationalExprState attrsIn e@RelationalExprEnv{} = e{re_extra = newattrs }
125+mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
126+mergeAttributesIntoGraphRefRelationalExprEnv attrsIn e = e { gre_extra = newattrs }
108127 where
109− newattrs = Just (Right (A.union attrsIn (stateAttributes e)))
128+ newattrs = Just (Right (A.union attrsIn (envAttributes e)))
110129
111130type ResultAccumName = StringType
112131
@@ -156,9 +175,25 @@ putStateContext ctx' = do
156175 s <- get
157176 put (s {dbc_context = ctx'})
158177
159−type RelationalExprState a = Reader RelationalExprEnv a
178+data GraphRefRelationalExprEnv =
179+ GraphRefRelationalExprEnv {
180+ gre_graph :: TransactionGraph,
181+ gre_extra :: Maybe (Either RelationTuple Attributes)
182+ }
183+
184+type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a
185+
186+runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a
187+runGraphRefRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))
188+
189+freshGraphRefRelationalExprEnv :: TransactionGraph -> GraphRefRelationalExprEnv
190+freshGraphRefRelationalExprEnv graph = GraphRefRelationalExprEnv {
191+ gre_graph = graph,
192+ gre_extra = Nothing
193+ }
160194
161−type GraphRefRelationalExprR a = Reader TransactionGraph a
195+gfGraph :: GraphRefRelationalExprM TransactionGraph
196+gfGraph = gre_graph <$> R.ask
162197
163198envContext :: RelationalExprEnv -> DatabaseContext
164199envContext = re_context
@@ -354,12 +389,12 @@ evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do
354389 relvars <- fmap relationVariables getStateContext
355390 tConss <- fmap typeConstructorMapping getStateContext
356391 relEnv <- dbcRelationalExprEnv
357− let eAttrs = runReader (mapM evalGraphRefAttrExpr attrExprs) relEnv
358− attrErrs = lefts eAttrs
359− attrsList = rights eAttrs
360− if not (null attrErrs) then
361− dbErr (someErrors attrErrs)
362− else do
392+ graph <- dbcGraph
393+ let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)
394+ gfEnv = freshGraphRefRelationalExprEnv graph
395+ case eAttrs of
396+ Left err -> dbErr err
397+ Right attrsList -> do
363398 let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList
364399 if not (null atomTypeErrs) then
365400 dbErr (someErrors atomTypeErrs)
@@ -381,8 +416,9 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do
381416 Nothing -> do
382417 setRelVar relVarName expr
383418 Just existingRel -> do
384− let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) graph
385− eNewExprType = runReader (typeForGraphRefRelationalExpr expr) graph
419+ let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)
420+ eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)
421+ reEnv = freshGraphRefRelationalExprEnv graph
386422 case eExpectedType of
387423 Left err -> dbErr err
388424 Right expectedType ->
@@ -410,7 +446,7 @@ evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do
410446evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do
411447 context <- getStateContext
412448 transId <- dbcTransId
413− reEnv <- dbcRelationalExprEnv
449+ graph <- dbcGraph
414450 let relVarMap = relationVariables context
415451 case M.lookup relVarName relVarMap of
416452 Nothing -> dbErr (RelVarNotDefinedError relVarName)
@@ -422,7 +458,7 @@ evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do
422458 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
423459 restrictedPortion = Restrict pred'
424460 updated = foldr (\(oldname, atomExpr) accum ->
425− let procAtomExpr = runReader (processAtomExpr atomExpr) reEnv in
461+ let procAtomExpr = runProcessExprM transId graph (processAtomExpr atomExpr) in
426462 updateAttr oldname procAtomExpr accum
427463 ) rv (M.toList atomExprMap)
428464 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
@@ -537,9 +573,11 @@ evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
537573evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
538574 context <- getStateContext
539575 relExprEnv <- dbcRelationalExprEnv
576+ graph <- dbcGraph
540577 --resolve atom arguments
541− let eAtomTypes = map (\atomExpr -> runReader (typeForGraphRefAtomExpr emptyAttributes atomExpr) relExprEnv) atomArgExprs
578+ let eAtomTypes = mapM (\atomExpr -> runGraphRefRelationalExprM gfEnv (typeForGraphRefAtomExpr emptyAttributes atomExpr)) atomArgExprs
542579 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
580+ gfEnv = freshGraphRefRelationalExprEnv graph
543581 case eFunc of
544582 Left err -> dbErr err
545583 Right func -> do
@@ -549,10 +587,9 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg
549587 dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
550588 else
551589 --check that the atom types are valid
552− case lefts eAtomTypes of
553− _:_ -> dbErr (someErrors (lefts eAtomTypes))
554− [] -> do
555− let atomTypes = rights eAtomTypes
590+ case eAtomTypes of
591+ Left err -> dbErr err
592+ Right atomTypes -> do
556593 let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of
557594 Left err -> Just err
558595 Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)
@@ -711,36 +748,39 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs
711748 graph = dbcio_graph env
712749 case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of
713750 Left err -> pure (Left err)
714− Right state -> do
751+ Right dbstate -> do
715752 --Assign
716753 let existingRelVar = M.lookup relVarName relVarTable
717− relVarTable = relationVariables (dbc_context state)
754+ relVarTable = relationVariables (dbc_context dbstate)
718755 case existingRelVar of
719756 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
720757 Just existingRel -> do
721− case runReader (typeForGraphRefRelationalExpr existingRel) graph of
758+ let env = freshGraphRefRelationalExprEnv graph
759+ case runGraphRefRelationalExprM env (typeForGraphRefRelationalExpr existingRel) of
722760 Left err -> pure (Left err)
723761 Right relType -> do
724762 let expectedAttributes = attributes relType
725− tcMap = typeConstructorMapping (dbc_context state)
763+ tcMap = typeConstructorMapping (dbc_context dbstate)
726764 eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
727765 case eitherRel of
728766 Left err -> pure $ Left err
729767 Right rel ->
730768 case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of
731769 Left err -> pure (Left err)
732− Right state -> putDBCIOContext (dbc_context state)
770+ Right dbstate' -> putDBCIOContext (dbc_context dbstate')
733771
772+{-
734773updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple
735774updateTupleWithAtomExprs exprMap context graph tupIn = do
736775 --resolve all atom exprs
776+ let
737777 atomsAssoc <- mapM (\(attrName, atomExpr) -> do
738778 let atom = unimplemented
739779 --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)
740780 pure (attrName, atom)
741781 ) (M.toList exprMap)
742782 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
743−
783+-}
744784--run verification on all constraints
745785checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
746786checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
@@ -756,14 +796,19 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
756796 reEnv = mkRelationalExprEnv context transId graph
757797 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment
758798 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
759− let gfSubsetExpr = runReader (processRelationalExpr subsetExpr) reEnv
760− gfSupersetExpr = runReader (processRelationalExpr supersetExpr) reEnv
799+ let process = runProcessExprM transId graph
800+ gfSubsetExpr = process (processRelationalExpr subsetExpr)
801+ gfSupersetExpr = process (processRelationalExpr supersetExpr)
761802 --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.
762− typeSub <- runReader (typeForRelationalExpr subsetExpr) reEnv
763− typeSuper <- runReader (typeForRelationalExpr supersetExpr) reEnv
803+ let gfEnv = freshGraphRefRelationalExprEnv graph
804+ runGfRel = runGraphRefRelationalExprM gfEnv
805+ typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)
806+ typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)
764807 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
765808 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)
766− case evalGraphRefRelationalExpr checkExpr potentialGraph of
809+ gfEvald = runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr checkExpr)
810+ gfEnv = freshGraphRefRelationalExprEnv potentialGraph
811+ case gfEvald of
767812 Left err -> Left err
768813 Right resultRel -> if resultRel == relationTrue then
769814 pure ()
@@ -773,13 +818,16 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
773818-- 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
774819-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
775820
776−typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
821+typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation
777822typeForRelationalExpr expr = do
778823 --replace the relationVariables context element with a cloned set of relation devoid of tuples
779824 --evalRelationalExpr could still return an existing relation with tuples, so strip them
780− gfExpr <- processRelationalExpr expr
781− graph <- re_graph <$> askEnv
782− pure $ runReader (typeForGraphRefRelationalExpr gfExpr) graph
825+ graph <- reGraph
826+ transId <- reTransId
827+ let gfExpr = runProcessExprM transId graph (processRelationalExpr expr)
828+ gfEnv = freshGraphRefRelationalExprEnv graph
829+ runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
830+ lift $ except $ runGf
783831
784832--returns a database context with all tuples removed
785833--this is useful for type checking and optimization
@@ -794,67 +842,66 @@ liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
794842liftE v = do
795843 y <- lift v
796844 case y of
797− Left err -> throwE err
845+ Left err -> throwError err
798846 Right val -> pure val
799847
800848{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
801−predicateRestrictionFilter :: Attributes -> RestrictionPredicateExprBase a -> RelationalExprState (Either RelationalError RestrictionFilter)
802−predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =
803− runExceptT $ do
804− expr1v <- liftE (predicateRestrictionFilter attrs expr1)
805− expr2v <- liftE (predicateRestrictionFilter attrs expr2)
806− pure (\x -> do
807− ev1 <- expr1v x
808− ev2 <- expr2v x
809− pure (ev1 && ev2))
810−
811−predicateRestrictionFilter attrs (OrPredicate expr1 expr2) =
812− runExceptT $ do
813− expr1v <- liftE (predicateRestrictionFilter attrs expr1)
814− expr2v <- liftE (predicateRestrictionFilter attrs expr2)
849+predicateRestrictionFilter :: Attributes -> GraphRefRestrictionPredicateExpr -> GraphRefRelationalExprM RestrictionFilter
850+predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do
851+ expr1v <- predicateRestrictionFilter attrs expr1
852+ expr2v <- predicateRestrictionFilter attrs expr2
853+ pure (\x -> do
854+ ev1 <- expr1v x
855+ ev2 <- expr2v x
856+ pure (ev1 && ev2))
857+
858+predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do
859+ expr1v <- predicateRestrictionFilter attrs expr1
860+ expr2v <- predicateRestrictionFilter attrs expr2
815861 pure (\x -> do
816862 ev1 <- expr1v x
817863 ev2 <- expr2v x
818864 pure (ev1 || ev2))
819865
820−predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))
866+predicateRestrictionFilter _ TruePredicate = pure (\_ -> pure True)
821867
822−predicateRestrictionFilter attrs (NotPredicate expr) =
823− runExceptT $ do
824− exprv <- liftE (predicateRestrictionFilter attrs expr)
825− pure (fmap not . exprv)
868+predicateRestrictionFilter attrs (NotPredicate expr) = do
869+ exprv <- predicateRestrictionFilter attrs expr
870+ pure (fmap not . exprv)
826871
827872--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
828−{-
829873predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do
830− rstate <- ask
831− pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of
874+ renv <- askEnv
875+ let eval :: RelationTuple -> Either RelationalError Relation
876+ eval tup =
877+ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in
878+ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)
879+ pure (\tup -> case eval tup of
832880 Left err -> Left err
833881 Right rel -> if arity rel /= 0 then
834882 Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
835883 else
836− pure (rel == relationTrue)))
884+ pure (rel == relationTrue))
837885
838886predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
839− rstate <- ask
840− let attrs' = stateAttributes rstate
841− ctxtup' = stateTuple rstate
842− runExceptT $ do
843− atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr)
844− attr <- either throwE pure $ case A.attributeForName attrName attrs of
887+ env <- askEnv
888+ let attrs' = envAttributes env
889+ ctxtup' = envTuple env
890+ atomExprType <- typeForGraphRefAtomExpr attrs' atomExpr
891+ attr <- lift $ except $ case A.attributeForName attrName attrs of
845892 Right attr -> Right attr
846893 Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of
847894 Right ctxattr -> Right ctxattr
848895 Left err2@(NoSuchAttributeNamesError _) -> Left err2
849896 Left err -> Left err
850897 Left err -> Left err
851− if atomExprType /= A.atomType attr then
852− throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
853− else
898+ if atomExprType /= A.atomType attr then
899+ throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
900+ else
854901 pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of
855902 Right atomCmp -> atomCmp == atomIn
856903 Left _ -> False
857− atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate
904+ atomEvald = runGraphRefRelationalExprM env (evalGraphRefAtomExpr tupleIn atomExpr)
858905 in
859906 pure $ case atomForAttributeName attrName tupleIn of
860907 Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of
@@ -865,43 +912,44 @@ predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr)
865912-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
866913predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
867914 --merge attrs into the state attributes
868− rstate <- ask
869− runExceptT $ do
870− aType <- liftE (typeFromAtomExpr attrs atomExpr)
871− if aType /= BoolAtomType then
872− throwE (AtomTypeMismatchError aType BoolAtomType)
873− else
915+ renv <- askEnv
916+ aType <- typeForGraphRefAtomExpr attrs atomExpr
917+ if aType /= BoolAtomType then
918+ throwError (AtomTypeMismatchError aType BoolAtomType)
919+ else
874920 pure (\tupleIn ->
875− case runReader (evalAtomExpr tupleIn atomExpr) rstate of
876− Left err -> Left err
877− Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))
878−-}
921+ case runGraphRefRelationalExprM renv (evalGraphRefAtomExpr tupleIn atomExpr) of
922+ Left err -> Left err
923+ Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))
924+
879925tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
880926tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then
881927 Left (AttributeNameInUseError attrName)
882928 else
883929 Right rel
884930
885−extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
886−extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
887− rstate <- askEnv
931+extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)
932+extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
933+ renv <- askEnv
888934 -- check that the attribute name is not in use
889935 case tupleExprCheckNewAttrName newAttrName relIn of
890− Left err -> pure (Left err)
891− Right _ -> runExceptT $ do
892− atomExprType <- liftE (typeFromAtomExpr (attributes relIn) atomExpr)
893− atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)
936+ Left err -> throwError err
937+ Right _ -> do
938+ atomExprType <- typeForGraphRefAtomExpr (attributes relIn) atomExpr
939+ atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType
894940 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
895941 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
896− pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in
942+ pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in
897943 case unimplemented {-runReader (evalAtomExpr tup atomExpr) substate-} of
898944 Left err -> Left err
899945 Right atom -> Right (tupleAtomExtend newAttrName atom tup)
900946 )
901947
948+evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
949+evalGraphRefAtomExpr = unimplemented
902950
903−evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)
904−evalAtomExpr = undefined
951+evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom
952+evalAtomExpr = unimplemented
905953{-
906954
907955evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
@@ -950,143 +998,129 @@ evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExcept
950998 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
951999 pure (ConstructedAtom dConsName aType argAtoms)
9521000-}
953−typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> RelationalExprState (Either RelationalError AtomType)
1001+typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
9541002typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do
955− rstate <- askEnv
1003+ renv <- askEnv
9561004 case A.atomTypeForAttributeName attrName attrs of
957− Right aType -> pure (Right aType)
1005+ Right aType -> pure aType
9581006 Left err@(NoSuchAttributeNamesError _) ->
959− let stateTup = stateTuple rstate
960− stateAttrs = stateAttributes rstate in
961− case A.attributeForName attrName stateAttrs of
962− Right attr -> pure (Right (A.atomType attr))
963− Left _ -> case atomForAttributeName attrName stateTup of
964− Right atom -> pure (Right (atomTypeForAtom atom))
965− Left _ -> pure (Left err)
966−
967−typeForGraphAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
968−typeForGraphAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
969− context <- fmap envContext askEnv
970− let funcs = atomFunctions context
1007+ let envTup = envTuple renv
1008+ envAttrs = envAttributes renv in
1009+ case A.attributeForName attrName envAttrs of
1010+ Right attr -> pure (A.atomType attr)
1011+ Left _ -> case atomForAttributeName attrName envTup of
1012+ Right atom -> pure (atomTypeForAtom atom)
1013+ Left _ -> throwError err
1014+
1015+typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)
1016+typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do
1017+ funcs <- atomFunctions . concreteDatabaseContext <$> gfTransForId transId
9711018 case atomFunctionForName funcName funcs of
972− Left err -> pure (Left err)
1019+ Left err -> throwError err
9731020 Right func -> do
9741021 let funcRetType = last (atomFuncType func)
9751022 funcArgTypes = init (atomFuncType func)
976− eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs
977− case lefts eArgTypes of
978− errs@(_:_) -> pure (Left (someErrors errs))
979− [] -> do
980− let eTvMap = resolveTypeVariables funcArgTypes argTypes
981− argTypes = rights eArgTypes
982− case eTvMap of
983− Left err -> pure (Left err)
984− Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
985−typeFromAtomExpr attrs (RelationAtomExpr relExpr) = do
986− relType <- R.local (mergeAttributesIntoRelationalExprState attrs) (typeForRelationalExpr relExpr)
987− case relType of
988− Left err -> pure (Left err)
989− Right relType' ->
990− pure (pure (RelationAtomType (attributes relType')))
1023+ argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs
1024+ let eTvMap = resolveTypeVariables funcArgTypes argTypes
1025+ case eTvMap of
1026+ Left err -> throwError err
1027+ Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName tvMap funcRetType
1028+typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do
1029+ relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)
1030+ pure (RelationAtomType (attributes relType))
9911031-- grab the type of the data constructor, then validate that the args match the expected types
992−typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
993− runExceptT $ do
994− argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs
995− context <- fmap envContext (lift askEnv)
996− either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
1032+typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =
1033+ do
1034+ argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs
1035+ tConsMap <- typeConstructorMapping . concreteDatabaseContext <$> gfTransForId tid
1036+ lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes
9971037
9981038-- | Validate that the type of the AtomExpr matches the expected type.
999−verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
1000−verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
1001− rstate <- lift askEnv
1039+verifyGraphRefAtomExprTypes :: Relation -> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
1040+verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do
1041+ env <- askEnv
10021042 case A.atomTypeForAttributeName attrName (attributes relIn) of
1003− Right aType -> either throwE pure (atomTypeVerify expectedType aType)
1043+ Right aType -> lift $ except $ atomTypeVerify expectedType aType
10041044 (Left err@(NoSuchAttributeNamesError _)) ->
1005− let attrs' = stateAttributes rstate in
1045+ let attrs' = envAttributes env in
10061046 if attrs' == emptyAttributes then
1007− throwE err
1047+ throwError err
10081048 else
10091049 case A.attributeForName attrName attrs' of
1010− Left err' -> throwE err'
1011− Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
1012−verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
1013−verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
1014− rstate <- askEnv
1050+ Left err' -> throwError err'
1051+ Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)
1052+verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =
1053+ lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)
1054+verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) expectedType = do
1055+ context <- concreteDatabaseContext <$> gfTransForId tid
10151056 let functions = atomFunctions context
1016− context = envContext rstate
1017− runExceptT $ do
1018− func <- either throwE pure (atomFunctionForName funcName functions)
1019− let expectedArgTypes = atomFuncType func
1020− funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of
1021− Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)
1022− Left err -> throwE err
1023− Right x -> pure x
1024− ) $ zip3 funcArgExprs expectedArgTypes [1..]
1025− if length funcArgTypes /= length expectedArgTypes - 1 then
1026− throwE (AtomTypeCountError funcArgTypes expectedArgTypes)
1057+ func <- lift $ except $ atomFunctionForName funcName functions
1058+ let expectedArgTypes = atomFuncType func
1059+ funcArgVerifier (atomExpr, expectedType2, argCount) = do
1060+ let handler :: RelationalError -> GraphRefRelationalExprM AtomType
1061+ handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)
1062+ handler err = throwError err
1063+ verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler
1064+ funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]
1065+ if length funcArgTypes /= length expectedArgTypes - 1 then
1066+ throwError (AtomTypeCountError funcArgTypes expectedArgTypes)
10271067 else
1028− either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
1029−verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
1030− rstate <- lift askEnv
1031− relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
1032− either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
1033−verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do
1034− cType <- liftE (typeFromAtomExpr (attributes rel) cons)
1035− either throwE pure (atomTypeVerify expectedType cType)
1068+ lift $ except $ atomTypeVerify expectedType (last expectedArgTypes)
1069+verifyGraphRefAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType =
1070+ do
1071+ let mergedAttrsEnv e = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) e
1072+ relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)
1073+ lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType))
1074+verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do
1075+ cType <- typeForGraphRefAtomExpr (attributes rel) cons
1076+ lift $ except $ atomTypeVerify expectedType cType
10361077
10371078-- | Look up the type's name and create a new attribute.
1038−evalGraphRefAttrExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)
1079+evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
10391080evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do
1040− graph <- re_graph <$> askEnv
1041− case transactionForId transId graph of
1042− Left err -> pure (Left err)
1043− Right trans -> do
1044− let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)
1045− validate = do
1046− aType <- atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
1047− validateAtomType aType tConsMap
1048− pure aType
1049− case validate of
1050− Left err -> pure (Left err)
1051− Right aType ->
1052− pure $ Right (Attribute attrName aType)
1081+ tConsMap <- typeConstructorMapping . concreteDatabaseContext <$> gfTransForId transId
1082+ aType <- lift $ except $ atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
1083+ lift $ except $ validateAtomType aType tConsMap
1084+ pure $ Attribute attrName aType
10531085
1054−evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure $ Right attr
1086+evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure attr
10551087
1056−evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
1057−evalTupleExpr mAttrs (TupleExpr tupMap) = do
1058− context <- fmap envContext askEnv
1059− runExceptT $ do
1088+evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple
1089+evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do
10601090 -- 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
10611091 -- 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
1062− let attrs = fromMaybe A.emptyAttributes mAttrs
1063− attrAtoms <- mapM (\(attrName, aExpr) -> do
1064− --provided when the relation header is available
1065− let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs
1066− unresolvedType <- liftE (typeFromAtomExpr attrs aExpr)
1067− resolvedType <- case eExpectedAtomType of
1092+ let attrs = fromMaybe A.emptyAttributes mAttrs
1093+ resolveOneAtom (attrName, aExpr) =
1094+ do
1095+ --provided when the relation header is available
1096+ let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs
1097+ unresolvedType <- typeForGraphRefAtomExpr attrs aExpr
1098+ resolvedType <- case eExpectedAtomType of
10681099 Left _ -> pure unresolvedType
1069− Right typeHint -> either throwE pure (resolveAtomType typeHint unresolvedType)
1100+ Right typeHint -> lift $ except $ resolveAtomType typeHint unresolvedType
10701101 --resolve atom typevars based on resolvedType?
1071− newAtom <- liftE (evalAtomExpr emptyTuple aExpr)
1072− pure (attrName, newAtom, resolvedType)
1073− ) (M.toList tupMap)
1074− let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
1075− atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
1076− tup = mkRelationTuple tupAttrs atoms
1077− tConss = typeConstructorMapping context
1078− finalAttrs = fromMaybe tupAttrs mAttrs
1102+ newAtom <- evalGraphRefAtomExpr emptyTuple aExpr
1103+ pure (attrName, newAtom, resolvedType)
1104+ attrAtoms <- mapM resolveOneAtom (M.toList tupMap)
1105+ let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
1106+ atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
1107+ tup = mkRelationTuple tupAttrs atoms
1108+ finalAttrs = fromMaybe tupAttrs mAttrs
10791109 --verify that the attributes match
1080− when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)
1081− tup' <- either throwE pure (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))
1082− _ <- either throwE pure (validateTuple tup' tConss)
1083− pure tup'
1110+ when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)
1111+ --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held
1112+-- tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))
1113+ let tup' = reorderTuple finalAttrs tup
1114+ --TODO: restore type resolution
1115+-- _ <- lift $ except (validateTuple tup' tConss)
1116+ pure tup'
10841117
1085−evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))
1118+{-
1119+evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))
10861120evalAttributeNames attrNames expr = do
10871121 eExprType <- typeForRelationalExpr expr
10881122 case eExprType of
1089− Left err -> pure (Left err)
1123+ Left err -> throwError err
10901124 Right exprTyp -> do
10911125 let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
10921126 case attrNames of
@@ -1129,14 +1163,15 @@ evalAttributeNames attrNames expr = do
11291163 case eAttrExprType of
11301164 Left err -> pure (Left err)
11311165 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
1166+-}
11321167
1133−evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation
1168+evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
11341169--evalGraphRefRelationalExpr (MakeRelationaFromExprs
1135−evalGraphRefRelationalExpr (RelationVariable name tid) graph = do
1136− ctx <- dbContextForTransId tid graph
1170+evalGraphRefRelationalExpr (RelationVariable name tid) = do
1171+ ctx <- concreteDatabaseContext <$> gfTransForId tid
11371172 case M.lookup name (relationVariables ctx) of
1138− Nothing -> Left (RelVarNotDefinedError name)
1139− Just rv -> evalGraphRefRelationalExpr rv graph
1173+ Nothing -> throwError (RelVarNotDefinedError name)
1174+ Just rv -> evalGraphRefRelationalExpr rv
11401175
11411176
11421177dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext
@@ -1155,165 +1190,64 @@ transactionForId tid graph
11551190 where
11561191 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
11571192
1158−processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState GraphRefRestrictionPredicateExpr
1159−processRestrictionPredicateExpr TruePredicate = pure TruePredicate
1160−processRestrictionPredicateExpr (AndPredicate a b) = AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
1161−processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
1162−processRestrictionPredicateExpr (NotPredicate a) = NotPredicate <$> processRestrictionPredicateExpr a
1163−processRestrictionPredicateExpr (RelationalExprPredicate expr) =
1164− RelationalExprPredicate <$> processRelationalExpr expr
1165−processRestrictionPredicateExpr (AtomExprPredicate expr) =
1166− AtomExprPredicate <$> processAtomExpr expr
1167−processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) =
1168− AttributeEqualityPredicate nam <$> processAtomExpr expr
1169−
1170−processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState GraphRefExtendTupleExpr
1171−processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =
1172− AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr
1173−
1174−typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprR (Either RelationalError Relation)
1175−typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = pure $ mkRelation attrs emptyTupleSet
1176−typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (Right (emptyRelationWithAttrs (attributes rel)))
1193+typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
1194+typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet
1195+typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))
11771196typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =
11781197 case mAttrExprs of
11791198 Just attrExprs -> do
1180− eAttrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs
1181− case lefts eAttrs of
1182− [] -> pure (Right (emptyRelationWithAttrs (attributesFromList (rights eAttrs))))
1183− _ -> pure (Left (someErrors (lefts eAttrs)))
1199+ attrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs
1200+ pure (emptyRelationWithAttrs (attributesFromList attrs))
11841201typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do
1185− graph <- R.ask
1186− let eTrans = transactionForId tid graph
1187− case eTrans of
1188− Left err -> pure (Left err)
1189− Right trans -> do
1190− let relVars = relationVariables (concreteDatabaseContext trans)
1191− case M.lookup rvName relVars of
1192− Nothing -> pure (Left (RelVarNotDefinedError rvName))
1193− Just rvExpr -> typeForGraphRefRelationalExpr rvExpr
1202+ relVars <- relationVariables . concreteDatabaseContext <$> gfTransForId tid
1203+ case M.lookup rvName relVars of
1204+ Nothing -> throwError (RelVarNotDefinedError rvName)
1205+ Just rvExpr -> typeForGraphRefRelationalExpr rvExpr
11941206typeForGraphRefRelationalExpr (Project attrNames expr) = do
1195− eExprType <- typeForGraphRefRelationalExpr expr
1196− case eExprType of
1197− Left err -> pure (Left err)
1198− Right exprType -> do
1199− eProjectionAttrs <- evalGraphRefAttributeNames attrNames expr
1200− pure $ case eProjectionAttrs of
1201− Left err -> Left err
1202− Right projectionAttrs -> project projectionAttrs exprType
1207+ exprType <- typeForGraphRefRelationalExpr expr
1208+ projectionAttrs <- evalGraphRefAttributeNames attrNames expr
1209+ lift $ except $ project projectionAttrs exprType
12031210
1204−evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprR (Either RelationalError (S.Set AttributeName))
1211+evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)
12051212evalGraphRefAttributeNames attrNames expr = do
1206− eExprType <- typeForGraphRefRelationalExpr expr
1207− case eExprType of
1208− Left err -> pure (Left err)
1209− Right exprTyp -> do
1210− let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
1211− case attrNames of
1212− AttributeNames names ->
1213− case A.projectionAttributesForNames names (attributes exprTyp) of
1214− Left err -> pure (Left err)
1215− Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))
1213+ exprType <- typeForGraphRefRelationalExpr expr
1214+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType)))
1215+ case attrNames of
1216+ AttributeNames names ->
1217+ case A.projectionAttributesForNames names (attributes exprType) of
1218+ Left err -> throwError err
1219+ Right attrs -> pure (S.fromList (V.toList (A.attributeNames attrs)))
12161220
1217− InvertedAttributeNames names -> do
1221+ InvertedAttributeNames names -> do
12181222 let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
12191223 if not (S.null nonExistentAttributeNames) then
1220− pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))
1224+ throwError (AttributeNamesMismatchError nonExistentAttributeNames)
12211225 else
1222− pure (pure (A.nonMatchingAttributeNameSet names typeNameSet))
1223−
1224− UnionAttributeNames namesA namesB -> do
1225− eNameSetA <- evalGraphRefAttributeNames namesA expr
1226− case eNameSetA of
1227− Left err -> pure (Left err)
1228− Right nameSetA -> do
1229− eNameSetB <- evalGraphRefAttributeNames namesB expr
1230− case eNameSetB of
1231− Left err -> pure (Left err)
1232− Right nameSetB ->
1233− pure (Right (S.union nameSetA nameSetB))
1226+ pure (A.nonMatchingAttributeNameSet names typeNameSet)
12341227
1235− IntersectAttributeNames namesA namesB -> do
1236− eNameSetA <- evalGraphRefAttributeNames namesA expr
1237− case eNameSetA of
1238− Left err -> pure (Left err)
1239− Right nameSetA -> do
1240− eNameSetB <- evalGraphRefAttributeNames namesB expr
1241− case eNameSetB of
1242− Left err -> pure (Left err)
1243− Right nameSetB ->
1244− pure (Right (S.intersection nameSetA nameSetB))
1228+ UnionAttributeNames namesA namesB -> do
1229+ nameSetA <- evalGraphRefAttributeNames namesA expr
1230+ nameSetB <- evalGraphRefAttributeNames namesB expr
1231+ pure (S.union nameSetA nameSetB)
12451232
1246− RelationalExprAttributeNames attrExpr -> do
1247− eAttrExprType <- typeForGraphRefRelationalExpr attrExpr
1248− case eAttrExprType of
1249− Left err -> pure (Left err)
1250− Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
1233+ IntersectAttributeNames namesA namesB -> do
1234+ nameSetA <- evalGraphRefAttributeNames namesA expr
1235+ nameSetB <- evalGraphRefAttributeNames namesB expr
1236+ pure (S.intersection nameSetA nameSetB)
12511237
1238+ RelationalExprAttributeNames attrExpr -> do
1239+ attrExprType <- typeForGraphRefRelationalExpr attrExpr
1240+ pure (A.attributeNameSet (attributes attrExprType))
12521241
1253−
1254−
1255−processAtomExpr :: AtomExpr -> RelationalExprState GraphRefAtomExpr
1256−processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam
1257−processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
1258−processAtomExpr (FunctionAtomExpr fName atomExprs ()) = do
1259− tid <- re_currentTransId <$> askEnv
1260− FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> pure tid
1261−processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr
1262−processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> (re_currentTransId <$> askEnv)
1263−
1264−processTupleExpr :: TupleExpr -> RelationalExprState GraphRefTupleExpr
1265−processTupleExpr (TupleExpr tMap) =
1266− TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)
1267−
1268−evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprR (Either RelationalError Attribute)
1242+evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
12691243evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
1270− graph <- R.ask
1271− case transactionForId tid graph of
1272− Left err -> pure (Left err)
1273− Right trans -> do
1274− let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)
1275− case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of
1276− Left err -> pure (Left err)
1277− Right aType -> do
1278− case validateAtomType aType tConsMap of
1279− Left err -> pure (Left err)
1280− Right _ -> pure (Right (Attribute attrName aType))
1281−
1282−--convert AttributeExpr to GraphRefAttributeExpr
1283−processAttributeExpr :: AttributeExpr -> RelationalExprState GraphRefAttributeExpr
1284−processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) = do
1285− tid <- re_currentTransId <$> askEnv
1286− pure $ AttributeAndTypeNameExpr nam tCons tid
1287−processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr
1288−
1289−-- convert a RelationalExpr into a GraphRefRelationalExpr using the current trans Id
1290−-- can this be done without any RelationalErrors as opposed to evalRelationalExpr?
1291−processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr
1292−processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do
1293− mAttrs' <- case mAttrs of
1294− Nothing -> pure Nothing
1295− Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''
1296− MakeRelationFromExprs mAttrs' <$> mapM processTupleExpr tupleExprs
1297−processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)
1298−processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)
1299−processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> fmap re_currentTransId askEnv
1300−processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr
1301−processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1302−processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1303−processRelationalExpr (Rename attrA attrB expr) =
1304− Rename attrA attrB <$> processRelationalExpr expr
1305−processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1306−processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr
1307−processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr
1308−processRelationalExpr (Restrict pred expr) = Restrict <$> processRestrictionPredicateExpr pred <*> processRelationalExpr expr
1309−processRelationalExpr (Equals exprA exprB) =
1310− Equals <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1311−processRelationalExpr (NotEquals exprA exprB) =
1312− NotEquals <$> processRelationalExpr exprA <*> processRelationalExpr exprB
1313−processRelationalExpr (Extend extendExpr expr) =
1314− Extend <$> processExtendTupleExpr extendExpr <*> processRelationalExpr expr
1315−processRelationalExpr (With macros expr) =
1316− With <$> mapM (\(nam, wexpr) -> (,) nam <$> processRelationalExpr wexpr) macros <*> processRelationalExpr expr
1244+ tConsMap <- typeConstructorMapping . concreteDatabaseContext <$> gfTransForId tid
1245+ case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of
1246+ Left err -> throwError err
1247+ Right aType -> do
1248+ case validateAtomType aType tConsMap of
1249+ Left err -> throwError err
1250+ Right _ -> pure (Attribute attrName aType)
13171251
13181252mkEmptyRelVars :: RelationVariables -> RelationVariables
13191253mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap
@@ -1335,50 +1269,10 @@ mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap
13351269 mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)
13361270 mkEmptyRelVar (With macros expr) = With (map (\(rv, expr) -> (rv, mkEmptyRelVar expr)) macros) (mkEmptyRelVar expr)
13371271
1338−processAttributeNames :: AttributeNames -> RelationalExprState GraphRefAttributeNames
1339−processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet
1340−processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
1341−processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
1342−processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr
1343−
1344−processDatabaseContextExpr :: DatabaseContextExpr -> RelationalExprState GraphRefDatabaseContextExpr
1345−processDatabaseContextExpr expr =
1346− case expr of
1347− NoOperation -> pure NoOperation
1348− Define nam attrExprs -> Define nam <$> mapM processAttributeExpr attrExprs
1349− Undefine nam -> pure (Undefine nam)
1350− Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr
1351− Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr
1352− Delete nam pred -> Delete nam <$> processRestrictionPredicateExpr pred
1353− Update nam attrMap pred -> Update nam attrMap <$> processRestrictionPredicateExpr pred
1354−
1355− AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)
1356− RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)
1357− AddNotification nam exprA exprB exprC -> pure (AddNotification nam exprA exprB exprC)
1358− RemoveNotification nam -> pure (RemoveNotification nam)
1359− AddTypeConstructor tyDef consDefs -> pure (AddTypeConstructor tyDef consDefs)
1360− RemoveTypeConstructor tyName -> pure (RemoveTypeConstructor tyName)
1361−
1362− RemoveAtomFunction aFuncName -> pure (RemoveAtomFunction aFuncName)
1363− RemoveDatabaseContextFunction funcName -> pure (RemoveDatabaseContextFunction funcName)
1364− ExecuteDatabaseContextFunction funcName atomExprs -> ExecuteDatabaseContextFunction funcName <$> mapM processAtomExpr atomExprs
1365− MultipleExpr exprs -> MultipleExpr <$> mapM processDatabaseContextExpr exprs
13661272
13671273dbErr :: RelationalError -> DatabaseContextEvalMonad ()
13681274dbErr err = lift (except (Left err))
13691275
1370−processDatabaseContextIOExpr :: DatabaseContextIOExpr -> RelationalExprState GraphRefDatabaseContextIOExpr
1371−processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =
1372− pure (AddAtomFunction f tcs sc)
1373−processDatabaseContextIOExpr (LoadAtomFunctions mod fun file) =
1374− pure (LoadAtomFunctions mod fun file)
1375−processDatabaseContextIOExpr (AddDatabaseContextFunction mod fun path) =
1376− pure (AddDatabaseContextFunction mod fun path)
1377−processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod fun path) =
1378− pure (LoadDatabaseContextFunctions mod fun path)
1379−processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =
1380− CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range
1381−
13821276-- | Return a Relation describing the relation variables.
13831277relationVariablesAsRelation :: RelationVariables -> TransactionGraph -> Either RelationalError Relation
13841278relationVariablesAsRelation relVarMap graph = do
@@ -1386,7 +1280,8 @@ relationVariablesAsRelation relVarMap graph = do
13861280 attrs = A.attributesFromList [Attribute "name" TextAtomType,
13871281 Attribute "attributes" (RelationAtomType subrelAttrs)]
13881282 mkRvDesc (rvName, gfExpr) = do
1389− gfType <- runReader (typeForGraphRefRelationalExpr gfExpr) graph
1283+ let gfEnv = freshGraphRefRelationalExprEnv graph
1284+ gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
13901285 pure (rvName, gfType)
13911286 relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]
13921287 attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]