git.iko.soy/project-m36
on 694fd44 help sign in
project-m36/TutorialDInterpreterTest.hs
151 lines 9.5 kB history raw
1import TutorialDInterpreter
2import Test.HUnit
3import RelationExpr
4import Relation
5import RelationalError
6import RelationType
7import RelationalTransaction
8import qualified Data.HashSet as HS
9import qualified Data.Map as M
10import qualified Data.Set as S
11import System.Exit
12import Data.UUID.V4 (nextRandom)
13import Data.UUID (nil)
14import Data.Either (isRight)
16main = do
17 counts <- runTestTT (TestList tests)
18 if errors counts + failures counts > 0 then exitFailure else exitSuccess
19 where
20 tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest]
21 simpleRelTests = [("x:=true", Right relationTrue),
22 ("x:=false", Right relationFalse),
23 ("x:=true union false", Right relationTrue),
24 ("x:=true; x:=false", Right relationFalse),
25 ("x:=relation{a int}", mkRelation simpleAAttributes HS.empty),
26 ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes HS.empty),
27 ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes HS.empty),
28 ("x:=relation{tuple{a char(\"spam\"), b int(5)}}", mkRelation simpleCAttributes (HS.fromList $ map RelationTuple [M.fromList [("a", StringAtom "spam"),("b",IntAtom 5)]])),
29 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
30 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
31 ("x:=true where true", Right relationTrue),
32 ("x:=true where false", Right relationFalse),
33 ("x:=true where true or false", Right relationTrue),
34 ("x:=true where false or false", Right relationFalse),
35 ("x:=true where true and false", Right relationFalse),
36 ("x:=true where true and true", Right relationTrue),
37 ("x:=true=true", Right relationTrue),
38 ("x:=true=false", Right relationFalse),
39 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),
40 ("x:=relation {b int, a char}; insert x relation{tuple{b int(5), a char(\"spam\")}}", mkRelation simpleCAttributes (HS.fromList [RelationTuple $ M.fromList [("a", StringAtom "spam"), ("b", IntAtom 5)]])),
41 ("x:=relation{tuple{b int(5),a char(\"spam\")},tuple{b int(6),a char(\"sam\")}}; delete x where b=6", mkRelation simpleCAttributes $ HS.fromList [RelationTuple $ M.fromList [("a", StringAtom "spam"), ("b", IntAtom 5)]])
42 ]
43 simpleAAttributes = M.fromList [("a", Attribute "a" IntAtomType)]
44 simpleBAttributes = M.fromList [("d", Attribute "d" IntAtomType)]
45 simpleCAttributes = M.fromList [("a", Attribute "a" StringAtomType), ("b", Attribute "b" IntAtomType)]
46 simpleProjectionAttributes = M.fromList [("c", Attribute "c" IntAtomType)]
47 dateExampleRelTests = [("x:=S where true", Right s),
48 ("x:=S where CITY = \"London\"", restrict (\(RelationTuple tupMap) -> tupMap M.! "CITY" == StringAtom "London") s),
49 ("x:=S where false", Right $ Relation (attributes s) HS.empty),
50 ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (M.fromList [("STATUS", Attribute "STATUS" IntAtomType)]) (HS.fromList [RelationTuple $ M.fromList [("STATUS", IntAtom 50)]])),
51 ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\(RelationTuple tupMap) -> RelationTuple $ if tupMap M.! "SNAME" == StringAtom "Blake" then M.insert "CITY" (StringAtom "Boston") tupMap else tupMap) s)
52 ]
54assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted
55 where
56 interpreted = case interpret databaseContext tutd of
57 (Just err, _) -> Left err
58 (Nothing, context) -> case M.lookup "x" (relationVariables context) of
59 Nothing -> Left $ RelVarNotDefinedError "x"
60 Just rel -> Right rel
62transactionGraphBasicTest = TestCase $ do
63 (discon, graph) <- dateExamplesGraph
64 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
66--add a new transaction to the graph, validate it is in the graph
67transactionGraphAddCommitTest = TestCase $ do
68 (discon@(DisconnectedTransaction firstUUID context), graph) <- dateExamplesGraph
69 freshUUID <- nextRandom
70 case interpret context "x:=S" of
71 (Just err, newContext) -> assertFailure (show err)
72 (Nothing, newContext) -> do
73 let discon = newDisconnectedTransaction firstUUID newContext
74 let addTrans = addDisconnectedTransaction freshUUID "master" discon graph
75 case addTrans of
76 Left err -> assertFailure (show err)
77 Right (newTrans, graph) -> do
78 assertBool "transaction in graph" (isRight $ transactionForUUID freshUUID graph)
79 assertEqual "validate fresh commit with deleted S" (validateGraph graph) Nothing
80 assertEqual "ensure S was deleted in newContext" (M.lookup "x" (relationVariables (transactionContext newTrans))) (Just s)
82transactionRollbackTest = TestCase $ do
83 (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
84 freshUUID <- nextRandom
85 case transactionForUUID firstUUID graph of
86 Left err -> assertFailure (show err)
87 Right firstTrans -> do
88 case interpret origContext "x:=S" of
89 (Just err, _) -> assertFailure (show err)
90 (Nothing, newContext) -> do
91 let discon = newDisconnectedTransaction firstUUID newContext
92 let (updatedDiscon@(DisconnectedTransaction _ newContext2), newGraph, result) = interpretOps freshUUID discon graph ":rollback"
93 assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing
94 assertEqual "validate graph" graph newGraph
96--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
97transactionJumpTest = TestCase $ do
98 (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
99 freshUUID <- nextRandom
100 case transactionForUUID firstUUID graph of
101 Left err -> assertFailure (show err)
102 Right firstTrans -> do
103 case interpret origContext "x:=S" of
104 (Just err, _) -> assertFailure (show err)
105 (Nothing, newContext) -> do
106 --modify the second transaction
107 case interpret newContext "x:=S" of
108 (Just err, _) -> assertFailure (show err)
109 (Nothing, newContext2) -> do
110 --add the transaction
111 let discon = newDisconnectedTransaction firstUUID newContext2
112 let addTrans = addDisconnectedTransaction freshUUID "master" discon graph
113 case addTrans of
114 Left err -> assertFailure (show err)
115 Right (newTrans, graph) -> do
116 --jump to the first transaction
117 let (updatedDiscon@(DisconnectedTransaction parentUUID newContext3), newGraph, result) = interpretOps freshUUID discon graph (":jump " ++ show firstUUID)
118 assertEqual "validate discon" parentUUID firstUUID
119 assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))
120 assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))
121 where
122 transactionUUIDs = S.fromList [firstUUID, freshUUID]
124--branch from the first transaction and verify that there are two heads
125transactionBranchTest = TestCase $ do
126 (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
127 freshUUID1 <- nextRandom
128 freshUUID2 <- nextRandom
129 case transactionForUUID firstUUID graph of
130 Left err -> assertFailure (show err)
131 Right firstTrans -> do
132 let disconMaster = newDisconnectedTransaction firstUUID origContext
133 let addTransMaster = addDisconnectedTransaction freshUUID1 "master" disconMaster graph
134 --add a second transaction to the "master" branch
135 case addTransMaster of
136 Left err -> assertFailure (show err)
137 Right (newTrans, graph) -> do
138 --add a third transaction to the "test" branch
139 let (updatedDiscon, newGraph, result) = interpretOps freshUUID2 origDiscon graph ":branch test"
140 assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)
141 assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)
142 where
143 maybeTransUUID t = maybe nil transactionUUID t
145dateExamplesGraph :: IO (DisconnectedTransaction, TransactionGraph)
146dateExamplesGraph = do
147 firstTransactionUUID <- nextRandom
148 let graph = bootstrapTransactionGraph firstTransactionUUID dateExamples
149 let discon = newDisconnectedTransaction firstTransactionUUID dateExamples
150 return (discon, graph)