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