git.iko.soy/project-m36
on ffe683a help sign in
project-m36/test/TutorialD/Interpreter.hs
256 lines 19 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 qualified ProjectM36.Base as Base
13import ProjectM36.TransactionGraph
14import ProjectM36.Client
15import ProjectM36.Atom
16import qualified ProjectM36.Attribute as A
17import qualified Data.Map as M
18import System.Exit
19import Data.Maybe (isJust)
20import System.IO
21import qualified Data.Vector as V
22import Data.Text.Encoding as TE
23import Data.Typeable (Proxy(..))
24import Data.Text (Text)
25import Data.Time.Clock (UTCTime(..))
26import Data.Time.Calendar (fromGregorian)
27import Data.Interval (interval, Interval, Extended(Finite))
28import Control.Concurrent.STM
30main :: IO ()
31main = do
32 tcounts <- runTestTT (TestList tests)
33 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
34 where
35 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]
36 simpleRelTests = [("x:=true", Right relationTrue),
37 ("x:=false", Right relationFalse),
38 ("x:=true union false", Right relationTrue),
39 ("x:=true; x:=false", Right relationFalse),
40 ("x:=relation{a int}", mkRelation simpleAAttributes emptyTupleSet),
41 ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),
42 ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),
43 ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [(RelationTuple simpleCAttributes) (V.fromList [stringAtom "spam", intAtom 5])]),
44 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
45 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
46 ("x:=true where true", Right relationTrue),
47 ("x:=true where false", Right relationFalse),
48 ("x:=true where true or false", Right relationTrue),
49 ("x:=true where false or false", Right relationFalse),
50 ("x:=true where true and false", Right relationFalse),
51 ("x:=true where true and true", Right relationTrue),
52 ("x:=true=true", Right relationTrue),
53 ("x:=true=false", Right relationFalse),
54 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),
55 ("x:=relation {b int, a char}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList[stringAtom "spam", intAtom 5]]),
56 -- test nested relation constructor
57 ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [intAtom 5, Atom (Relation simpleAAttributes $ RelationTupleSet [RelationTuple simpleAAttributes $ V.fromList [intAtom 6]])])]),
58 ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [stringAtom "spam", intAtom 5])]),
59 ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [intAtom 5, intAtom 5])]),
60 ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [intAtom 5, intAtom 6])]),
61 ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [intAtom 5, intAtom 10])]),
62 ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 intAtomType stringAtomType)),
63 ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [intAtom 5, intAtom 12])])
64 ]
65 simpleAAttributes = A.attributesFromList [Attribute "a" intAtomType]
66 simpleBAttributes = A.attributesFromList [Attribute "d" intAtomType]
67 simpleCAttributes = A.attributesFromList [Attribute "a" stringAtomType, Attribute "b" intAtomType]
68 simpleDAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" intAtomType]
69 simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Maybe Text))]
70 simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Maybe Int))]
71 simpleIntervalDateTimeAttributes = A.attributesFromList [Attribute "a" $ atomTypeForProxy (Proxy :: Proxy (Interval UTCTime))]
72 simpleProjectionAttributes = A.attributesFromList [Attribute "c" intAtomType]
73 nestedRelationAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" intAtomType])]
74 extendTestAttributes = A.attributesFromList [Attribute "a" intAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]
75 byteStringAttributes = A.attributesFromList [Attribute "y" byteStringAtomType]
76 groupCountAttrs = A.attributesFromList [Attribute "z" intAtomType]
77 minMaxAttrs = A.attributesFromList [Attribute "S#" stringAtomType, Attribute "z" intAtomType]
78 dateExampleRelTests = [("x:=S where true", Right suppliersRel),
79 ("x:=S where CITY = \"London\"", restrict (\tuple -> atomForAttributeName "CITY" tuple == (Right $ stringAtom "London")) suppliersRel),
80 ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
81 ("x:=P where COLOR=\"Blue\" and CITY=\"Paris\"", mkRelationFromList (attributes productsRel) [[stringAtom "P5", stringAtom "Cam", stringAtom "Blue", intAtom 12, stringAtom "Paris"]]),
82 ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (A.attributesFromList [Attribute "STATUS" intAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "STATUS" intAtomType]) (V.fromList [intAtom 50])])),
83 --atom function tests
84 ("x:=((S : {STATUS2 := add(10,@STATUS)}) where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),
85 ("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),
86 ("x:=relation{tuple{a 5}} : {b:=S}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [intAtom 5, Atom suppliersRel])])),
87 --relatom function tests
88 ("x:=((S group ({CITY} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ intAtom 1)])),
89 ("x:=(SP group ({S#} as y)) ungroup y", Right supplierProductsRel),
90 ("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)])),
91 ("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)])),
92 ("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)])),
93 --boolean function restriction
94 ("x:=S where ^lt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"]]),
95 ("x:=S where ^gt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[stringAtom "S3", stringAtom "Blake", intAtom 30, stringAtom "Paris"],
96 [stringAtom "S5", stringAtom "Adams", intAtom 30, stringAtom "Athens"]]),
97 ("x:=S where ^sum(@STATUS)", Left $ AtomTypeMismatchError intAtomType boolAtomType),
98 ("x:=S where ^not(gte(@STATUS,20))", mkRelationFromList (attributes suppliersRel) [[stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"]]),
99 --test "all but" attribute inversion syntax
100 ("x:=S{all but S#} = S{CITY,SNAME,STATUS}", Right $ relationTrue),
101 --test key syntax
102 ("x:=S; key testconstraint {S#,CITY} x; insert x relation{tuple{CITY \"London\", S# \"S1\", SNAME \"gonk\", STATUS 50}}", Left (InclusionDependencyCheckError "testconstraint")),
103 ("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),
104 --test binary bytestring data type
105 ("x:=relation{tuple{y \"dGVzdGRhdGE=\"::bytestring}}", mkRelationFromList byteStringAttributes [[Atom (TE.encodeUtf8 "testdata")]]),
106 --test Maybe Text
107 ("x:=relation{tuple{a Just \"spam\"::maybe char}}", mkRelationFromList simpleMaybeTextAttributes [[Atom (Just "spam" :: Maybe Text)]]),
108 --test Maybe Int
109 ("x:=relation{tuple{a Just 3::maybe int}}", mkRelationFromList simpleMaybeIntAttributes [[Atom (Just 3 :: Maybe Int)]]),
110 --test datetime interval
111 ("x:=relation{tuple{a interval_datetime((\"2015-01-01 00:00:00\",\"2016-01-01 00:00:00\"])}}", mkRelationFromList simpleIntervalDateTimeAttributes [
112 [Atom $ interval (Finite (UTCTime (fromGregorian 2015 1 1) 0), False)
113 (Finite (UTCTime (fromGregorian 2016 1 1) 0), True)]
114 ])
115 ]
117assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion
118assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted
119 where
120 interpreted = case interpretDatabaseExpr databaseContext tutd of
121 Left err -> Left err
122 Right context -> case M.lookup "x" (relationVariables context) of
123 Nothing -> Left $ RelVarNotDefinedError "x"
124 Just rel -> Right rel
126transactionGraphBasicTest :: Test
127transactionGraphBasicTest = TestCase $ do
128 dbconn <- dateExamplesConnection
129 graph <- transactionGraph dbconn
130 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
132--add a new transaction to the graph, validate it is in the graph
133transactionGraphAddCommitTest :: Test
134transactionGraphAddCommitTest = TestCase $ do
135 dbconn <- dateExamplesConnection
136 case parseTutorialD "x:=S" of
137 Left err -> assertFailure (show err)
138 Right parsed -> do
139 result <- evalTutorialD dbconn parsed
140 case result of
141 QuitResult -> assertFailure "quit?"
142 DisplayResult _ -> assertFailure "display?"
143 DisplayIOResult _ -> assertFailure "displayIO?"
144 DisplayErrorResult err -> assertFailure (show err)
145 QuietSuccessResult -> do
146 commit dbconn >>= maybeFail
147 (DisconnectedTransaction _ context) <- disconnectedTransaction dbconn
148 assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)
150transactionRollbackTest :: Test
151transactionRollbackTest = TestCase $ do
152 dbconn <- dateExamplesConnection
153 graph <- transactionGraph dbconn
154 maybeErr <- executeDatabaseContextExpr dbconn (Assign "x" (RelationVariable "S"))
155 case maybeErr of
156 Just err -> assertFailure (show err)
157 Nothing -> do
158 rollback dbconn >>= maybeFail
159 (DisconnectedTransaction _ context') <- disconnectedTransaction dbconn
160 graph' <- transactionGraph dbconn
161 assertEqual "validate context" Nothing (M.lookup "x" (relationVariables context'))
162 assertEqual "validate graph" graph graph'
164--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
165transactionJumpTest :: Test
166transactionJumpTest = TestCase $ do
167 dbconn <- dateExamplesConnection
168 (DisconnectedTransaction firstUUID _) <- disconnectedTransaction dbconn
169 maybeErr <- executeDatabaseContextExpr dbconn (Assign "x" (RelationVariable "S"))
170 case maybeErr of
171 Just err -> assertFailure (show err)
172 Nothing -> do
173 commit dbconn >>= maybeFail
174 --perform the jump
175 maybeErr2 <- executeGraphExpr dbconn (JumpToTransaction firstUUID)
176 case maybeErr2 of
177 Just err -> assertFailure (show err)
178 Nothing -> do
179 --check that the disconnected transaction does not include "x"
180 (DisconnectedTransaction _ context') <- disconnectedTransaction dbconn
181 assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables context'))
183maybeFail :: (Show a) => Maybe a -> IO ()
184maybeFail (Just err) = assertFailure (show err)
185maybeFail Nothing = return ()
187--branch from the first transaction and verify that there are two heads
188transactionBranchTest :: Test
189transactionBranchTest = TestCase $ do
190 dbconn <- dateExamplesConnection
191 mapM_ (\x -> x >>= maybeFail) [executeGraphExpr dbconn (Branch "test"),
192 executeDatabaseContextExpr dbconn (Assign "x" (RelationVariable "S")),
193 commit dbconn,
194 executeGraphExpr dbconn (JumpToHead "master"),
195 executeDatabaseContextExpr dbconn (Assign "y" (RelationVariable "S"))
196 ]
197 graph <- transactionGraph dbconn
198 assertBool "master branch exists" $ isJust (transactionForHead "master" graph)
199 assertBool "test branch exists" $ isJust (transactionForHead "test" graph)
201simpleJoinTest :: Test
202simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=S join SP"
203 where
204 attrs = A.attributesFromList [Attribute "CITY" stringAtomType,
205 Attribute "QTY" intAtomType,
206 Attribute "P#" stringAtomType,
207 Attribute "S#" stringAtomType,
208 Attribute "SNAME" stringAtomType,
209 Attribute "STATUS" intAtomType]
210 joinedRel = mkRelationFromList attrs [[stringAtom "London", intAtom 100, stringAtom "P6", stringAtom "S1", stringAtom "Smith", intAtom 20],
211 [stringAtom "London", intAtom 400, stringAtom "P3", stringAtom "S1", stringAtom "Smith", intAtom 20],
212 [stringAtom "London", intAtom 400, stringAtom "P5", stringAtom "S4", stringAtom "Clark", intAtom 20],
213 [stringAtom "London", intAtom 300, stringAtom "P1", stringAtom "S1", stringAtom "Smith", intAtom 20],
214 [stringAtom "Paris", intAtom 200, stringAtom "P2", stringAtom "S3", stringAtom "Blake", intAtom 30],
215 [stringAtom "Paris", intAtom 300, stringAtom "P1", stringAtom "S2", stringAtom "Jones", intAtom 10],
216 [stringAtom "London", intAtom 100, stringAtom "P5", stringAtom "S1", stringAtom "Smith", intAtom 20],
217 [stringAtom "London", intAtom 300, stringAtom "P4", stringAtom "S4", stringAtom "Clark", intAtom 20],
218 [stringAtom "Paris", intAtom 400, stringAtom "P2", stringAtom "S2", stringAtom "Jones", intAtom 10],
219 [stringAtom "London", intAtom 200, stringAtom "P2", stringAtom "S1", stringAtom "Smith", intAtom 20],
220 [stringAtom "London", intAtom 200, stringAtom "P4", stringAtom "S1", stringAtom "Smith", intAtom 20],
221 [stringAtom "London", intAtom 200, stringAtom "P2", stringAtom "S4", stringAtom "Clark", intAtom 20]
222 ]
223transactionGraph :: Connection -> IO TransactionGraph
224transactionGraph (InProcessConnection _ tvar) = atomically $ do
225 (_, graph) <- readTVar tvar
226 pure graph
227transactionGraph _ = error "remote connection used"
229disconnectedTransaction :: Connection -> IO DisconnectedTransaction
230disconnectedTransaction (InProcessConnection _ tvar) = atomically $ do
231 (discon, _) <- readTVar tvar
232 pure discon
233disconnectedTransaction _ = error "remote connection used"
235{-
236inclusionDependencies :: Connection -> M.Map IncDepName InclusionDependency
237inclusionDependencies (InProcessConnection (DisconnectedTransaction _ context)) = inclusionDependencies context
238inclusionDependencies _ = error "remote connection used"
239-}
241dateExamplesConnection :: IO (Connection)
242dateExamplesConnection = do
243 dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence)
244 let incDeps = Base.inclusionDependencies dateExamples
245 case dbconn of
246 Left err -> do
247 hPutStrLn stderr (show err)
248 exitFailure
249 Right conn -> do
250 mapM_ (\(rvName,rvRel) -> executeDatabaseContextExpr conn (Assign rvName (ExistingRelation rvRel))) (M.toList (relationVariables dateExamples))
251 mapM_ (\(idName,incDep) -> executeDatabaseContextExpr conn (AddInclusionDependency idName incDep)) (M.toList incDeps)
252 --skipping atom functions for now- there are no atom function manipulation operators yet
253 commit conn >>= maybeFail
254 return conn