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