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