git.iko.soy/project-m36
on 18f736a help sign in
project-m36/test/TutorialD/Interpreter.hs
539 lines 36 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 hiding (getCurrentTime)
31import Data.Time.Clock (getCurrentTime)
33main :: IO ()
34main = do
35 tcounts <- runTestTT (TestList tests)
36 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
37 where
38 tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [
39 transactionGraphBasicTest,
40 transactionGraphAddCommitTest,
41 transactionRollbackTest,
42 transactionJumpTest,
43 transactionBranchTest,
44 simpleJoinTest,
45 testNotification,
46 testTypeConstructors,
47 testMergeTransactions,
48 testComments,
49 testTransGraphRelationalExpr,
50 failJoinTest,
51 testMultiAttributeRename,
52 testSchemaExpr,
53 testRelationalExprStateTupleElems,
54 testFunctionalDependencies,
55 testEmptyCommits,
56 testIntervalAtom,
57 testListConstructedAtom,
58 testTypeChecker,
59 testRestrictionPredicateExprs,
60 testRelationalAttributeNames,
61 testSemijoin,
62 testAntijoin
63 ]
64 simpleRelTests = [("x:=true", Right relationTrue),
65 ("x:=false", Right relationFalse),
66 ("x:=true union false", Right relationTrue),
67 ("x:=true minus false", Right relationTrue),
68 ("x:=false minus true", Right relationFalse),
69 ("x:=true; x:=false", Right relationFalse),
70 ("x:=relation{a Integer}{}", mkRelation simpleAAttributes emptyTupleSet),
71 ("x:=relation{c Integer}{} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),
72 ("y:=relation{b Integer, c Integer}{}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),
73 ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntegerAtom 5])]),
74 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
75 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
76 ("x:=relation{}{}", Right relationFalse),
77 ("x:=relation{tuple{}}", Right relationTrue),
78 ("x:=true where true", Right relationTrue),
79 ("x:=true where false", Right relationFalse),
80 ("x:=true where true or false", Right relationTrue),
81 ("x:=true where false or false", Right relationFalse),
82 ("x:=true where true and false", Right relationFalse),
83 ("x:=true where false and true", Right relationFalse),
84 ("x:=true where ^t and ^f", Right relationFalse),
85 ("x:=true where true and true", Right relationTrue),
86 ("x:=true=true", Right relationTrue),
87 ("x:=true=false", Right relationFalse),
88 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),
89 ("x:=relation {b Integer, a Text}{}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList [TextAtom "spam", IntegerAtom 5]]),
90 -- test nested relation constructor
91 ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [IntegerAtom 5, RelationAtom (Relation simpleAAttributes $ RelationTupleSet [RelationTuple simpleAAttributes $ V.fromList [IntegerAtom 6]])])]),
92 ("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", IntegerAtom 5])]),
93 ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 5])]),
94 ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 6])]),
95 ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 10])]),
96 ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntegerAtomType TextAtomType)),
97 ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 12])])
98 ]
99 simpleAAttributes = A.attributesFromList [Attribute "a" IntegerAtomType]
100 simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]
101 simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntegerAtomType]
102 simpleDAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" IntegerAtomType]
103 maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)
104 maybeIntegerAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntegerAtomType)
105 simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" maybeTextAtomType]
106 simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntegerAtomType]
107 simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]
108 simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType]
109 nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])]
110 extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]
111 byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]
112 groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType]
113 minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntegerAtomType]
114 updateParisPlus10 = relMap (\tuple -> do
115 statusAtom <- atomForAttributeName "status" tuple
116 cityAtom <- atomForAttributeName "city" tuple
117 if cityAtom == TextAtom "Paris" then
118 Right $ updateTupleWithAtoms (M.singleton "status" (IntegerAtom (castInteger statusAtom + 10))) tuple
119 else Right tuple) suppliersRel
120 dateExampleRelTests = [("x:=s where true", Right suppliersRel),
121 ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),
122 ("x:=s where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
123 ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]),
124 ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntegerAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntegerAtomType]) (V.fromList [IntegerAtom 50])])),
125 ("x:=s minus (s where status=20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),
126 --atom function tests
127 ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),
128 ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntegerAtom 5, RelationAtom suppliersRel])])),
129 ("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),
130 ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),
131 --relatom function tests
132 ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntegerAtom 1)])),
133 ("x:=(sp group ({s#} as y)) ungroup y", Right supplierProductsRel),
134 ("x:=((sp{s#,qty}) group ({qty} as x):{z:=max(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),
135 ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),
136 ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),
137 --boolean function restriction
138 ("x:=s where ^lt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),
139 ("x:=s where ^gt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],
140 [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),
141 ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntegerAtomType BoolAtomType),
142 ("x:=s where ^not(gte(@status,20))", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),
143 --test "all but" attribute inversion syntax
144 ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue),
145 --test key syntax
146 ("x:=s; key testconstraint {s#,city} x; insert x relation{tuple{city \"London\", s# \"S1\", sname \"gonk\", status 50}}", Left (InclusionDependencyCheckError "testconstraint")),
147 ("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),
148 --test binary bytestring data type
149 ("x:=relation{tuple{y bytestring(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),
150 --test Maybe Text
151 ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [TextAtom "spam"]]]),
152 --test Maybe Integer
153 ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntegerAtomType [IntegerAtom 3]]]),
154 --test Either Integer Text
155 ("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
156 ("x:=relation{a Either Integer Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType IntegerAtomType TextAtomType) [IntegerAtom 3]]]),
157 --test datetime constructor
158 ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]])
159 ]
161assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion
162assertTutdEqual databaseContext expected tutd = assertEqual (unpack tutd) expected interpreted
163 where
164 interpreted = case interpretDatabaseContextExpr databaseContext tutd of
165 Left err -> Left err
166 Right context -> case M.lookup "x" (relationVariables context) of
167 Nothing -> Left $ RelVarNotDefinedError "x"
168 Just rel -> Right rel
170transactionGraphBasicTest :: Test
171transactionGraphBasicTest = TestCase $ do
172 (_, dbconn) <- dateExamplesConnection emptyNotificationCallback
173 graph <- transactionGraph_ dbconn
174 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
176--add a new transaction to the graph, validate it is in the graph
177transactionGraphAddCommitTest :: Test
178transactionGraphAddCommitTest = TestCase $ do
179 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
180 case parseTutorialD "x:=s" of
181 Left err -> assertFailure (show err)
182 Right parsed -> do
183 result <- evalTutorialD sessionId dbconn UnsafeEvaluation parsed
184 case result of
185 QuitResult -> assertFailure "quit?"
186 DisplayResult _ -> assertFailure "display?"
187 DisplayIOResult _ -> assertFailure "displayIO?"
188 DisplayRelationResult _ -> assertFailure "displayrelation?"
189 DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"
190 DisplayErrorResult err -> assertFailure (show err)
191 QuietSuccessResult -> do
192 commit sessionId dbconn >>= eitherFail
193 discon <- disconnectedTransaction_ sessionId dbconn
194 let context = Discon.concreteDatabaseContext discon
195 assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)
197transactionRollbackTest :: Test
198transactionRollbackTest = TestCase $ do
199 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
200 graph <- transactionGraph_ dbconn
201 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail
202 rollback sessionId dbconn >>= eitherFail
203 discon <- disconnectedTransaction_ sessionId dbconn
204 graph' <- transactionGraph_ dbconn
205 assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))
206 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
207 assertEqual "validate graph" (graphEq graph) (graphEq graph')
209--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
210transactionJumpTest :: Test
211transactionJumpTest = TestCase $ do
212 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
213 (DisconnectedTransaction firstUUID _ _) <- disconnectedTransaction_ sessionId dbconn
214 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail
215 commit sessionId dbconn >>= eitherFail
216 --perform the jump
217 executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID) >>= eitherFail
218 --check that the disconnected transaction does not include "x"
219 discon <- disconnectedTransaction_ sessionId dbconn
220 assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))
221--branch from the first transaction and verify that there are two heads
222transactionBranchTest :: Test
223transactionBranchTest = TestCase $ do
224 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
225 mapM_ (>>= eitherFail) [executeGraphExpr sessionId dbconn (Branch "test"),
226 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),
227 commit sessionId dbconn,
228 executeGraphExpr sessionId dbconn (JumpToHead "master"),
229 executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ()))
230 ]
231 graph <- transactionGraph_ dbconn
232 assertBool "master branch exists" $ isJust (transactionForHead "master" graph)
233 assertBool "test branch exists" $ isJust (transactionForHead "test" graph)
235-- test that overlapping attribute names with different types fail with an error
236failJoinTest :: Test
237failJoinTest = TestCase $ assertTutdEqual basicDatabaseContext err "x:=relation{tuple{test 4}} join relation{tuple{test \"test\"}}"
238 where
239 err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntegerAtomType]))
241simpleJoinTest :: Test
242simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=s join sp"
243 where
244 attrs = A.attributesFromList [Attribute "city" TextAtomType,
245 Attribute "qty" IntegerAtomType,
246 Attribute "p#" TextAtomType,
247 Attribute "s#" TextAtomType,
248 Attribute "sname" TextAtomType,
249 Attribute "status" IntegerAtomType]
250 joinedRel = mkRelationFromList attrs [[TextAtom "London", IntegerAtom 100, TextAtom "P6", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
251 [TextAtom "London", IntegerAtom 400, TextAtom "P3", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
252 [TextAtom "London", IntegerAtom 400, TextAtom "P5", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],
253 [TextAtom "London", IntegerAtom 300, TextAtom "P1", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
254 [TextAtom "Paris", IntegerAtom 200, TextAtom "P2", TextAtom "S3", TextAtom "Blake", IntegerAtom 30],
255 [TextAtom "Paris", IntegerAtom 300, TextAtom "P1", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],
256 [TextAtom "London", IntegerAtom 100, TextAtom "P5", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
257 [TextAtom "London", IntegerAtom 300, TextAtom "P4", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],
258 [TextAtom "Paris", IntegerAtom 400, TextAtom "P2", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],
259 [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
260 [TextAtom "London", IntegerAtom 200, TextAtom "P4", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
261 [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S4", TextAtom "Clark", IntegerAtom 20]
262 ]
265{-
266inclusionDependencies :: Connection -> M.Map IncDepName InclusionDependency
267inclusionDependencies (InProcessConnection (DisconnectedTransaction _ context)) = inclusionDependencies context
268inclusionDependencies _ = error "remote connection used"
269-}
271-- test notifications over the InProcessConnection
272testNotification :: Test
273testNotification = TestCase $ do
274 notifmvar <- newEmptyMVar
275 let notifCallback mvar _ _ = putMVar mvar ()
276 relvarx = RelationVariable "x" ()
277 (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)
278 executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail
279 executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx relvarx) >>= eitherFail
280 commit sess conn >>= eitherFail
281 executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail
282 commit sess conn >>= eitherFail
283 takeMVar notifmvar
285testTypeConstructors :: Test
286testTypeConstructors = TestCase $ do
287 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
288 executeTutorialD sessionId dbconn "data Hair = Color Text | Bald | UserRefusesToSpecify"
289 executeTutorialD sessionId dbconn "x:=relation{a Hair}{tuple{a Color \"Blonde\"},tuple{a Bald},tuple{a UserRefusesToSpecify}}"
290 executeTutorialD sessionId dbconn "data Tree a = Node a (Tree a) (Tree a) | EmptyNode"
291 executeTutorialD sessionId dbconn "y:=relation{a Tree Integer}{tuple{a Node 3 (Node 4 EmptyNode EmptyNode) EmptyNode},tuple{a Node 4 EmptyNode EmptyNode}}"
293testMergeTransactions :: Test
294testMergeTransactions = TestCase $ do
295 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
296 mapM_ (executeTutorialD sessionId dbconn) [
297 ":branch branchA",
298 "conflictrv := relation{conflict Integer}{tuple{conflict 1}}",
299 ":commit",
300 ":jumphead master",
301 ":branch branchB",
302 "conflictrv := relation{conflict Integer}{tuple{conflict 2}}",
303 ":commit",
304 ":mergetrans union branchA branchB"
305 ]
306 case mkRelationFromList (attributesFromList [Attribute "conflict" IntegerAtomType]) [[IntegerAtom 1],[IntegerAtom 2]] of
307 Left err -> assertFailure (show err)
308 Right conflictCheck -> do
309 eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "conflictrv" ())
310 case eRv of
311 Left err -> assertFailure (show err)
312 Right conflictrv -> assertEqual "conflict union merge relvar" conflictCheck conflictrv
314testComments :: Test
315testComments = TestCase $ do
316 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
317 mapM_ (executeTutorialD sessionId dbconn) [
318 ":branch testbranch --test comment\n",
319 ":jumphead {- test comment -} master"]
321-- create a graph and query from two disparate contexts
322testTransGraphRelationalExpr :: Test
323testTransGraphRelationalExpr = TestCase $ do
324 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
325 mapM_ (executeTutorialD sessionId dbconn) [
326 "x:=s", --dud relvar so that the commit isn't empty
327 ":commit",
328 ":branch testbranch",
329 "insert s relation{tuple{city \"Boston\", s# \"S9\", sname \"Smithers\", status 50}}",
330 ":commit"
331 ]
332 let masterMarker = TransactionIdHeadNameLookup "master" []
333 testBranchMarker = TransactionIdHeadNameLookup "testbranch" []
334 sattrs = attributesFromList [Attribute "city" TextAtomType,
335 Attribute "sname" TextAtomType,
336 Attribute "s#" TextAtomType,
337 Attribute "status" IntegerAtomType]
338 expectedRel = mkRelationFromList sattrs [[TextAtom "Boston",
339 TextAtom "Smithers",
340 TextAtom "S9",
341 IntegerAtom 50]]
342 diff <- executeTransGraphRelationalExpr sessionId dbconn (Difference (RelationVariable "s" testBranchMarker) (RelationVariable "s" masterMarker))
343 assertEqual "difference in s" expectedRel diff
345 --test graph traversal (head backtracking)
346 let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]
347 backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))
348 assertEqual "backtrack to master" (Right relationTrue) backtrackRel
350 --test walkback to time (stay in current location)
351 now <- getCurrentTime
352 headId <- headTransactionId sessionId dbconn
353 _ <- executeGraphExpr sessionId dbconn (WalkBackToTime now)
354 headId' <- headTransactionId sessionId dbconn
355 assertEqual "transaction walk back stays in place" headId headId'
357 --test branch deletion
358 mapM_ (executeTutorialD sessionId dbconn) [
359 ":jumphead master",
360 ":deletebranch testbranch"]
361 eEvald <- case parseTutorialD ":jumphead testbranch" of
362 Left _ -> assertFailure "jumphead parse error" >> error "x"
363 Right parsed -> evalTutorialD sessionId dbconn UnsafeEvaluation parsed
364 case eEvald of
365 DisplayErrorResult err -> assertEqual "testbranch deletion" (show (NoSuchHeadNameError "testbranch")) (unpack err)
366 _ -> assertFailure "failed to delete branch"
368testMultiAttributeRename :: Test
369testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false"
370 where
371 sattrs = attributesFromList [Attribute "town" TextAtomType,
372 Attribute "sname" TextAtomType,
373 Attribute "s#" TextAtomType,
374 Attribute "price" IntegerAtomType]
375 renamedRel = mkRelationFromList sattrs []
377testSchemaExpr :: Test
378testSchemaExpr = TestCase $ do
379 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
380 mapM_ (executeTutorialD sessionId dbconn) [
381 ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" ^gte(17,@weight))",
382 ":setschema test",
383 ""
384 ]
385 eLightProduct <- executeRelationalExpr sessionId dbconn (RelationVariable "light_product" ())
386 lightProduct <- assertEither eLightProduct
387 let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntegerAtom 17), AttributeAtomExpr "weight"] ()))
388 setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName >>= eitherFail
389 eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ()))
390 restrictedProduct <- assertEither eRestrictedProduct
391 assertEqual "light product" restrictedProduct lightProduct
393assertEither :: (Show a) => Either a b -> IO b
394assertEither x = case x of
395 Left err -> assertFailure (show err) >> undefined
396 Right val -> pure val
398-- | Validate that a tuple passed through the context correctly typechecks and propagates to the AttributeAtomExpr.
399testRelationalExprStateTupleElems :: Test
400testRelationalExprStateTupleElems = TestCase $ do
401 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
402 executeTutorialD sessionId dbconn "x := (s : { parts := p rename {city as pcity} where pcity=@city}) : {z:=count(@parts)}"
404 executeTutorialD sessionId dbconn "y:=x{city,z}"
405 eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())
406 let expectedRel = mkRelationFromList (attributesFromList [Attribute "city" TextAtomType,
407 Attribute "z" IntegerAtomType])
408 [[TextAtom "Paris", IntegerAtom 2],
409 [TextAtom "London", IntegerAtom 3],
410 [TextAtom "Athens", IntegerAtom 0]]
411 assertEqual "validate parts count" expectedRel eRv
413 executeTutorialD sessionId dbconn "rv1:=relation{tuple{test 1}}"
414 executeTutorialD sessionId dbconn "rv2:=relation{tuple{val 1},tuple{val 2}}"
415 --check subexpression evaluation in restriction predicate
416 -- "rv1 where ((rv2 where val=@test) {})"
417 let correctSubexpr = Restrict (AttributeEqualityPredicate "val" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())
418 mainExpr subexpr = Restrict
419 (RelationalExprPredicate
420 (Project AN.empty subexpr)) (RelationVariable "rv1" ())
421 eRv2 <- executeRelationalExpr sessionId dbconn (mainExpr correctSubexpr)
422 let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntegerAtomType]) [[IntegerAtom 1]]
423 assertEqual "validate sub-expression attribute" expectedRel2 eRv2
425 --check error in subexpression
426 let wrongSubexpr = Restrict (AttributeEqualityPredicate "nosuchattr" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())
427 eRv3 <- executeRelationalExpr sessionId dbconn (mainExpr wrongSubexpr)
428 assertEqual "validate missing attribute in subexpression" (Left (NoSuchAttributeNamesError (S.singleton "nosuchattr"))) eRv3
430-- | Add a functional dependency on sname -> status and insert one tuple which is valid and another tuple which is invalid.
431testFunctionalDependencies :: Test
432testFunctionalDependencies = TestCase $ do
433 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
434 executeTutorialD sessionId dbconn "funcdep sname_status (sname) -> (status) s"
435 --insert a new, valid tuple
436 executeTutorialD sessionId dbconn "insert s relation{tuple{city \"Boston\", s# \"S6\", sname \"Stevens\", status 30}}"
437 --insert an constraint-violating tuple
438 let expectedError = "InclusionDependencyCheckError \"sname_status_A\""
439 expectTutorialDErr sessionId dbconn (T.isPrefixOf expectedError) "insert s relation{tuple{city \"Boston\", s# \"S7\", sname \"Jones\", status 20}}"
441testEmptyCommits :: Test
442testEmptyCommits = TestCase $ do
443 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
444 dirty <- disconnectedTransactionIsDirty sessionId dbconn
445 assertEqual "no change not dirty" (Right False) dirty
446 Right () <- commit sessionId dbconn
448 --insert no tuples
449 Right () <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ()))
450 dirty' <- disconnectedTransactionIsDirty sessionId dbconn
451 assertEqual "empty insert empty commit" (Right False) dirty'
452 Right () <- commit sessionId dbconn
454 --update no tuples
455 Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))
456 dirty'' <- disconnectedTransactionIsDirty sessionId dbconn
457 assertEqual "empty update empty commit" (Right False) dirty''
458 Right () <- commit sessionId dbconn
460 --delete no tuples
461 Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))
462 dirty''' <- disconnectedTransactionIsDirty sessionId dbconn
463 assertEqual "empty delete empty commit" (Right False) dirty'''
465testIntervalAtom :: Test
466testIntervalAtom = TestCase $ do
467 --test interval creation
468 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
469 executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,f,f), b interval(4,5,f,f)}, tuple{n 2,a interval(3,4,t,t), b interval(4,5,t,t)}}"
470 --test failed interval creation
471 let err1 = "AtomFunctionUserError InvalidIntervalOrderingError"
472 err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError \"Text\")"
473 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,f,f)}}"
474 expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",f,f)}}"
476 --test interval_overlaps
477 executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}"
478 eRv <- executeRelationalExpr sessionId dbconn (Project (AttributeNames (S.fromList ["n","c"])) (RelationVariable "y" ()))
479 assertEqual "interval overlap check" (mkRelationFromList (attributesFromList [Attribute "c" BoolAtomType,Attribute "n" IntegerAtomType]) [[BoolAtom True, IntegerAtom 1], [BoolAtom False, IntegerAtom 2]]) eRv
481testListConstructedAtom :: Test
482testListConstructedAtom = TestCase $ do
483 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
484 executeTutorialD sessionId dbconn "x:=relation{tuple{l Cons 4 (Cons 5 Empty)}}"
485 let err1 = "ConstructedAtomArgumentCountMismatchError 2 1"
486 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{l Cons 4}}"
487 let err2 = "TypeConstructorAtomTypeMismatch \"List\" IntegerAtomType"
488 expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{l Cons 4 5}}"
490testTypeChecker :: Test
491testTypeChecker = TestCase $ do
492 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
493 let err1 = "AtomFunctionTypeError \"max\" 1 (RelationAtomType [Attribute \"_\" IntegerAtomType]) IntegerAtomType"
494 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 0}}:{b:=max(@a)}"
496--exercise expression parser
497testRestrictionPredicateExprs :: Test
498testRestrictionPredicateExprs = TestCase $ do
499 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
500 -- or
501 executeTutorialD sessionId dbconn "x:=s where status=20 or status=10"
502 eRvOr <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
503 let expectedRelOr = restrict (\tuple ->
504 pure (atomForAttributeName "status" tuple `elem` [Right (IntegerAtom 10), Right (IntegerAtom 20)])) suppliersRel
505 assertEqual "status 20 or 10" expectedRelOr eRvOr
506 -- and
507 executeTutorialD sessionId dbconn "x:=s where status=20 and status=10"
508 eRvAnd <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
509 let expectedRelAnd = Right (emptyRelationWithAttrs (attributes suppliersRel))
510 assertEqual "status 20 and 10" expectedRelAnd eRvAnd
512testRelationalAttributeNames :: Test
513testRelationalAttributeNames = TestCase $ do
514 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
515 executeTutorialD sessionId dbconn "x:=(s join sp){all from sp}"
516 eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
517 case eRv of
518 Left err -> assertFailure (show err)
519 Right rel ->
520 assertEqual "attributes from sp" (attributes supplierProductsRel) (attributes rel)
522testSemijoin :: Test
523testSemijoin = TestCase $ do
524 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
525 executeTutorialD sessionId dbconn "x:=s semijoin sp"
526 executeTutorialD sessionId dbconn "y:=s where not (sname = \"Adams\")"
527 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
528 eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())
529 assertEqual "semijoin missing Adams" eX eY
531testAntijoin :: Test
532testAntijoin = TestCase $ do
533 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
534 executeTutorialD sessionId dbconn "x:=s antijoin sp"
535 executeTutorialD sessionId dbconn "y:=s where sname = \"Adams\""
536 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
537 eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())
538 assertEqual "antijoin only Adams" eX eY