9ada9c7 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

RelationalExpression.hs compilation checkpoint

9ada9c7AgentM7 years ago

src/lib/ProjectM36/Base.hs+2−1

compare with master

unifiedsplit

@@ -444,7 +444,8 @@ instance Binary AtomExpr

444data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

445 deriving (Show, Eq, Generic, NFData)

446

447−type ExtendTupleExpr = ExtendTupleExprBase ()

447+type ExtendTupleExpr = ExtendTupleExprBase ()

448+type GraphRefExtendTupleExpr = ExtendTupleExprBase TransactionId

448

449

449instance Binary ExtendTupleExpr

450instance Binary ExtendTupleExpr

450

451

src/lib/ProjectM36/RelationalExpression.hs+91−62

@@ -7,7 +7,7 @@ import ProjectM36.Base

7import qualified Data.UUID as U

8import ProjectM36.Error

9import ProjectM36.AtomType

10−import ProjectM36.Attribute (emptyAttributes)

10+import ProjectM36.Attribute (emptyAttributes, attributesFromList)

11import ProjectM36.ScriptSession

12import ProjectM36.DataTypes.Primitive

13import ProjectM36.AtomFunction

@@ -85,6 +85,12 @@ mkRelationalExprState ctx currentTransId graph =

85 elems_graph = graph,

86 elems_currentTransId = currentTransId,

87 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)

89mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems

95mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems

90mergeTuplesIntoRelationalExprState tupIn e@RelationalExprStateElems{} =

96mergeTuplesIntoRelationalExprState tupIn e@RelationalExprStateElems{} =

@@ -340,7 +346,7 @@ evalDatabaseContextExpr (Assign relVarName expr) transId graph = do

340 Left err -> pure (Left err)

346 Left err -> pure (Left err)

341 Right rvExpr -> setRelVar relVarName rvExpr transId graph

347 Right rvExpr -> setRelVar relVarName rvExpr transId graph

342 Just existingRel -> do

348 Just existingRel -> do

343− let eExpectedType = typeForGraphRefRelationalExpr existingRel graph

349+ let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprState context transId graph)

344 eNewExprType = runReader (typeForRelationalExpr expr) relExprState

350 eNewExprType = runReader (typeForRelationalExpr expr) relExprState

345 case eExpectedType of

351 case eExpectedType of

346 Left err -> pure (Left err)

352 Left err -> pure (Left err)

@@ -387,7 +393,7 @@ evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr)

387 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

393 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

388 restrictedPortion = Restrict graphRefPredicate

394 restrictedPortion = Restrict graphRefPredicate

389 updated = foldr (\(oldname, atomExpr) accum ->

395 updated = foldr (\(oldname, atomExpr) accum ->

390− let procAtomExpr = processAtomExpr atomExpr transId in

396+ let procAtomExpr = runReader (processAtomExpr atomExpr) rvState in

391 updateAttr oldname procAtomExpr accum

397 updateAttr oldname procAtomExpr accum

392 ) rv (M.toList atomExprMap)

398 ) rv (M.toList atomExprMap)

393 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds

399 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds

@@ -633,7 +639,7 @@ evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelatio

633 case existingRelVar of

639 case existingRelVar of

634 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

640 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

635 Just existingRel -> do

641 Just existingRel -> do

636− case typeForGraphRefRelationalExpr existingRel graph of

642+ case runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprState currentContext transId graph) of

637 Left err -> pure (Left err)

643 Left err -> pure (Left err)

638 Right relType -> do

644 Right relType -> do

639 let expectedAttributes = attributes relType

645 let expectedAttributes = attributes relType

@@ -690,11 +696,10 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

690

696

691typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

697typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

692typeForRelationalExpr expr = do

698typeForRelationalExpr expr = do

693− graph <- elems_graph <$> ask

694 --replace the relationVariables context element with a cloned set of relation devoid of tuples

699 --replace the relationVariables context element with a cloned set of relation devoid of tuples

695 --evalRelationalExpr could still return an existing relation with tuples, so strip them

700 --evalRelationalExpr could still return an existing relation with tuples, so strip them

696 gfExpr <- processRelationalExpr expr

