@@ -7,7 +7,7 @@ import ProjectM36.Base
77import qualified Data.UUID as U
88import ProjectM36.Error
99import ProjectM36.AtomType
10−import ProjectM36.Attribute (emptyAttributes)
10+import ProjectM36.Attribute (emptyAttributes, attributesFromList)
1111import ProjectM36.ScriptSession
1212import ProjectM36.DataTypes.Primitive
1313import ProjectM36.AtomFunction
@@ -85,6 +85,12 @@ mkRelationalExprState ctx currentTransId graph =
8585 elems_graph = graph,
8686 elems_currentTransId = currentTransId,
8787 elems_extra = Nothing }
88+
89+currentTrans :: RelationalExprState (Either RelationalError Transaction)
90+currentTrans = do
91+ tid <- elems_currentTransId <$> ask
92+ graph <- elems_graph <$> ask
93+ pure (transactionForId tid graph)
8894
8995mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems
9096mergeTuplesIntoRelationalExprState tupIn e@RelationalExprStateElems{} =
@@ -340,7 +346,7 @@ evalDatabaseContextExpr (Assign relVarName expr) transId graph = do
340346 Left err -> pure (Left err)
341347 Right rvExpr -> setRelVar relVarName rvExpr transId graph
342348 Just existingRel -> do
343− let eExpectedType = typeForGraphRefRelationalExpr existingRel graph
349+ let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprState context transId graph)
344350 eNewExprType = runReader (typeForRelationalExpr expr) relExprState
345351 case eExpectedType of
346352 Left err -> pure (Left err)
@@ -387,7 +393,7 @@ evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr)
387393 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
388394 restrictedPortion = Restrict graphRefPredicate
389395 updated = foldr (\(oldname, atomExpr) accum ->
390− let procAtomExpr = processAtomExpr atomExpr transId in
396+ let procAtomExpr = runReader (processAtomExpr atomExpr) rvState in
391397 updateAttr oldname procAtomExpr accum
392398 ) rv (M.toList atomExprMap)
393399 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
@@ -633,7 +639,7 @@ evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelatio
633639 case existingRelVar of
634640 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
635641 Just existingRel -> do
636− case typeForGraphRefRelationalExpr existingRel graph of
642+ case runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprState currentContext transId graph) of
637643 Left err -> pure (Left err)
638644 Right relType -> do
639645 let expectedAttributes = attributes relType
@@ -690,11 +696,10 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =
690696
691697typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
692698typeForRelationalExpr expr = do
693− graph <- elems_graph <$> ask
694699 --replace the relationVariables context element with a cloned set of relation devoid of tuples
695700 --evalRelationalExpr could still return an existing relation with tuples, so strip them
696701 gfExpr <- processRelationalExpr expr
697− pure (typeForGraphRefRelationalExpr gfExpr graph)
702+ typeForGraphRefRelationalExpr gfExpr
698703
699704--returns a database context with all tuples removed
700705--this is useful for type checking and optimization
@@ -1090,44 +1095,54 @@ processRestrictionPredicateExpr (RelationalExprPredicate expr) = do
10901095 Left err -> Left err
10911096 Right e' -> Right (RelationalExprPredicate e')
10921097processRestrictionPredicateExpr (AtomExprPredicate expr) = do
1093− tid <- elems_currentTransId <$> ask
1094− let e = processAtomExpr expr tid
1098+ e <- processAtomExpr expr
10951099 pure (Right (AtomExprPredicate e))
10961100processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = do
1097− tid <- elems_currentTransId <$> ask
1098− let e = processAtomExpr expr tid
1101+ e <- processAtomExpr expr
10991102 pure (Right (AttributeEqualityPredicate nam e))
1100−processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError (ExtendTupleExprBase a))
1103+
1104+processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError GraphRefExtendTupleExpr)
11011105processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do
1102− eExpr <- evalAtomExpr atomExpr
1103− case eExpr of
1104− Left err -> pure (Left err)
1105− Right expr -> pure (Right (AttributeExtendTupleExpr nam expr))
1106+ e <- processAtomExpr atomExpr
1107+ pure (Right (AttributeExtendTupleExpr nam e))
11061108
1107−typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation
1108−typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) _ = mkRelation attrs emptyTupleSet
1109−typeForGraphRefRelationalExpr (ExistingRelation rel) _ = pure (emptyRelationWithAttrs (attributes rel))
1110−typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) graph =
1109+typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExprState (Either RelationalError Relation)
1110+typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = pure $ mkRelation attrs emptyTupleSet
1111+typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (Right (emptyRelationWithAttrs (attributes rel)))
1112+typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =
11111113 case mAttrExprs of
11121114 Just attrExprs -> do
1113− attrs <- mapM (\e -> evalGraphRefAttributeExpr e graph) attrExprs
1114− pure (emptyRelationWithAttrs attrs)
1115−typeForGraphRefRelationalExpr (RelationVariable rvName tid) graph = do
1116− trans <- transactionForId tid graph
1117− let relVars = relationVariables (concreteDatabaseContext trans)
1118− case M.lookup rvName relVars of
1119− Nothing -> Left $ RelVarNotDefinedError name
1120− Just rvExpr -> typeForGraphRefRelationalExpr rvExpr graph
1121−typeForGraphRefRelationalExpr (Project attrNames expr) graph = do
1122− exprType <- typeForGraphRefRelationalExpr expr graph
1123− projectionAttrs <- evalGraphRefAttributeNames attrNames expr graph
1124− project projectionAttrs exprType
1125−
1126−evalGraphRefAttributeNames :: AttributeNames -> GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError (S.Set AttributeName)
1127−evalGraphRefAttributeNames attrNames expr graph = do
1128− exprTyp <- typeForGraphRefRelationalExpr expr graph
1129− let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
1130− case attrNames of
1115+ eAttrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs
1116+ case lefts eAttrs of
1117+ [] -> pure (Right (emptyRelationWithAttrs (attributesFromList (rights eAttrs))))
1118+ _ -> pure (Left (someErrors (lefts eAttrs)))
1119+typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do
1120+ eTrans <- currentTrans
1121+ case eTrans of
1122+ Left err -> pure (Left err)
1123+ Right trans -> do
1124+ let relVars = relationVariables (concreteDatabaseContext trans)
1125+ case M.lookup rvName relVars of
1126+ Nothing -> pure (Left (RelVarNotDefinedError rvName))
1127+ Just rvExpr -> typeForGraphRefRelationalExpr rvExpr
1128+typeForGraphRefRelationalExpr (Project attrNames expr) = do
1129+ eExprType <- typeForGraphRefRelationalExpr expr
1130+ case eExprType of
1131+ Left err -> pure (Left err)
1132+ Right exprType -> do
1133+ eProjectionAttrs <- evalGraphRefAttributeNames attrNames expr
1134+ pure $ case eProjectionAttrs of
1135+ Left err -> Left err
1136+ Right projectionAttrs -> project projectionAttrs exprType
1137+
1138+evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))
1139+evalGraphRefAttributeNames attrNames expr = do
1140+ eExprType <- typeForGraphRefRelationalExpr expr
1141+ case eExprType of
1142+ Left err -> pure (Left err)
1143+ Right exprTyp -> do
1144+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
1145+ case attrNames of
11311146 AttributeNames names ->
11321147 case A.projectionAttributesForNames names (attributes exprTyp) of
11331148 Left err -> pure (Left err)
@@ -1138,32 +1153,32 @@ evalGraphRefAttributeNames attrNames expr graph = do
11381153 if not (S.null nonExistentAttributeNames) then
11391154 pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))
11401155 else
1141− pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))
1156+ pure (pure (A.nonMatchingAttributeNameSet names typeNameSet))
11421157
11431158 UnionAttributeNames namesA namesB -> do
1144− eNameSetA <- evalAttributeNames namesA expr
1159+ eNameSetA <- evalGraphRefAttributeNames namesA expr
11451160 case eNameSetA of
11461161 Left err -> pure (Left err)
11471162 Right nameSetA -> do
1148− eNameSetB <- evalAttributeNames namesB expr
1163+ eNameSetB <- evalGraphRefAttributeNames namesB expr
11491164 case eNameSetB of
11501165 Left err -> pure (Left err)
11511166 Right nameSetB ->
11521167 pure (Right (S.union nameSetA nameSetB))
11531168
11541169 IntersectAttributeNames namesA namesB -> do
1155− eNameSetA <- evalAttributeNames namesA expr
1170+ eNameSetA <- evalGraphRefAttributeNames namesA expr
11561171 case eNameSetA of
11571172 Left err -> pure (Left err)
11581173 Right nameSetA -> do
1159− eNameSetB <- evalAttributeNames namesB expr
1174+ eNameSetB <- evalGraphRefAttributeNames namesB expr
11601175 case eNameSetB of
11611176 Left err -> pure (Left err)
11621177 Right nameSetB ->
11631178 pure (Right (S.intersection nameSetA nameSetB))
11641179
11651180 RelationalExprAttributeNames attrExpr -> do
1166− eAttrExprType <- typeForRelationalExpr attrExpr
1181+ eAttrExprType <- typeForGraphRefRelationalExpr attrExpr
11671182 case eAttrExprType of
11681183 Left err -> pure (Left err)
11691184 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
@@ -1171,30 +1186,44 @@ evalGraphRefAttributeNames attrNames expr graph = do
11711186
11721187
11731188
1174−processAtomExpr :: AtomExpr -> TransactionId -> GraphRefAtomExpr
1175−processAtomExpr (AttributeAtomExpr nam) _ = AttributeAtomExpr nam
1176−processAtomExpr (NakedAtomExpr atom) _ = NakedAtomExpr atom
1177−processAtomExpr (FunctionAtomExpr fName atomExprs ()) tid = FunctionAtomExpr fName (fmap processAtomExpr tid) tid
1178−processAtomExpr (RelationAtomExpr expr) tid = RelationAtomExpr (processRelationalExpr expr tid)
1179−processAtomExpr (ConstructedAtomExpr dConsName atomExprs) = ConstructedAtomExpr dConsName (fmap processAtomExpr tid) tid
1189+processAtomExpr :: AtomExpr -> RelationalExprState GraphRefAtomExpr
1190+processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam
1191+processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
1192+processAtomExpr (FunctionAtomExpr fName atomExprs ()) = do
1193+ tid <- elems_currentTransId <$> ask
1194+ FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> pure tid
1195+processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr
1196+processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> (elems_currentTransId <$> ask)
11801197
1181−processTupleExpr :: TupleExpr -> TransactionId -> GraphRefTupleExpr
1182−processTupleExpr (TupleExpr tMap) tid = TupleExpr (M.map (processAtomExpr tid) tMap)
1198+processTupleExpr :: TupleExpr -> RelationalExprState GraphRefTupleExpr
1199+processTupleExpr (TupleExpr tMap) =
1200+ TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)
11831201
1184−evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> TransactionGraph -> Either RelationalError Attribute
1185−evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) graph = do
1186− trans <- transactionForId tid graph
1187− let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)
1188− aType <- atomTypeForTypeConstructorValidate True tCons tConsMap M.empty
1189− validateAtomType aType tConsMap
1190− pure (Attribute attrName aType)
1202+evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)
1203+evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do
1204+ graph <- elems_graph <$> ask
1205+ case transactionForId tid graph of
1206+ Left err -> pure (Left err)
1207+ Right trans -> do
1208+ let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)
1209+ case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of
1210+ Left err -> pure (Left err)
1211+ Right aType -> do
1212+ case validateAtomType aType tConsMap of
1213+ Left err -> pure (Left err)
1214+ Right _ -> pure (Right (Attribute attrName aType))
11911215
11921216--convert AttributeExpr to GraphRefAttributeExpr
1193−processAttributeExpr :: AttributeExpr -> TransactionId -> GraphRefAttributeExpr
1194−processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) tid = AttributeAndTypeNameExpr nam tCons tid
1195−processAttributeExpr (NakedAttributeExpr attr) = NakedAttributeExpr attr
1217+processAttributeExpr :: AttributeExpr -> RelationalExprState GraphRefAttributeExpr
1218+processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) = do
1219+ tid <- elems_currentTransId <$> ask
1220+ pure $ AttributeAndTypeNameExpr nam tCons tid
1221+processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr
11961222
11971223-- convert a RelationalExpr into a GraphRefRelationalExpr
11981224processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr
11991225processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do
1200− MakeRelationFromExprs (fmap (fmap processAttributeExpr) mAttrs) (processTupleExprs tupleExprs)
1226+ mAttrs' <- case mAttrs of
1227+ Nothing -> pure Nothing
1228+ Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''
1229+ MakeRelationFromExprs mAttrs' <$> mapM processTupleExpr tupleExprs