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