701 gfExpr <- processRelationalExpr expr

697− pure (typeForGraphRefRelationalExpr gfExpr graph)

702+ typeForGraphRefRelationalExpr gfExpr

698

703

699--returns a database context with all tuples removed

704--returns a database context with all tuples removed

700--this is useful for type checking and optimization

705--this is useful for type checking and optimization

@@ -1090,44 +1095,54 @@ processRestrictionPredicateExpr (RelationalExprPredicate expr) = do

1090 Left err -> Left err

1095 Left err -> Left err

1091 Right e' -> Right (RelationalExprPredicate e')

1096 Right e' -> Right (RelationalExprPredicate e')

1092processRestrictionPredicateExpr (AtomExprPredicate expr) = do

1097processRestrictionPredicateExpr (AtomExprPredicate expr) = do

1093− tid <- elems_currentTransId <$> ask

1094− let e = processAtomExpr expr tid

1098+ e <- processAtomExpr expr

1095 pure (Right (AtomExprPredicate e))

1099 pure (Right (AtomExprPredicate e))

1096processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = do

1100processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = do

1097− tid <- elems_currentTransId <$> ask

1098− let e = processAtomExpr expr tid

1101+ e <- processAtomExpr expr

1099 pure (Right (AttributeEqualityPredicate nam e))

1102 pure (Right (AttributeEqualityPredicate nam e))

1103+

1100−processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError (ExtendTupleExprBase a))

1104+processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError GraphRefExtendTupleExpr)

1101processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do

1105processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do

1102− eExpr <- evalAtomExpr atomExpr

1106+ e <- processAtomExpr atomExpr

1103− case eExpr of

1104− Left err -> pure (Left err)

1105− Right expr -> pure (Right (AttributeExtendTupleExpr nam expr))

1107+ pure (Right (AttributeExtendTupleExpr nam e))

1106

1108

1107−typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation

1109+typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExprState (Either RelationalError Relation)

1108−typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) _ = mkRelation attrs emptyTupleSet

1110+typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = pure $ mkRelation attrs emptyTupleSet

1109−typeForGraphRefRelationalExpr (ExistingRelation rel) _ = pure (emptyRelationWithAttrs (attributes rel))

1111+typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (Right (emptyRelationWithAttrs (attributes rel)))

1110−typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) graph =

1112+typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =

1111 case mAttrExprs of

1113 case mAttrExprs of

1112 Just attrExprs -> do

1114 Just attrExprs -> do

1113− attrs <- mapM (\e -> evalGraphRefAttributeExpr e graph) attrExprs

1115+ eAttrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs

1116+ case lefts eAttrs of

1114− pure (emptyRelationWithAttrs attrs)

1117+ [] -> pure (Right (emptyRelationWithAttrs (attributesFromList (rights eAttrs))))

1118+ _ -> pure (Left (someErrors (lefts eAttrs)))

1115−typeForGraphRefRelationalExpr (RelationVariable rvName tid) graph = do

1119+typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

1116− trans <- transactionForId tid graph

1120+ eTrans <- currentTrans

1121+ case eTrans of

1122+ Left err -> pure (Left err)

1123+ Right trans -> do

1117− let relVars = relationVariables (concreteDatabaseContext trans)

1124+ let relVars = relationVariables (concreteDatabaseContext trans)

1118− case M.lookup rvName relVars of

1125+ case M.lookup rvName relVars of

1119− Nothing -> Left $ RelVarNotDefinedError name

1126+ Nothing -> pure (Left (RelVarNotDefinedError rvName))

1120− Just rvExpr -> typeForGraphRefRelationalExpr rvExpr graph

1127+ Just rvExpr -> typeForGraphRefRelationalExpr rvExpr

1121−typeForGraphRefRelationalExpr (Project attrNames expr) graph = do

1128+typeForGraphRefRelationalExpr (Project attrNames expr) = do

1122− exprType <- typeForGraphRefRelationalExpr expr graph

1129+ eExprType <- typeForGraphRefRelationalExpr expr

1130+ case eExprType of

1131+ Left err -> pure (Left err)

