git.iko.soy/project-m36
on 0ff751e help sign in
project-m36/test/TutorialD/Interpreter.hs
664 lines 43 kB history raw
1import TutorialD.Interpreter.DatabaseContextExpr
2import TutorialD.Interpreter.TestBase
3import TutorialD.Interpreter
4import TutorialD.Interpreter.Base
5import Test.HUnit
6import ProjectM36.Relation as R
7import ProjectM36.Tuple
8import ProjectM36.TupleSet
9import ProjectM36.Error
10import ProjectM36.DatabaseContext
11import ProjectM36.AtomFunctions.Primitive
12import ProjectM36.DataTypes.Either
13import ProjectM36.DataTypes.Interval
14import ProjectM36.DataTypes.NonEmptyList
15import ProjectM36.DataTypes.List
16import ProjectM36.DateExamples
17import ProjectM36.Base hiding (Finite)
18import ProjectM36.TransactionGraph
19import ProjectM36.Client
20import qualified ProjectM36.DisconnectedTransaction as Discon
21import qualified ProjectM36.AttributeNames as AN
22import qualified ProjectM36.Session as Sess
23import qualified ProjectM36.Attribute as A
24import qualified Data.Map as M
25import System.Exit
26import Data.Maybe (isJust)
27import qualified Data.Vector as V
28import Data.Text.Encoding as TE
29import Control.Concurrent
30import qualified Data.Set as S
31import Data.Text hiding (map)
32import qualified Data.Text as T
33import Data.Time.Clock.POSIX hiding (getCurrentTime)
34import Data.Time.Clock (getCurrentTime)
35import Data.Time.Calendar (fromGregorian)
37main :: IO ()
38main = do
39 tcounts <- runTestTT (TestList tests)
40 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
41 where
42 tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++
43 map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [
44 transactionGraphBasicTest,
45 transactionGraphAddCommitTest,
46 transactionRollbackTest,
47 transactionJumpTest,
48 transactionBranchTest,
49 simpleJoinTest,
50 testNotification,
51 testTypeConstructors,
52 testMergeTransactions,
53 testComments,
54 testTransGraphRelationalExpr,
55 failJoinTest,
56 testMultiAttributeRename,
57 testSchemaExpr,
58 testRelationalExprStateTupleElems,
59 testFunctionalDependencies,
60 testEmptyCommits,
61 testIntervalAtom,
62 testListConstructedAtom,
63 testTypeChecker,
64 testRestrictionPredicateExprs,
65 testRelationalAttributeNames,
66 testSemijoin,
67 testAntijoin,
68 testRelationAttributeDefinition,
69 testAssignWithTypeVar,
70 testDefineWithTypeVar,
71 testIntervalType,
72 testArbitraryRelation,
73 testNonEmptyListType,
74 testUnresolvedAtomTypes,
75 testWithClause,
76 testAtomFunctionArgumentMismatch,
77 testInvalidDataConstructor,
78 testBasicList,
79 testRelationDeclarationMismatch
80 ]
81 simpleRelTests = [("x:=true", Right relationTrue),
82 ("x:=false", Right relationFalse),
83 ("x:=true union false", Right relationTrue),
84 ("x:=true minus false", Right relationTrue),
85 ("x:=false minus true", Right relationFalse),
86 ("x:=true; x:=false", Right relationFalse),
87 ("x:=relation{a Integer}{}", mkRelation simpleAAttributes emptyTupleSet),
88 ("x:=relation{c Integer}{} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),
89 ("y:=relation{b Integer, c Integer}{}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),
90 ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntegerAtom 5])]),
91 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
92 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
93 ("x:=relation{}{}", Right relationFalse),
94 ("x:=relation{tuple{}}", Right relationTrue),
95 ("x:=true where true", Right relationTrue),
96 ("x:=true where false", Right relationFalse),
97 ("x:=true where true or false", Right relationTrue),
98 ("x:=true where false or false", Right relationFalse),
99 ("x:=true where true and false", Right relationFalse),
100 ("x:=true where false and true", Right relationFalse),
101 ("x:=true where ^t and ^f", Right relationFalse),
102 ("x:=true where true and true", Right relationTrue),
103 ("x:=true=true", Right relationTrue),
104 ("x:=true=false", Right relationFalse),
105 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),
106 ("x:=relation {b Integer, a Text}{}; insert x relation{tuple{b -5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList [TextAtom "spam", IntegerAtom (-5)]]),
107 -- test nested relation constructor
108 ("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]])])]),
109 ("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])]),
110 ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 5])]),
111 ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 6])]),
112 ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 10])]),
113 ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntegerAtomType TextAtomType)),
114 ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 12])])
115 ]
116 simpleAAttributes = A.attributesFromList [Attribute "a" IntegerAtomType]
117 simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]
118 simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntegerAtomType]
119 simpleDAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" IntegerAtomType]
120 maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)
121 maybeIntegerAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntegerAtomType)
122 simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" maybeTextAtomType]
123 simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntegerAtomType]
124 simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]
125 simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType]
126 nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])]
127 extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)]
128 byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]
129 groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType]
130 minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntegerAtomType]
131 updateParisPlus10 = relMap (\tuple -> do
132 statusAtom <- atomForAttributeName "status" tuple
133 cityAtom <- atomForAttributeName "city" tuple
134 if cityAtom == TextAtom "Paris" then
135 Right $ updateTupleWithAtoms (M.singleton "status" (IntegerAtom (castInteger statusAtom + 10))) tuple
136 else Right tuple) suppliersRel
137 dateExampleRelTests = [("x:=s where true", Right suppliersRel),
138 ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == Right (TextAtom "London")) suppliersRel),
139 ("x:=s where false", Right $ Relation (R.attributes suppliersRel) emptyTupleSet),
140 ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (R.attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]),
141 ("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])])),
142 ("x:=s minus (s where status=20)", mkRelationFromList (R.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"]]),
143 --atom function tests
144 ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),
145 ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntegerAtom 5, RelationAtom suppliersRel])])),
146 ("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),
147 ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),
148 --relatom function tests
149 ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntegerAtom 1)])),
150 ("x:=(sp group ({s#} as y)) ungroup y", Right supplierProductsRel),
151 ("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)])),
152 ("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)])),
153 ("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)])),
154 --boolean function restriction
155 ("x:=s where ^lt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),
156 ("x:=s where ^gt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],
157 [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),
158 ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntegerAtomType BoolAtomType),
159 ("x:=s where ^not(gte(@status,20))", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),
160 --test "all but" attribute inversion syntax
161 ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue),
162 --test key syntax
163 ("x:=s; key testconstraint {s#,city} x; insert x relation{tuple{city \"London\", s# \"S1\", sname \"gonk\", status 50}}", Left (InclusionDependencyCheckError "testconstraint")),
164 ("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),
165 --test binary bytestring data type
166 ("x:=relation{tuple{y bytestring(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),
167 --test Maybe Text
168 ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [TextAtom "spam"]]]),
169 --test Maybe Integer
170 ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntegerAtomType [IntegerAtom 3]]]),
171 --test Either Integer Text
172 ("x:=relation{tuple{a Left 3}}", Left (TypeConstructorTypeVarMissing "b")), -- Left 3, alone is not enough information to imply the type
173 ("x:=relation{a Either Integer Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType IntegerAtomType TextAtomType) [IntegerAtom 3]]]),
174 --test datetime constructor
175 ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]]),
176 --test Day constructor
177 ("x:=relation{tuple{a fromGregorian(2017,05,30)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DayAtomType]) [[DayAtom (fromGregorian 2017 05 30)]])
178 ]
180assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion
181assertTutdEqual databaseContext expected tutd = assertEqual (unpack tutd) expected interpreted
182 where
183 interpreted = case interpretDatabaseContextExpr databaseContext tutd of
184 Left err -> Left err
185 Right context -> case M.lookup "x" (relationVariables context) of
186 Nothing -> Left $ RelVarNotDefinedError "x"
187 Just rel -> Right rel
189transactionGraphBasicTest :: Test
190transactionGraphBasicTest = TestCase $ do
191 (_, dbconn) <- dateExamplesConnection emptyNotificationCallback
192 graph <- transactionGraph_ dbconn
193 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
195--add a new transaction to the graph, validate it is in the graph
196transactionGraphAddCommitTest :: Test
197transactionGraphAddCommitTest = TestCase $ do
198 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
199 case parseTutorialD "x:=s" of
200 Left err -> assertFailure (show err)
201 Right parsed -> do
202 result <- evalTutorialD sessionId dbconn UnsafeEvaluation parsed
203 case result of
204 QuitResult -> assertFailure "quit?"
205 DisplayResult _ -> assertFailure "display?"
206 DisplayIOResult _ -> assertFailure "displayIO?"
207 DisplayRelationResult _ -> assertFailure "displayrelation?"
208 DisplayDataFrameResult _ -> assertFailure "displaydataframe?"
209 DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"
210 DisplayErrorResult err -> assertFailure (show err)
211 QuietSuccessResult -> do
212 commit sessionId dbconn >>= eitherFail
213 discon <- disconnectedTransaction_ sessionId dbconn
214 let context = Discon.concreteDatabaseContext discon
215 assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)
217transactionRollbackTest :: Test
218transactionRollbackTest = TestCase $ do
219 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
220 graph <- transactionGraph_ dbconn
221 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail
222 rollback sessionId dbconn >>= eitherFail
223 discon <- disconnectedTransaction_ sessionId dbconn
224 graph' <- transactionGraph_ dbconn
225 assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))
226 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)
227 assertEqual "validate graph" (graphEq graph) (graphEq graph')
229--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
230transactionJumpTest :: Test
231transactionJumpTest = TestCase $ do
232 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
233 (DisconnectedTransaction firstUUID _ _) <- disconnectedTransaction_ sessionId dbconn
234 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail
235 commit sessionId dbconn >>= eitherFail
236 --perform the jump
237 executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID) >>= eitherFail
238 --check that the disconnected transaction does not include "x"
239 discon <- disconnectedTransaction_ sessionId dbconn
240 assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))
241--branch from the first transaction and verify that there are two heads
242transactionBranchTest :: Test
243transactionBranchTest = TestCase $ do
244 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
245 mapM_ (>>= eitherFail) [executeGraphExpr sessionId dbconn (Branch "test"),
246 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),
247 commit sessionId dbconn,
248 executeGraphExpr sessionId dbconn (JumpToHead "master"),
249 executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ()))
250 ]
251 graph <- transactionGraph_ dbconn
252 assertBool "master branch exists" $ isJust (transactionForHead "master" graph)
253 assertBool "test branch exists" $ isJust (transactionForHead "test" graph)
255-- test that overlapping attribute names with different types fail with an error
256failJoinTest :: Test
257failJoinTest = TestCase $ assertTutdEqual basicDatabaseContext err "x:=relation{tuple{test 4}} join relation{tuple{test \"test\"}}"
258 where
259 err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntegerAtomType]))
261simpleJoinTest :: Test
262simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=s join sp"
263 where
264 attrs = A.attributesFromList [Attribute "city" TextAtomType,
265 Attribute "qty" IntegerAtomType,
266 Attribute "p#" TextAtomType,
267 Attribute "s#" TextAtomType,
268 Attribute "sname" TextAtomType,
269 Attribute "status" IntegerAtomType]
270 joinedRel = mkRelationFromList attrs [[TextAtom "London", IntegerAtom 100, TextAtom "P6", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
271 [TextAtom "London", IntegerAtom 400, TextAtom "P3", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
272 [TextAtom "London", IntegerAtom 400, TextAtom "P5", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],
273 [TextAtom "London", IntegerAtom 300, TextAtom "P1", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
274 [TextAtom "Paris", IntegerAtom 200, TextAtom "P2", TextAtom "S3", TextAtom "Blake", IntegerAtom 30],
275 [TextAtom "Paris", IntegerAtom 300, TextAtom "P1", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],
276 [TextAtom "London", IntegerAtom 100, TextAtom "P5", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
277 [TextAtom "London", IntegerAtom 300, TextAtom "P4", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],
278 [TextAtom "Paris", IntegerAtom 400, TextAtom "P2", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],
279 [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
280 [TextAtom "London", IntegerAtom 200, TextAtom "P4", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],
281 [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S4", TextAtom "Clark", IntegerAtom 20]
282 ]
285{-
286inclusionDependencies :: Connection -> M.Map IncDepName InclusionDependency
287inclusionDependencies (InProcessConnection (DisconnectedTransaction _ context)) = inclusionDependencies context
288inclusionDependencies _ = error "remote connection used"
289-}
291-- test notifications over the InProcessConnection
292testNotification :: Test
293testNotification = TestCase $ do
294 notifmvar <- newEmptyMVar
295 let notifCallback mvar _ _ = putMVar mvar ()
296 relvarx = RelationVariable "x" ()
297 (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)
298 executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail
299 executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx relvarx) >>= eitherFail
300 commit sess conn >>= eitherFail
301 executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail
302 commit sess conn >>= eitherFail
303 takeMVar notifmvar
305testTypeConstructors :: Test
306testTypeConstructors = TestCase $ do
307 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
308 executeTutorialD sessionId dbconn "data Hair = Color Text | Bald | UserRefusesToSpecify"
309 executeTutorialD sessionId dbconn "x:=relation{a Hair}{tuple{a Color \"Blonde\"},tuple{a Bald},tuple{a UserRefusesToSpecify}}"
310 executeTutorialD sessionId dbconn "data Tree a = Node a (Tree a) (Tree a) | EmptyNode"
311 executeTutorialD sessionId dbconn "y:=relation{a Tree Integer}{tuple{a Node 3 (Node 4 EmptyNode EmptyNode) EmptyNode},tuple{a Node 4 EmptyNode EmptyNode}}"
313testMergeTransactions :: Test
314testMergeTransactions = TestCase $ do
315 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
316 mapM_ (executeTutorialD sessionId dbconn) [
317 ":branch branchA",
318 "conflictrv := relation{conflict Integer}{tuple{conflict 1}}",
319 ":commit",
320 ":jumphead master",
321 ":branch branchB",
322 "conflictrv := relation{conflict Integer}{tuple{conflict 2}}",
323 ":commit",
324 ":mergetrans union branchA branchB"
325 ]
326 case mkRelationFromList (attributesFromList [Attribute "conflict" IntegerAtomType]) [[IntegerAtom 1],[IntegerAtom 2]] of
327 Left err -> assertFailure (show err)
328 Right conflictCheck -> do
329 eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "conflictrv" ())
330 case eRv of
331 Left err -> assertFailure (show err)
332 Right conflictrv -> assertEqual "conflict union merge relvar" conflictCheck conflictrv
334testComments :: Test
335testComments = TestCase $ do
336 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
337 mapM_ (executeTutorialD sessionId dbconn) [
338 ":branch testbranch --test comment\n",
339 ":jumphead {- test comment -} master"]
341-- create a graph and query from two disparate contexts
342testTransGraphRelationalExpr :: Test
343testTransGraphRelationalExpr = TestCase $ do
344 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
345 mapM_ (executeTutorialD sessionId dbconn) [
346 "x:=s", --dud relvar so that the commit isn't empty
347 ":commit",
348 ":branch testbranch",
349 "insert s relation{tuple{city \"Boston\", s# \"S9\", sname \"Smithers\", status 50}}",
350 ":commit"
351 ]
352 let masterMarker = TransactionIdHeadNameLookup "master" []
353 testBranchMarker = TransactionIdHeadNameLookup "testbranch" []
354 sattrs = attributesFromList [Attribute "city" TextAtomType,
355 Attribute "sname" TextAtomType,
356 Attribute "s#" TextAtomType,
357 Attribute "status" IntegerAtomType]
358 expectedRel = mkRelationFromList sattrs [[TextAtom "Boston",
359 TextAtom "Smithers",
360 TextAtom "S9",
361 IntegerAtom 50]]
362 diff <- executeTransGraphRelationalExpr sessionId dbconn (Difference (RelationVariable "s" testBranchMarker) (RelationVariable "s" masterMarker))
363 assertEqual "difference in s" expectedRel diff
365 --test graph traversal (head backtracking)
366 let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]
367 backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))
368 assertEqual "backtrack to master" (Right relationTrue) backtrackRel
370 --test walkback to time (stay in current location)
371 now <- getCurrentTime
372 headId <- headTransactionId sessionId dbconn
373 _ <- executeGraphExpr sessionId dbconn (WalkBackToTime now)
374 headId' <- headTransactionId sessionId dbconn
375 assertEqual "transaction walk back stays in place" headId headId'
377 --test branch deletion
378 mapM_ (executeTutorialD sessionId dbconn) [
379 ":jumphead master",
380 ":deletebranch testbranch"]
381 eEvald <- case parseTutorialD ":jumphead testbranch" of
382 Left _ -> assertFailure "jumphead parse error" >> error "x"
383 Right parsed -> evalTutorialD sessionId dbconn UnsafeEvaluation parsed
384 case eEvald of
385 DisplayErrorResult err -> assertEqual "testbranch deletion" (show (NoSuchHeadNameError "testbranch")) (unpack err)
386 _ -> assertFailure "failed to delete branch"
388testMultiAttributeRename :: Test
389testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false"
390 where
391 sattrs = attributesFromList [Attribute "town" TextAtomType,
392 Attribute "sname" TextAtomType,
393 Attribute "s#" TextAtomType,
394 Attribute "price" IntegerAtomType]
395 renamedRel = mkRelationFromList sattrs []
397testSchemaExpr :: Test
398testSchemaExpr = TestCase $ do
399 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
400 mapM_ (executeTutorialD sessionId dbconn) [
401 ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" ^gte(17,@weight))",
402 ":setschema test",
403 ""
404 ]
405 eLightProduct <- executeRelationalExpr sessionId dbconn (RelationVariable "light_product" ())
406 lightProduct <- assertEither eLightProduct
407 let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntegerAtom 17), AttributeAtomExpr "weight"] ()))
408 setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName >>= eitherFail
409 eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ()))
410 restrictedProduct <- assertEither eRestrictedProduct
411 assertEqual "light product" restrictedProduct lightProduct
413assertEither :: (Show a) => Either a b -> IO b
414assertEither x = case x of
415 Left err -> assertFailure (show err) >> undefined
416 Right val -> pure val
418-- | Validate that a tuple passed through the context correctly typechecks and propagates to the AttributeAtomExpr.
419testRelationalExprStateTupleElems :: Test
420testRelationalExprStateTupleElems = TestCase $ do
421 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
422 executeTutorialD sessionId dbconn "x := (s : { parts := p rename {city as pcity} where pcity=@city}) : {z:=count(@parts)}"
424 executeTutorialD sessionId dbconn "y:=x{city,z}"
425 eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())
426 let expectedRel = mkRelationFromList (attributesFromList [Attribute "city" TextAtomType,
427 Attribute "z" IntegerAtomType])
428 [[TextAtom "Paris", IntegerAtom 2],
429 [TextAtom "London", IntegerAtom 3],
430 [TextAtom "Athens", IntegerAtom 0]]
431 assertEqual "validate parts count" expectedRel eRv
433 executeTutorialD sessionId dbconn "rv1:=relation{tuple{test 1}}"
434 executeTutorialD sessionId dbconn "rv2:=relation{tuple{val 1},tuple{val 2}}"
435 --check subexpression evaluation in restriction predicate
436 -- "rv1 where ((rv2 where val=@test) {})"
437 let correctSubexpr = Restrict (AttributeEqualityPredicate "val" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())
438 mainExpr subexpr = Restrict
439 (RelationalExprPredicate
440 (Project AN.empty subexpr)) (RelationVariable "rv1" ())
441 eRv2 <- executeRelationalExpr sessionId dbconn (mainExpr correctSubexpr)
442 let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntegerAtomType]) [[IntegerAtom 1]]
443 assertEqual "validate sub-expression attribute" expectedRel2 eRv2
445 --check error in subexpression
446 let wrongSubexpr = Restrict (AttributeEqualityPredicate "nosuchattr" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())
447 eRv3 <- executeRelationalExpr sessionId dbconn (mainExpr wrongSubexpr)
448 assertEqual "validate missing attribute in subexpression" (Left (NoSuchAttributeNamesError (S.singleton "nosuchattr"))) eRv3
450-- | Add a functional dependency on sname -> status and insert one tuple which is valid and another tuple which is invalid.
451testFunctionalDependencies :: Test
452testFunctionalDependencies = TestCase $ do
453 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
454 executeTutorialD sessionId dbconn "funcdep sname_status (sname) -> (status) s"
455 --insert a new, valid tuple
456 executeTutorialD sessionId dbconn "insert s relation{tuple{city \"Boston\", s# \"S6\", sname \"Stevens\", status 30}}"
457 --insert an constraint-violating tuple
458 let expectedError = "InclusionDependencyCheckError \"sname_status_A\""
459 expectTutorialDErr sessionId dbconn (T.isPrefixOf expectedError) "insert s relation{tuple{city \"Boston\", s# \"S7\", sname \"Jones\", status 20}}"
461testEmptyCommits :: Test
462testEmptyCommits = TestCase $ do
463 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
464 dirty <- disconnectedTransactionIsDirty sessionId dbconn
465 assertEqual "no change not dirty" (Right False) dirty
466 Right () <- commit sessionId dbconn
468 --insert no tuples
469 Right () <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ()))
470 dirty' <- disconnectedTransactionIsDirty sessionId dbconn
471 assertEqual "empty insert empty commit" (Right False) dirty'
472 Right () <- commit sessionId dbconn
474 --update no tuples
475 Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))
476 dirty'' <- disconnectedTransactionIsDirty sessionId dbconn
477 assertEqual "empty update empty commit" (Right False) dirty''
478 Right () <- commit sessionId dbconn
480 --delete no tuples
481 Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))
482 dirty''' <- disconnectedTransactionIsDirty sessionId dbconn
483 assertEqual "empty delete empty commit" (Right False) dirty'''
485testIntervalAtom :: Test
486testIntervalAtom = TestCase $ do
487 --test interval creation
488 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
489 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)}}"
490 --test failed interval creation
491 let err1 = "AtomFunctionUserError InvalidIntervalOrderingError"
492 err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError \"Text\")"
493 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,f,f)}}"
494 expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",f,f)}}"
496 --test interval_overlaps
497 executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}"
498 eRv <- executeRelationalExpr sessionId dbconn (Project (AttributeNames (S.fromList ["n","c"])) (RelationVariable "y" ()))
499 assertEqual "interval overlap check" (mkRelationFromList (attributesFromList [Attribute "c" BoolAtomType,Attribute "n" IntegerAtomType]) [[BoolAtom True, IntegerAtom 1], [BoolAtom False, IntegerAtom 2]]) eRv
501testListConstructedAtom :: Test
502testListConstructedAtom = TestCase $ do
503 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
504 executeTutorialD sessionId dbconn "x:=relation{tuple{l Cons 4 (Cons 5 Empty)}}"
505 let err1 = "ConstructedAtomArgumentCountMismatchError 2 1"
506 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{l Cons 4}}"
507 let err2 = "TypeConstructorAtomTypeMismatch \"List\" IntegerAtomType"
508 expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{l Cons 4 5}}"
510testTypeChecker :: Test
511testTypeChecker = TestCase $ do
512 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
513 let err1 = "AtomFunctionTypeError \"max\" 1 (RelationAtomType [Attribute \"_\" IntegerAtomType]) IntegerAtomType"
514 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 0}}:{b:=max(@a)}"
516--exercise expression parser
517testRestrictionPredicateExprs :: Test
518testRestrictionPredicateExprs = TestCase $ do
519 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
520 -- or
521 executeTutorialD sessionId dbconn "x:=s where status=20 or status=10"
522 eRvOr <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
523 let expectedRelOr = restrict (\tuple ->
524 pure (atomForAttributeName "status" tuple `elem` [Right (IntegerAtom 10), Right (IntegerAtom 20)])) suppliersRel
525 assertEqual "status 20 or 10" expectedRelOr eRvOr
526 -- and
527 executeTutorialD sessionId dbconn "x:=s where status=20 and status=10"
528 eRvAnd <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
529 let expectedRelAnd = Right (emptyRelationWithAttrs (R.attributes suppliersRel))
530 assertEqual "status 20 and 10" expectedRelAnd eRvAnd
532testRelationalAttributeNames :: Test
533testRelationalAttributeNames = TestCase $ do
534 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
535 executeTutorialD sessionId dbconn "x:=(s join sp){all from sp}"
536 eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
537 case eRv of
538 Left err -> assertFailure (show err)
539 Right rel ->
540 assertEqual "attributes from sp" (R.attributes supplierProductsRel) (R.attributes rel)
542testSemijoin :: Test
543testSemijoin = TestCase $ do
544 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
545 executeTutorialD sessionId dbconn "x:=s semijoin sp"
546 executeTutorialD sessionId dbconn "y:=s where not (sname = \"Adams\")"
547 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
548 eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())
549 assertEqual "semijoin missing Adams" eX eY
551testAntijoin :: Test
552testAntijoin = TestCase $ do
553 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
554 executeTutorialD sessionId dbconn "x:=s antijoin sp"
555 executeTutorialD sessionId dbconn "y:=s where sname = \"Adams\""
556 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
557 eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())
558 assertEqual "antijoin only Adams" eX eY
560testRelationAttributeDefinition :: Test
561testRelationAttributeDefinition = TestCase $ do
562 -- test normal subrelation construction
563 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
564 executeTutorialD sessionId dbconn "x:=relation{a relation{b Integer}}{tuple{a relation{tuple{b 4}}}}"
565 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
566 let expected = mkRelationFromList attrs [[RelationAtom subRel]]
567 attrs = attributesFromList [Attribute "a" (RelationAtomType subRelAttrs)]
568 subRelAttrs = attributesFromList [Attribute "b" IntegerAtomType]
569 Right subRel = mkRelationFromList subRelAttrs [[IntegerAtom 4]]
570 assertEqual "relation attribute construction" expected eX
571 -- test rejected subrelation construction due to floating type variables
572 expectTutorialDErr sessionId dbconn (T.isPrefixOf "TypeConstructorTypeVarMissing") "y:=relation{a relation{b x}}"
574testAssignWithTypeVar :: Test
575testAssignWithTypeVar = TestCase $ do
576 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
577 let err1 = "TypeConstructorTypeVarMissing"
578 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "y:=relation{a int, b invalidtype}"
580testDefineWithTypeVar :: Test
581testDefineWithTypeVar = TestCase $ do
582 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
583 let err1 = "TypeConstructorTypeVarMissing"
584 expectTutorialDErr sessionId dbconn (T.isInfixOf err1) "y::{a int, b invalidtype}"
586testIntervalType :: Test
587testIntervalType = TestCase $ do
588 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
589 executeTutorialD sessionId dbconn "x:=relation{a Interval Integer}"
590 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
591 let expectedIntervalInt = mkRelationFromList expectedAttrs []
592 expectedAttrs = A.attributesFromList [Attribute "a" (intervalAtomType IntegerAtomType)]
593 assertEqual "Interval Int attribute" expectedIntervalInt eX
595testArbitraryRelation :: Test
596testArbitraryRelation = TestCase $ do
597 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
598 executeTutorialD sessionId dbconn "createarbitraryrelation rv1 {a Integer} 5-10"
599 executeTutorialD sessionId dbconn "createarbitraryrelation rv2 {a Integer, b relation{c Integer}} 10-100"
600 executeTutorialD sessionId dbconn "createarbitraryrelation rv3 {a Int, b relation{c Interval Int}} 3-100"
602testNonEmptyListType :: Test
603testNonEmptyListType = TestCase $ do
604 --create a NonEmptyList
605 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
606 executeTutorialD sessionId dbconn "x:=relation{tuple{a NECons 3 (Cons 4 Empty)}} : {x:=nonEmptyListHead(@a)}"
607 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
608 let expected = mkRelationFromList attrs [[nelist, nehead]]
609 attrs = attributesFromList [Attribute "a" neListType,
610 Attribute "x" IntegerAtomType]
611 neListType = nonEmptyListAtomType IntegerAtomType
612 listType = listAtomType IntegerAtomType
613 nelist = ConstructedAtom "NECons" (nonEmptyListAtomType IntegerAtomType) [
614 IntegerAtom 3,
615 ConstructedAtom "Cons" listType [IntegerAtom 4, ConstructedAtom "Empty" listType []]]
616 nehead = IntegerAtom 3
617 assertEqual "non-empty list type construction" expected eX
619testUnresolvedAtomTypes :: Test
620testUnresolvedAtomTypes = TestCase $ do
621 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
622 let err1 = "TypeConstructorTypeVarMissing"
623 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a Empty}}"
624 executeTutorialD sessionId dbconn "x:=relation{a List Int}{tuple{a Empty}}"
626-- with (x as s) s
627testWithClause :: Test
628testWithClause = TestCase $ do
629 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
630 executeTutorialD sessionId dbconn "x:=with (x as s) x"
631 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
632 assertEqual "with x as s" (Right suppliersRel) eX
634 let err1 = "RelVarAlreadyDefinedError"
635 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as s) s"
637 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as sp) s"
639testAtomFunctionArgumentMismatch :: Test
640testAtomFunctionArgumentMismatch = TestCase $ do
641 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
642 let err1 = "AtomTypeMismatchError"
643 --atom function type mismatch
644 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 5}} where ^gt(@a,1.5)"
645 --wrong argument count
646 let err2 = "FunctionArgumentCountMismatchError"
647 expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"
649testInvalidDataConstructor :: Test
650testInvalidDataConstructor = TestCase $ do
651 --test that a referenced TypeConstructor in a DataConstructor definition matches the expected count of arguments
652 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
653 let err1 = "ConstructedAtomArgumentCountMismatchError"
654 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "data TestT = TestT Maybe Int"
656testBasicList :: Test
657testBasicList = TestCase $ do
658 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
659 executeTutorialD sessionId dbconn "x := relation{tuple{ a (Cons 1 (Cons 2 Empty)) }}"
661testRelationDeclarationMismatch :: Test
662testRelationDeclarationMismatch = TestCase $ do
663 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback
664 expectTutorialDErr sessionId dbconn (T.isPrefixOf "AtomTypeMismatchError") "data A a = A a | B | C; a := relation{a A Integer}{tuple{a A \"1\"}}"