git.iko.soy/project-m36
on ac258da help sign in
project-m36/test/TutorialD/Interpreter.hs
217 lines 16 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2import TutorialD.Interpreter.DatabaseExpr
3import TutorialD.Interpreter
4import TutorialD.Interpreter.Base
5import Test.HUnit
6import ProjectM36.RelationalExpression
7import ProjectM36.Relation
8import ProjectM36.Tuple
9import ProjectM36.TupleSet
10import ProjectM36.Error
11import ProjectM36.Base
12import ProjectM36.TransactionGraph
13import ProjectM36.Client
14import qualified ProjectM36.Attribute as A
15import qualified Data.HashSet as HS
16import qualified Data.Map as M
17import System.Exit
18import Data.Maybe (isJust)
19import System.IO
20import qualified Data.Vector as V
22--urgent: add group and ungroup tests- I missed the group relation type bug
23main :: IO ()
24main = do
25 tcounts <- runTestTT (TestList tests)
26 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
27 where
28 tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest]
29 simpleRelTests = [("x:=true", Right relationTrue),
30 ("x:=false", Right relationFalse),
31 ("x:=true union false", Right relationTrue),
32 ("x:=true; x:=false", Right relationFalse),
33 ("x:=relation{a int}", mkRelation simpleAAttributes emptyTupleSet),
34 ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),
35 ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),
36 ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ HS.singleton ((RelationTuple simpleCAttributes) (V.fromList [StringAtom "spam", IntAtom 5]))),
37 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
38 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
39 ("x:=true where true", Right relationTrue),
40 ("x:=true where false", Right relationFalse),
41 ("x:=true where true or false", Right relationTrue),
42 ("x:=true where false or false", Right relationFalse),
43 ("x:=true where true and false", Right relationFalse),
44 ("x:=true where true and true", Right relationTrue),
45 ("x:=true=true", Right relationTrue),
46 ("x:=true=false", Right relationFalse),
47 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),
48 ("x:=relation {b int, a char}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelation simpleCAttributes (HS.fromList [RelationTuple simpleCAttributes $ V.fromList [StringAtom "spam", IntAtom 5]])),
49 -- test nested relation constructor
50 ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ HS.singleton $ RelationTuple nestedRelationAttributes (V.fromList [IntAtom 5, RelationAtom (Relation simpleAAttributes (HS.singleton $ RelationTuple simpleAAttributes $ V.fromList [IntAtom 6]))])),
51 ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ HS.singleton $ RelationTuple simpleCAttributes (V.fromList [StringAtom "spam", IntAtom 5])),
52 ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 5])),
53 ("x:=relation{tuple{a 5}} : {b:=6}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 6])),
54 ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 10])),
55 ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntAtomType StringAtomType)),
56 ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelation simpleDAttributes $ HS.singleton $ RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 12]))
57 ]
58 simpleAAttributes = A.attributesFromList [Attribute "a" IntAtomType]
59 simpleBAttributes = A.attributesFromList [Attribute "d" IntAtomType]
60 simpleCAttributes = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" IntAtomType]
61 simpleDAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" IntAtomType]
62 simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]
63 nestedRelationAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntAtomType])]
64 extendTestAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]
65 groupCountAttrs = A.attributesFromList [Attribute "z" IntAtomType]
66 minMaxAttrs = A.attributesFromList [Attribute "S#" StringAtomType, Attribute "z" IntAtomType]
67 dateExampleRelTests = [("x:=S where true", Right suppliersRel),
68 ("x:=S where CITY = \"London\"", restrict (\tuple -> atomForAttributeName "CITY" tuple == (Right $ StringAtom "London")) suppliersRel),
69 ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
70 ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (A.attributesFromList [ Attribute "STATUS" IntAtomType]) (HS.singleton $ mkRelationTuple (A.attributesFromList [Attribute "STATUS" IntAtomType]) (V.fromList [IntAtom 50]))),
71 --atom function tests
72 ("x:=((S : {STATUS2 := add(10,@STATUS)}) where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),
73 ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "SNAME" tuple == (Right $ StringAtom "Blake") then updateTuple (M.singleton "CITY" (StringAtom "Boston")) tuple else tuple) suppliersRel),
74 ("x:=relation{tuple{a 5}} : {b:=S}", mkRelation extendTestAttributes (HS.singleton $ mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel]))),
75 --relatom function tests
76 ("x:=((S group ({CITY} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (HS.singleton $ mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1))),
77 ("x:=(SP group ({S#} as y)) ungroup y", Right supplierProductsRel),
78 ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=max(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),
79 ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=min(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),
80 ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=sum(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),
81 --boolean function restriction
82 ("x:=S where ^lt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"]]),
83 ("x:=S where ^gt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[StringAtom "S3", StringAtom "Blake", IntAtom 30, StringAtom "Paris"],
84 [StringAtom "S5", StringAtom "Adams", IntAtom 30, StringAtom "Athens"]]),
85 ("x:=S where ^sum(@STATUS)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType),
86 ("x:=S where ^not(gte(@STATUS,20))", mkRelationFromList (attributes suppliersRel) [[StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"]]),
87 --test "all but" attribute inversion syntax
88 ("x:=S{all but S#} = S{CITY,SNAME,STATUS}", Right $ relationTrue),
89 --test key syntax
90 ("x:=S; key testconstraint {S#,CITY} x; insert x relation{tuple{CITY \"London\", S# \"S1\", SNAME \"gonk\", STATUS 50}}", Left (InclusionDependencyCheckError "testconstraint")),
91 ("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)
93 ]
96assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion
97assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted
98 where
99 interpreted = case interpretDatabaseExpr databaseContext tutd of
100 Left err -> Left err
101 Right context -> case M.lookup "x" (relationVariables context) of
102 Nothing -> Left $ RelVarNotDefinedError "x"
103 Just rel -> Right rel
105transactionGraphBasicTest :: Test
106transactionGraphBasicTest = TestCase $ do
107 dbconn <- dateExamplesConnection
108 graph <- transactionGraph dbconn
109 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
111--add a new transaction to the graph, validate it is in the graph
112transactionGraphAddCommitTest :: Test
113transactionGraphAddCommitTest = TestCase $ do
114 dbconn <- dateExamplesConnection
115 case parseTutorialD dbconn "x:=S" of
116 Left err -> assertFailure (show err)
117 Right parsed -> do
118 result <- evalTutorialD dbconn parsed
119 case result of
120 QuitResult -> assertFailure "quit?"
121 DisplayResult _ -> assertFailure "display?"
122 DisplayIOResult _ -> assertFailure "displayIO?"
123 DisplayErrorResult err -> assertFailure (show err)
124 QuietSuccessResult -> do
125 commit dbconn >>= maybeFail
126 (DisconnectedTransaction _ context) <- disconnectedTransaction dbconn
127 assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)
129transactionRollbackTest :: Test
130transactionRollbackTest = TestCase $ do
131 dbconn <- dateExamplesConnection
132 graph <- transactionGraph dbconn
133 maybeErr <- executeDatabaseContextExpr dbconn (Assign "x" (RelationVariable "S"))
134 case maybeErr of
135 Just err -> assertFailure (show err)
136 Nothing -> do
137 rollback dbconn >>= maybeFail
138 (DisconnectedTransaction _ context') <- disconnectedTransaction dbconn
139 graph' <- transactionGraph dbconn
140 assertEqual "validate context" Nothing (M.lookup "x" (relationVariables context'))
141 assertEqual "validate graph" graph graph'
143--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
144transactionJumpTest :: Test
145transactionJumpTest = TestCase $ do
146 dbconn <- dateExamplesConnection
147 (DisconnectedTransaction firstUUID _) <- disconnectedTransaction dbconn
148 maybeErr <- executeDatabaseContextExpr dbconn (Assign "x" (RelationVariable "S"))
149 case maybeErr of
150 Just err -> assertFailure (show err)
151 Nothing -> do
152 commit dbconn >>= maybeFail
153 --perform the jump
154 maybeErr2 <- executeGraphExpr dbconn (JumpToTransaction firstUUID)
155 case maybeErr2 of
156 Just err -> assertFailure (show err)
157 Nothing -> do
158 --check that the disconnected transaction does not include "x"
159 (DisconnectedTransaction _ context') <- disconnectedTransaction dbconn
160 assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables context'))
162maybeFail :: (Show a) => Maybe a -> IO ()
163maybeFail (Just err) = assertFailure (show err)
164maybeFail Nothing = return ()
166--branch from the first transaction and verify that there are two heads
167transactionBranchTest :: Test
168transactionBranchTest = TestCase $ do
169 dbconn <- dateExamplesConnection
170 mapM_ (\x -> x >>= maybeFail) [executeGraphExpr dbconn (Branch "test"),
171 executeDatabaseContextExpr dbconn (Assign "x" (RelationVariable "S")),
172 commit dbconn,
173 executeGraphExpr dbconn (JumpToHead "master"),
174 executeDatabaseContextExpr dbconn (Assign "y" (RelationVariable "S"))
175 ]
176 graph <- transactionGraph dbconn
177 assertBool "master branch exists" $ isJust (transactionForHead "master" graph)
178 assertBool "test branch exists" $ isJust (transactionForHead "test" graph)
180simpleJoinTest :: Test
181simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=S join SP"
182 where
183 attrs = A.attributesFromList [Attribute "CITY" StringAtomType,
184 Attribute "QTY" IntAtomType,
185 Attribute "P#" StringAtomType,
186 Attribute "S#" StringAtomType,
187 Attribute "SNAME" StringAtomType,
188 Attribute "STATUS" IntAtomType]
189 joinedRel = mkRelationFromList attrs [[StringAtom "London", IntAtom 100, StringAtom "P6", StringAtom "S1", StringAtom "Smith", IntAtom 20],
190 [StringAtom "London", IntAtom 400, StringAtom "P3", StringAtom "S1", StringAtom "Smith", IntAtom 20],
191 [StringAtom "London", IntAtom 400, StringAtom "P5", StringAtom "S4", StringAtom "Clark", IntAtom 20],
192 [StringAtom "London", IntAtom 300, StringAtom "P1", StringAtom "S1", StringAtom "Smith", IntAtom 20],
193 [StringAtom "Paris", IntAtom 200, StringAtom "P2", StringAtom "S3", StringAtom "Blake", IntAtom 30],
194 [StringAtom "Paris", IntAtom 300, StringAtom "P1", StringAtom "S2", StringAtom "Jones", IntAtom 10],
195 [StringAtom "London", IntAtom 100, StringAtom "P5", StringAtom "S1", StringAtom "Smith", IntAtom 20],
196 [StringAtom "London", IntAtom 300, StringAtom "P4", StringAtom "S4", StringAtom "Clark", IntAtom 20],
197 [StringAtom "Paris", IntAtom 400, StringAtom "P2", StringAtom "S2", StringAtom "Jones", IntAtom 10],
198 [StringAtom "London", IntAtom 200, StringAtom "P2", StringAtom "S1", StringAtom "Smith", IntAtom 20],
199 [StringAtom "London", IntAtom 200, StringAtom "P4", StringAtom "S1", StringAtom "Smith", IntAtom 20],
200 [StringAtom "London", IntAtom 200, StringAtom "P2", StringAtom "S4", StringAtom "Clark", IntAtom 20]
201 ]
203dateExamplesConnection :: IO (Connection)
204dateExamplesConnection = do
205 dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence)
206 case dbconn of
207 Left err -> do
208 hPutStrLn stderr (show err)
209 exitFailure
210 Right conn -> do
211 mapM_ (\(rvName,rvRel) -> executeDatabaseContextExpr conn (Assign rvName (ExistingRelation rvRel))) (M.toList (relationVariables dateExamples))
212 mapM_ (\(idName,incDep) -> executeDatabaseContextExpr conn (AddInclusionDependency idName incDep)) (M.toList (inclusionDependencies dateExamples))
213 --skipping atom functions for now- there are no atom function manipulation operators yet
214 commit conn >>= maybeFail
215 return conn