1132+ Right exprType -> do

1123− projectionAttrs <- evalGraphRefAttributeNames attrNames expr graph

1133+ eProjectionAttrs <- evalGraphRefAttributeNames attrNames expr

1134+ pure $ case eProjectionAttrs of

1135+ Left err -> Left err

1124− project projectionAttrs exprType

1136+ Right projectionAttrs -> project projectionAttrs exprType

1125−

1137+

1126−evalGraphRefAttributeNames :: AttributeNames -> GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError (S.Set AttributeName)

1138+evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))

1127−evalGraphRefAttributeNames attrNames expr graph = do

1139+evalGraphRefAttributeNames attrNames expr = do

1128− exprTyp <- typeForGraphRefRelationalExpr expr graph

1140+ eExprType <- typeForGraphRefRelationalExpr expr

1141+ case eExprType of

1142+ Left err -> pure (Left err)

1143+ Right exprTyp -> do

1129− let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))

1144+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))

1130− case attrNames of

1145+ case attrNames of

1131 AttributeNames names ->

1146 AttributeNames names ->

1132 case A.projectionAttributesForNames names (attributes exprTyp) of

1147 case A.projectionAttributesForNames names (attributes exprTyp) of

1133 Left err -> pure (Left err)

1148 Left err -> pure (Left err)

@@ -1138,32 +1153,32 @@ evalGraphRefAttributeNames attrNames expr graph = do

1138 if not (S.null nonExistentAttributeNames) then

1153 if not (S.null nonExistentAttributeNames) then

1139 pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))

1154 pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))

1140 else

1155 else

1141− pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))

1156+ pure (pure (A.nonMatchingAttributeNameSet names typeNameSet))

1142

1157

1143 UnionAttributeNames namesA namesB -> do

1158 UnionAttributeNames namesA namesB -> do

1144− eNameSetA <- evalAttributeNames namesA expr

1159+ eNameSetA <- evalGraphRefAttributeNames namesA expr

1145 case eNameSetA of

1160 case eNameSetA of

1146 Left err -> pure (Left err)

1161 Left err -> pure (Left err)

1147 Right nameSetA -> do

1162 Right nameSetA -> do

1148− eNameSetB <- evalAttributeNames namesB expr

1163+ eNameSetB <- evalGraphRefAttributeNames namesB expr

1149 case eNameSetB of

1164 case eNameSetB of

1150 Left err -> pure (Left err)

1165 Left err -> pure (Left err)

1151 Right nameSetB ->

1166 Right nameSetB ->

1152 pure (Right (S.union nameSetA nameSetB))

1167 pure (Right (S.union nameSetA nameSetB))

1153

1168

1154 IntersectAttributeNames namesA namesB -> do

1169 IntersectAttributeNames namesA namesB -> do

1155− eNameSetA <- evalAttributeNames namesA expr

1170+ eNameSetA <- evalGraphRefAttributeNames namesA expr

1156 case eNameSetA of

1171 case eNameSetA of

1157 Left err -> pure (Left err)

1172 Left err -> pure (Left err)

1158 Right nameSetA -> do

1173 Right nameSetA -> do

1159− eNameSetB <- evalAttributeNames namesB expr

1174+ eNameSetB <- evalGraphRefAttributeNames namesB expr

1160 case eNameSetB of

1175 case eNameSetB of

1161 Left err -> pure (Left err)

1176 Left err -> pure (Left err)

1162 Right nameSetB ->

1177 Right nameSetB ->

1163 pure (Right (S.intersection nameSetA nameSetB))

1178 pure (Right (S.intersection nameSetA nameSetB))

1164

1179

1165 RelationalExprAttributeNames attrExpr -> do

1180 RelationalExprAttributeNames attrExpr -> do

1166− eAttrExprType <- typeForRelationalExpr attrExpr

1181+ eAttrExprType <- typeForGraphRefRelationalExpr attrExpr

1167 case eAttrExprType of

1182 case eAttrExprType of

1168 Left err -> pure (Left err)

1183 Left err -> pure (Left err)

1169 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1184 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

@@ -1171,30 +1186,44 @@ evalGraphRefAttributeNames attrNames expr graph = do

