git.iko.soy/project-m36
on 2aba32a help sign in
project-m36/test/TutorialD/Interpreter.hs
437 lines 31 kB history raw
1import TutorialD.Interpreter.DatabaseContextExpr
2import TutorialD.Interpreter.TestBase
3import TutorialD.Interpreter
4import TutorialD.Interpreter.Base
5import Test.HUnit
6import ProjectM36.Relation
7import ProjectM36.Tuple
8import ProjectM36.TupleSet
9import ProjectM36.Error
10import ProjectM36.DatabaseContext
11import ProjectM36.AtomFunctions.Primitive
12import ProjectM36.DataTypes.Either
13import ProjectM36.DateExamples
14import ProjectM36.Base hiding (Finite)
15import ProjectM36.TransactionGraph
16import ProjectM36.Client
17import qualified ProjectM36.DisconnectedTransaction as Discon
18import qualified ProjectM36.AttributeNames as AN
19import qualified ProjectM36.Session as Sess
20import qualified ProjectM36.Attribute as A
21import qualified Data.Map as M
22import System.Exit
23import Data.Maybe (isJust)
24import qualified Data.Vector as V
25import Data.Text.Encoding as TE
26import Control.Concurrent
27import qualified Data.Set as S
28import Data.Text hiding (map)
29import qualified Data.Text as T
30import Data.Time.Clock.POSIX
32main :: IO ()
33main = do
34 tcounts <- runTestTT (TestList tests)
35 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
36 where
37 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, testSchemaExpr, testRelationalExprStateTupleElems, testFunctionalDependencies, testEmptyCommits]
38 simpleRelTests = [("x:=true", Right relationTrue),
39 ("x:=false", Right relationFalse),
40 ("x:=true union false", Right relationTrue),
41 ("x:=true minus false", Right relationTrue),
42 ("x:=false minus true", Right relationFalse),
43 ("x:=true; x:=false", Right relationFalse),
44 ("x:=relation{a Int}{}", mkRelation simpleAAttributes emptyTupleSet),
45 ("x:=relation{c Int}{} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),
46 ("y:=relation{b Int, c Int}{}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),
47 ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntAtom 5])]),
48 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
49 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
50 ("x:=relation{}{}", Right relationFalse),
51 ("x:=relation{tuple{}}", Right relationTrue),
52 ("x:=true where true", Right relationTrue),
53 ("x:=true where false", Right relationFalse),
54 ("x:=true where true or false", Right relationTrue),
55 ("x:=true where false or false", Right relationFalse),
56 ("x:=true where true and false", Right relationFalse),
57 ("x:=true where true and true", Right relationTrue),
58 ("x:=true=true", Right relationTrue),
59 ("x:=true=false", Right relationFalse),
60 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),
61 ("x:=relation {b Int, a Text}{}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList[TextAtom "spam", IntAtom 5]]),
62 -- test nested relation constructor
63 ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [IntAtom 5, RelationAtom (Relation simpleAAttributes $ RelationTupleSet [RelationTuple simpleAAttributes $ V.fromList [IntAtom 6]])])]),
64 ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntAtom 5])]),
65 ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 5])]),
66 ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 6])]),
67 ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 10])]),
68 ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntAtomType TextAtomType)),
69 ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 12])])
70 ]
71 simpleAAttributes = A.attributesFromList [Attribute "a" IntAtomType]
72 simpleBAttributes = A.attributesFromList [Attribute "d" IntAtomType]
73 simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntAtomType]
74 simpleDAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" IntAtomType]
75 maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)
76 maybeIntAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntAtomType)
77 simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" maybeTextAtomType]
78 simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntAtomType]
79 simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntAtomType TextAtomType)]
80 simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]
81 nestedRelationAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntAtomType])]
82 extendTestAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]
83 byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]
84 groupCountAttrs = A.attributesFromList [Attribute "z" IntAtomType]
85 minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntAtomType]
86 updateParisPlus10 = relMap (\tuple -> do
87 statusAtom <- atomForAttributeName "status" tuple
88 cityAtom <- atomForAttributeName "city" tuple
89 if cityAtom == TextAtom "Paris" then
90 Right $ updateTupleWithAtoms (M.singleton "status" (IntAtom (castInt statusAtom + 10))) tuple
91 else Right tuple) suppliersRel
92 dateExampleRelTests = [("x:=s where true", Right suppliersRel),
93 ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),
94 ("x:=s where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
95 ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntAtom 12, TextAtom "Paris"]]),
96 ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntAtomType]) (V.fromList [IntAtom 50])])),
97 ("x:=s minus (s where status=20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntAtom 30, TextAtom "Athens"]]),
98 --atom function tests
99 ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),
100 ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel])])),
101 ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == (Right $ TextAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (TextAtom "Boston")) tuple else Right tuple) suppliersRel),
102 ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),
103 --relatom function tests
104 ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1)])),
105 ("x:=(sp group ({s#} as y)) ungroup y", Right supplierProductsRel),
106 ("x:=((sp{s#,qty}) group ({qty} as x):{z:=max(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),
107 ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),
108 ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),
109 --boolean function restriction
110 ("x:=s where ^lt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"]]),
111 ("x:=s where ^gt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntAtom 30, TextAtom "Paris"],
112 [TextAtom "S5", TextAtom "Adams", IntAtom 30, TextAtom "Athens"]]),
113 ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType),
114 ("x:=s where ^not(gte(@status,20))", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"]]),
115 --test "all but" attribute inversion syntax
116 ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue),
117 --test key syntax
118 ("x:=s; key testconstraint {s#,city} x; insert x relation{tuple{city \"London\", s# \"S1\", sname \"gonk\", status 50}}", Left (InclusionDependencyCheckError "testconstraint")),
119 ("y:=s; key testconstraint {s#} y; insert y relation{tuple{city \"London\", s# \"S6\", sname \"gonk\", status 50}}; x:=y{s#} = s{s#} union relation{tuple{s# \"S6\"}}", Right relationTrue),
120 --test binary bytestring data type
121 ("x:=relation{tuple{y makeByteString(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),
122 --test Maybe Text
123 ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [TextAtom "spam"]]]),
124 --test Maybe Int
125 ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntAtomType [IntAtom 3]]]),
126 --test Either Int Text
127 ("x:=relation{tuple{a Left 3}}", Left (TypeConstructorTypeVarsMismatch (S.fromList ["a","b"]) (S.fromList ["a"]))), -- Left 3, alone is not enough information to imply the type
128 ("x:=relation{a Either Int Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType IntAtomType TextAtomType) [IntAtom 3]]]),
129 --test datetime constructor
130 ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]])
131 ]
133assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion
134assertTutdEqual databaseContext expected tutd = assertEqual (unpack tutd) expected interpreted
135 where
136 interpreted = case interpretDatabaseContextExpr databaseContext tutd of
137 Left err -> Left err
138 Right context -> case M.lookup "x" (relationVariables context) of
139 Nothing -> Left $ RelVarNotDefinedError "x"
140 Just rel -> Right rel
142transactionGraphBasicTest :: Test
143transactionGraphBasicTest = TestCase $ do
144 (_, dbconn) <- dateExamplesConnection emptyNotificationCallback
145 graph <- transactionGraph_ dbconn
146 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
148--add a new transaction to the graph, validate it is in the graph
149transactionGraphAddCommitTest :: Test
150transactionGraphAddCommitTest = TestCase $ do
151 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
152 case parseTutorialD "x:=s" of
153 Left err -> assertFailure (show err)
154 Right parsed -> do
155 result <- evalTutorialD sessionId dbconn UnsafeEvaluation parsed
156 case result of
157 QuitResult -> assertFailure "quit?"
158 DisplayResult _ -> assertFailure "display?"
159 DisplayIOResult _ -> assertFailure "displayIO?"
160 DisplayRelationResult _ -> assertFailure "displayrelation?"
161 DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"
162 DisplayErrorResult err -> assertFailure (show err)
163 QuietSuccessResult -> do
164 commit sessionId dbconn >>= eitherFail
165 discon <- disconnectedTransaction_ sessionId dbconn
166 let context = Discon.concreteDatabaseContext discon
167 assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)
169transactionRollbackTest :: Test
170transactionRollbackTest = TestCase $ do
171 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
172 graph <- transactionGraph_ dbconn
173 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail
174 rollback sessionId dbconn >>= eitherFail
175 discon <- disconnectedTransaction_ sessionId dbconn
176 graph' <- transactionGraph_ dbconn
177 assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))
178 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
179 assertEqual "validate graph" (graphEq graph) (graphEq graph')
181--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
182transactionJumpTest :: Test
183transactionJumpTest = TestCase $ do
184 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
185 (DisconnectedTransaction firstUUID _ _) <- disconnectedTransaction_ sessionId dbconn
186 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail
187 commit sessionId dbconn >>= eitherFail
188 --perform the jump
189 executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID) >>= eitherFail
190 --check that the disconnected transaction does not include "x"
191 discon <- disconnectedTransaction_ sessionId dbconn
192 assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))
193--branch from the first transaction and verify that there are two heads
194transactionBranchTest :: Test
195transactionBranchTest = TestCase $ do
196 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
197 mapM_ (>>= eitherFail) [executeGraphExpr sessionId dbconn (Branch "test"),
198 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),
199 commit sessionId dbconn,
200 executeGraphExpr sessionId dbconn (JumpToHead "master"),
201 executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ()))
202 ]
203 graph <- transactionGraph_ dbconn
204 assertBool "master branch exists" $ isJust (transactionForHead "master" graph)
205 assertBool "test branch exists" $ isJust (transactionForHead "test" graph)
207-- test that overlapping attribute names with different types fail with an error
208failJoinTest :: Test
209failJoinTest = TestCase $ assertTutdEqual basicDatabaseContext err "x:=relation{tuple{test 4}} join relation{tuple{test \"test\"}}"
210 where
211 err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntAtomType]))
213simpleJoinTest :: Test
214simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=s join sp"
215 where
216 attrs = A.attributesFromList [Attribute "city" TextAtomType,
217 Attribute "qty" IntAtomType,
218 Attribute "p#" TextAtomType,
219 Attribute "s#" TextAtomType,
220 Attribute "sname" TextAtomType,
221 Attribute "status" IntAtomType]
222 joinedRel = mkRelationFromList attrs [[TextAtom "London", IntAtom 100, TextAtom "P6", TextAtom "S1", TextAtom "Smith", IntAtom 20],
223 [TextAtom "London", IntAtom 400, TextAtom "P3", TextAtom "S1", TextAtom "Smith", IntAtom 20],
224 [TextAtom "London", IntAtom 400, TextAtom "P5", TextAtom "S4", TextAtom "Clark", IntAtom 20],
225 [TextAtom "London", IntAtom 300, TextAtom "P1", TextAtom "S1", TextAtom "Smith", IntAtom 20],
226 [TextAtom "Paris", IntAtom 200, TextAtom "P2", TextAtom "S3", TextAtom "Blake", IntAtom 30],
227 [TextAtom "Paris", IntAtom 300, TextAtom "P1", TextAtom "S2", TextAtom "Jones", IntAtom 10],
228 [TextAtom "London", IntAtom 100, TextAtom "P5", TextAtom "S1", TextAtom "Smith", IntAtom 20],
229 [TextAtom "London", IntAtom 300, TextAtom "P4", TextAtom "S4", TextAtom "Clark", IntAtom 20],
230 [TextAtom "Paris", IntAtom 400, TextAtom "P2", TextAtom "S2", TextAtom "Jones", IntAtom 10],
231 [TextAtom "London", IntAtom 200, TextAtom "P2", TextAtom "S1", TextAtom "Smith", IntAtom 20],
232 [TextAtom "London", IntAtom 200, TextAtom "P4", TextAtom "S1", TextAtom "Smith", IntAtom 20],
233 [TextAtom "London", IntAtom 200, TextAtom "P2", TextAtom "S4", TextAtom "Clark", IntAtom 20]
234 ]
237{-
238inclusionDependencies :: Connection -> M.Map IncDepName InclusionDependency
239inclusionDependencies (InProcessConnection (DisconnectedTransaction _ context)) = inclusionDependencies context
240inclusionDependencies _ = error "remote connection used"
241-}
243-- test notifications over the InProcessConnection
244testNotification :: Test
245testNotification = TestCase $ do
246 notifmvar <- newEmptyMVar
247 let notifCallback mvar _ _ = putMVar mvar ()
248 relvarx = RelationVariable "x" ()
249 (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)
250 executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail
251 executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx) >>= eitherFail
252 commit sess conn >>= eitherFail
253 executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail
254 commit sess conn >>= eitherFail
255 takeMVar notifmvar
257testTypeConstructors :: Test
258testTypeConstructors = TestCase $ do
259 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
260 executeTutorialD sessionId dbconn "data Hair = Color Text | Bald | UserRefusesToSpecify"
261 executeTutorialD sessionId dbconn "x:=relation{a Hair}{tuple{a Color \"Blonde\"},tuple{a Bald},tuple{a UserRefusesToSpecify}}"
262 executeTutorialD sessionId dbconn "data Tree a = Node a (Tree a) (Tree a) | EmptyNode"
263 executeTutorialD sessionId dbconn "y:=relation{a Tree Int}{tuple{a Node 3 (Node 4 EmptyNode EmptyNode) EmptyNode},tuple{a Node 4 EmptyNode EmptyNode}}"
265testMergeTransactions :: Test
266testMergeTransactions = TestCase $ do
267 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
268 mapM_ (executeTutorialD sessionId dbconn) [
269 ":branch branchA",
270 "conflictrv := relation{conflict Int}{tuple{conflict 1}}",
271 ":commit",
272 ":jumphead master",
273 ":branch branchB",
274 "conflictrv := relation{conflict Int}{tuple{conflict 2}}",
275 ":commit",
276 ":mergetrans union branchA branchB"
277 ]
278 case mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) [[IntAtom 1],[IntAtom 2]] of
279 Left err -> assertFailure (show err)
280 Right conflictCheck -> do
281 eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "conflictrv" ())
282 case eRv of
283 Left err -> assertFailure (show err)
284 Right conflictrv -> assertEqual "conflict union merge relvar" conflictCheck conflictrv
286testComments :: Test
287testComments = TestCase $ do
288 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
289 mapM_ (executeTutorialD sessionId dbconn) [
290 ":branch testbranch --test comment\n",
291 ":jumphead {- test comment -} master"]
293-- create a graph and query from two disparate contexts
294testTransGraphRelationalExpr :: Test
295testTransGraphRelationalExpr = TestCase $ do
296 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
297 mapM_ (executeTutorialD sessionId dbconn) [
298 "x:=s", --dud relvar so that the commit isn't empty
299 ":commit",
300 ":branch testbranch",
301 "insert s relation{tuple{city \"Boston\", s# \"S9\", sname \"Smithers\", status 50}}",
302 ":commit"
303 ]
304 let masterMarker = TransactionIdHeadNameLookup "master" []
305 testBranchMarker = TransactionIdHeadNameLookup "testbranch" []
306 sattrs = attributesFromList [Attribute "city" TextAtomType,
307 Attribute "sname" TextAtomType,
308 Attribute "s#" TextAtomType,
309 Attribute "status" IntAtomType]
310 expectedRel = mkRelationFromList sattrs [[TextAtom "Boston",
311 TextAtom "Smithers",
312 TextAtom "S9",
313 IntAtom 50]]
314 diff <- executeTransGraphRelationalExpr sessionId dbconn (Difference (RelationVariable "s" testBranchMarker) (RelationVariable "s" masterMarker))
315 assertEqual "difference in s" expectedRel diff
317 --test graph traversal (head backtracking)
318 let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]
319 backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))
320 assertEqual "backtrack to master" (Right relationTrue) backtrackRel
322 --test walkback to time (stay in current location)
323 now <- getCurrentTime
324 headId <- headTransactionId sessionId dbconn
325 _ <- executeGraphExpr sessionId dbconn (WalkBackToTime now)
326 headId' <- headTransactionId sessionId dbconn
327 assertEqual "transaction walk back stays in place" headId headId'
329 --test branch deletion
330 mapM_ (executeTutorialD sessionId dbconn) [
331 ":jumphead master",
332 ":deletebranch testbranch"]
333 eEvald <- case parseTutorialD ":jumphead testbranch" of
334 Left _ -> assertFailure "jumphead parse error" >> error "x"
335 Right parsed -> evalTutorialD sessionId dbconn UnsafeEvaluation parsed
336 case eEvald of
337 DisplayErrorResult err -> assertEqual "testbranch deletion" (show (NoSuchHeadNameError "testbranch")) (unpack err)
338 _ -> assertFailure "failed to delete branch"
340testMultiAttributeRename :: Test
341testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false"
342 where
343 sattrs = attributesFromList [Attribute "town" TextAtomType,
344 Attribute "sname" TextAtomType,
345 Attribute "s#" TextAtomType,
346 Attribute "price" IntAtomType]
347 renamedRel = mkRelationFromList sattrs []
349testSchemaExpr :: Test
350testSchemaExpr = TestCase $ do
351 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
352 mapM_ (executeTutorialD sessionId dbconn) [
353 ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" ^gte(17,@weight))",
354 ":setschema test",
355 ""
356 ]
357 eLightProduct <- executeRelationalExpr sessionId dbconn (RelationVariable "light_product" ())
358 lightProduct <- assertEither eLightProduct
359 let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntAtom 17), AttributeAtomExpr "weight"] ()))
360 setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName >>= eitherFail
361 eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ()))
362 restrictedProduct <- assertEither eRestrictedProduct
363 assertEqual "light product" restrictedProduct lightProduct
365assertEither :: (Show a) => Either a b -> IO b
366assertEither x = case x of
367 Left err -> assertFailure (show err) >> undefined
368 Right val -> pure val
370-- | Validate that a tuple passed through the context correctly typechecks and propagates to the AttributeAtomExpr.
371testRelationalExprStateTupleElems :: Test
372testRelationalExprStateTupleElems = TestCase $ do
373 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
374 executeTutorialD sessionId dbconn "x := (s : { parts := p rename {city as pcity} where pcity=@city}) : {z:=count(@parts)}"
376 executeTutorialD sessionId dbconn "y:=x{city,z}"
377 eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())
378 let expectedRel = mkRelationFromList (attributesFromList [Attribute "city" TextAtomType,
379 Attribute "z" IntAtomType])
380 [[TextAtom "Paris", IntAtom 2],
381 [TextAtom "London", IntAtom 3],
382 [TextAtom "Athens", IntAtom 0]]
383 assertEqual "validate parts count" expectedRel eRv
385 executeTutorialD sessionId dbconn "rv1:=relation{tuple{test 1}}"
386 executeTutorialD sessionId dbconn "rv2:=relation{tuple{val 1},tuple{val 2}}"
387 --check subexpression evaluation in restriction predicate
388 -- "rv1 where ((rv2 where val=@test) {})"
389 let correctSubexpr = Restrict (AttributeEqualityPredicate "val" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())
390 mainExpr subexpr = Restrict
391 (RelationalExprPredicate
392 (Project AN.empty subexpr)) (RelationVariable "rv1" ())
393 eRv2 <- executeRelationalExpr sessionId dbconn (mainExpr correctSubexpr)
394 let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntAtomType]) [[IntAtom 1]]
395 assertEqual "validate sub-expression attribute" expectedRel2 eRv2
397 --check error in subexpression
398 let wrongSubexpr = Restrict (AttributeEqualityPredicate "nosuchattr" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())
399 eRv3 <- executeRelationalExpr sessionId dbconn (mainExpr wrongSubexpr)
400 assertEqual "validate missing attribute in subexpression" (Left (NoSuchAttributeNamesError (S.singleton "nosuchattr"))) eRv3
402-- | Add a functional dependency on sname -> status and insert one tuple which is valid and another tuple which is invalid.
403testFunctionalDependencies :: Test
404testFunctionalDependencies = TestCase $ do
405 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
406 executeTutorialD sessionId dbconn "funcdep sname_status (sname) -> (status) s"
407 --insert a new, valid tuple
408 executeTutorialD sessionId dbconn "insert s relation{tuple{city \"Boston\", s# \"S6\", sname \"Stevens\", status 30}}"
409 --insert an constraint-violating tuple
410 let expectedError = "InclusionDependencyCheckError \"sname_status_A\""
411 expectTutorialDErr sessionId dbconn (T.isPrefixOf expectedError) "insert s relation{tuple{city \"Boston\", s# \"S7\", sname \"Jones\", status 20}}"
413testEmptyCommits :: Test
414testEmptyCommits = TestCase $ do
415 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
416 dirty <- disconnectedTransactionIsDirty sessionId dbconn
417 assertEqual "no change not dirty" (Right False) dirty
418 Right () <- commit sessionId dbconn
420 --insert no tuples
421 Right () <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ()))
422 dirty' <- disconnectedTransactionIsDirty sessionId dbconn
423 assertEqual "empty insert empty commit" (Right False) dirty'
424 Right () <- commit sessionId dbconn
426 --update no tuples
427 Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))
428 dirty'' <- disconnectedTransactionIsDirty sessionId dbconn
429 assertEqual "empty update empty commit" (Right False) dirty''
430 Right () <- commit sessionId dbconn
432 --delete no tuples
433 Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))
434 dirty''' <- disconnectedTransactionIsDirty sessionId dbconn
435 assertEqual "empty delete empty commit" (Right False) dirty'''