git.iko.soy/project-m36
on master help sign in
allow multiple attribute renames as part of tutd rename clause
8cfc3eeAgentM
src/bin/TutorialD/Interpreter/RelationalExpr.hs+5−2
compare with master
unifiedsplit
@@ -80,8 +80,11 @@ renameClauseP = do
80renameP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
80renameP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
81renameP = do
81renameP = do
82 reservedOp "rename"
82 reservedOp "rename"
83− (oldAttr, newAttr) <- braces renameClauseP
83+ renameList <- braces (sepBy renameClauseP comma)
84+ case renameList of
85+ [] -> pure (Restrict TruePredicate) --no-op when rename list is empty
86+ renames -> do
84− return $ Rename oldAttr newAttr
87+ pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames
85
88
86whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
89whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
87whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP)
90whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP)
test/TutorialD/Interpreter.hs+12−3
@@ -32,7 +32,7 @@ main = do
32 tcounts <- runTestTT (TestList tests)
32 tcounts <- runTestTT (TestList tests)
33 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
33 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
34 where
34 where
35− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification, testTypeConstructors, testMergeTransactions, testComments, testTransGraphRelationalExpr]
35+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification, testTypeConstructors, testMergeTransactions, testComments, testTransGraphRelationalExpr, failJoinTest, testMultiAttributeRename]
36 simpleRelTests = [("x:=true", Right relationTrue),
36 simpleRelTests = [("x:=true", Right relationTrue),
37 ("x:=false", Right relationFalse),
37 ("x:=false", Right relationFalse),
38 ("x:=true union false", Right relationTrue),
38 ("x:=true union false", Right relationTrue),
@@ -208,7 +208,7 @@ transactionBranchTest = TestCase $ do
208
208
209-- test that overlapping attribute names with different types fail with an error
209-- test that overlapping attribute names with different types fail with an error
210failJoinTest :: Test
210failJoinTest :: Test
211−failJoinTest = TestCase $ assertTutdEqual basicDatabaseContext err "x:=relation{tuple{test Int}} join relation{tuple{test Text}}"
211+failJoinTest = TestCase $ assertTutdEqual basicDatabaseContext err "x:=relation{tuple{test 4}} join relation{tuple{test \"test\"}}"
212 where
212 where
213 err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntAtomType]))
213 err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntAtomType]))
214
214
@@ -331,4 +331,13 @@ testTransGraphRelationalExpr = TestCase $ do
331 let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]
331 let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]
332 backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))
332 backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))
333 assertEqual "backtrack to master" (Right relationTrue) backtrackRel
333 assertEqual "backtrack to master" (Right relationTrue) backtrackRel
334−
334+
335+
336+testMultiAttributeRename :: Test
337+testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false"
338+ where
339+ sattrs = attributesFromList [Attribute "town" TextAtomType,
340+ Attribute "sname" TextAtomType,
341+ Attribute "s#" TextAtomType,
342+ Attribute "price" IntAtomType]
343+ renamedRel = mkRelationFromList sattrs []