1171

1186

1172

1187

1173

1188

1174−processAtomExpr :: AtomExpr -> TransactionId -> GraphRefAtomExpr

1189+processAtomExpr :: AtomExpr -> RelationalExprState GraphRefAtomExpr

1175−processAtomExpr (AttributeAtomExpr nam) _ = AttributeAtomExpr nam

1190+processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam

1176−processAtomExpr (NakedAtomExpr atom) _ = NakedAtomExpr atom

1191+processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom

1177−processAtomExpr (FunctionAtomExpr fName atomExprs ()) tid = FunctionAtomExpr fName (fmap processAtomExpr tid) tid

1192+processAtomExpr (FunctionAtomExpr fName atomExprs ()) = do

1193+ tid <- elems_currentTransId <$> ask

1194+ FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> pure tid

1178−processAtomExpr (RelationAtomExpr expr) tid = RelationAtomExpr (processRelationalExpr expr tid)

1195+processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr

1179−processAtomExpr (ConstructedAtomExpr dConsName atomExprs) = ConstructedAtomExpr dConsName (fmap processAtomExpr tid) tid

1196+processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> (elems_currentTransId <$> ask)

1180

1197

1181−processTupleExpr :: TupleExpr -> TransactionId -> GraphRefTupleExpr

1198+processTupleExpr :: TupleExpr -> RelationalExprState GraphRefTupleExpr

1182−processTupleExpr (TupleExpr tMap) tid = TupleExpr (M.map (processAtomExpr tid) tMap)

1199+processTupleExpr (TupleExpr tMap) =

1200+ TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)

1183

1201

1184−evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> TransactionGraph -> Either RelationalError Attribute

1202+evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)

1185−evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) graph = do

1203+evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1204+ graph <- elems_graph <$> ask

1186− trans <- transactionForId tid graph

1205+ case transactionForId tid graph of

1206+ Left err -> pure (Left err)

1207+ Right trans -> do

1187− let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)

1208+ let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)

1188− aType <- atomTypeForTypeConstructorValidate True tCons tConsMap M.empty

1209+ case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of

1210+ Left err -> pure (Left err)

1211+ Right aType -> do

1189− validateAtomType aType tConsMap

1212+ case validateAtomType aType tConsMap of

1213+ Left err -> pure (Left err)

1190− pure (Attribute attrName aType)

1214+ Right _ -> pure (Right (Attribute attrName aType))

1191

1215

1192--convert AttributeExpr to GraphRefAttributeExpr

1216--convert AttributeExpr to GraphRefAttributeExpr

1193−processAttributeExpr :: AttributeExpr -> TransactionId -> GraphRefAttributeExpr

1217+processAttributeExpr :: AttributeExpr -> RelationalExprState GraphRefAttributeExpr

1194−processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) tid = AttributeAndTypeNameExpr nam tCons tid

1218+processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) = do

1219+ tid <- elems_currentTransId <$> ask

1220+ pure $ AttributeAndTypeNameExpr nam tCons tid

1195−processAttributeExpr (NakedAttributeExpr attr) = NakedAttributeExpr attr

1221+processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr

1196

1222

1197-- convert a RelationalExpr into a GraphRefRelationalExpr

1223-- convert a RelationalExpr into a GraphRefRelationalExpr

1198processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr

1224processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr

1199processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do

1225processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do

1226+ mAttrs' <- case mAttrs of

1227+ Nothing -> pure Nothing

1228+ Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''

1200− MakeRelationFromExprs (fmap (fmap processAttributeExpr) mAttrs) (processTupleExprs tupleExprs)

1229+ MakeRelationFromExprs mAttrs' <$> mapM processTupleExpr tupleExprs

src/lib/ProjectM36/TransactionGraph.hs+1−1

@@ -94,7 +94,7 @@ transactionsForIds idSet graph =

95-- | A root transaction terminates a graph and has no parents.

96isRootTransaction :: Transaction -> Bool

97−isRootTransaction trans = diffs trans == TD.root

97+isRootTransaction trans = parentTransactions == nil :| []

99-- the first transaction has no parent - all other do have parents- merges have two parents

100parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)