git.iko.soy/project-m36
on master help sign in
WIP compilation checkpoint
3a95699AgentM
RelationalError.hs+2−1
compare with master
unifiedsplit
@@ -17,7 +17,8 @@ data RelationalError = NoSuchAttributeNameError String
17 | PredicateExpressionError String
17 | PredicateExpressionError String
18 | NoSuchTransactionError U.UUID
18 | NoSuchTransactionError U.UUID
19 | NoSuchHeadNameError HeadName
19 | NoSuchHeadNameError HeadName
20− | TransactionIsNotAHead U.UUID
20+ | TransactionIsNotAHeadError U.UUID
21+ | TransactionGraphCycleError U.UUID
21 deriving (Show,Eq)
22 deriving (Show,Eq)
22
23
23
24
RelationalTransaction.hs+62−21
@@ -5,6 +5,7 @@ import RelationalError
5import qualified Data.Set as S
5import qualified Data.Set as S
6import qualified Data.Map as M
6import qualified Data.Map as M
7import Control.Applicative ((<$>))
7import Control.Applicative ((<$>))
8+import Control.Monad
8
9
9bootstrapTransactionGraph :: UUID -> DatabaseContext -> TransactionGraph
10bootstrapTransactionGraph :: UUID -> DatabaseContext -> TransactionGraph
10bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
11bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
@@ -31,21 +32,25 @@ transactionForUUID uuid graph = if S.null matchingTrans then
31 Right $ head (S.toList matchingTrans)
32 Right $ head (S.toList matchingTrans)
32 where
33 where
33 matchingTrans = S.filter (\(Transaction uuidMatch _ _) -> uuidMatch == uuid) (transactionsForGraph graph)
34 matchingTrans = S.filter (\(Transaction uuidMatch _ _) -> uuidMatch == uuid) (transactionsForGraph graph)
34−
35+
35transactionsForUUIDs :: S.Set UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)
36transactionsForUUIDs :: S.Set UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)
36−transactionsForUUIDs uuidSet graph = S.map transactionForUUID uuidSet
37+transactionsForUUIDs uuidSet graph = do
38+ transList <- forM (S.toList uuidSet) ((flip transactionForUUID) graph)
39+ return (S.fromList transList)
40+
37
41
38-- the first transaction has no parent - all other do have parents- merges have two parents
42-- the first transaction has no parent - all other do have parents- merges have two parents
39parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
43parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
40−parentTransactions (Transaction _ (TransactionInfo pUUID _)) = case transactionForUUID pUUID of
44+parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do
45+ trans <- transactionForUUID pUUID graph
41− Just trans -> S.singleton trans
46+ return (S.singleton trans)
42− Nothing -> S.empty
47+
43−parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _)) = transactionsForUUIDs (S.fromList [pUUID1 pUUID2])
48+parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _ ) graph = transactionsForUUIDs (S.fromList [pUUID1, pUUID2]) graph
44
49
45
50
46−childTransactions :: Transaction -> TransactionGraph -> S.Set Transaction
51+childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
47−childTransactions (Transaction _ _ (TransactionInfo _ children _)) = undefined
52+childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForUUIDs children
48−childTransactions (Transaction _ _ (MergeTransactionInfo _ _ children _)) = undefined
53+childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForUUIDs children
49
54
50
55
51--create a disconnected transaction with a parent
56--create a disconnected transaction with a parent
@@ -61,20 +66,19 @@ addBranch newBranchName branchPoint graph@(TransactionGraph heads transSet) = if
61
66
62-- create a new commit and add it to the heads
67-- create a new commit and add it to the heads
63-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
68-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
64−addBranch :: UUID -> HeadName -> Transaction -> TransactionGraph -> Maybe (Transaction, TransactionGraph)
69+addBranch :: UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
65addBranch newUUID newBranchName branchPoint graph@(TransactionGraph heads transSet) = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph
70addBranch newUUID newBranchName branchPoint graph@(TransactionGraph heads transSet) = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph
66
71
67--adds a disconnected transaction to a transaction graph at some head
72--adds a disconnected transaction to a transaction graph at some head
68−addDisconnectedTransaction :: UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Maybe (Transaction, TransactionGraph)
73+addDisconnectedTransaction :: UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
69−addDisconnectedTransaction newUUID headName dTrans@(DisconnectedTransaction parentUUID context) graph = case transactionForUUID parentUUID graph of
74+addDisconnectedTransaction newUUID headName dTrans@(DisconnectedTransaction parentUUID context) graph = do
70− Nothing -> Nothing
75+ parentTrans <- transactionForUUID parentUUID graph
71− Just parentTrans ->
72− addTransactionToGraph headName parentTrans newUUID context graph
76+ addTransactionToGraph headName parentTrans newUUID context graph
73
77
74-- create a new transaction on "newHeadName" with the branchPointTrans
78-- create a new transaction on "newHeadName" with the branchPointTrans
75−addTransactionToGraph :: HeadName -> Transaction -> UUID -> DatabaseContext -> TransactionGraph -> Maybe (Transaction, TransactionGraph)
79+addTransactionToGraph :: HeadName -> Transaction -> UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
76addTransactionToGraph newHeadName branchPointTrans@(Transaction parentUUID _ parentInfo) newUUID newContext graph@(TransactionGraph heads transSet) = do
80addTransactionToGraph newHeadName branchPointTrans@(Transaction parentUUID _ parentInfo) newUUID newContext graph@(TransactionGraph heads transSet) = do
77− let freshTransaction = Transaction newUUID (transactionUUID branchPointTrans) (TransactionInfo S.empty newContext)
81+ let freshTransaction = Transaction newUUID (TransactionInfo (transactionUUID branchPointTrans) S.empty) newContext
78 -- there are two parents for MergeTransactions! not implemented
82 -- there are two parents for MergeTransactions! not implemented
79 --update parentTransaction to add child
83 --update parentTransaction to add child
80 let parentTransaction = branchPointTrans
84 let parentTransaction = branchPointTrans
@@ -83,8 +87,45 @@ addTransactionToGraph newHeadName branchPointTrans@(Transaction parentUUID _ par
83 return (freshTransaction, updatedGraph)
87 return (freshTransaction, updatedGraph)
84
88
85--check that all forward and backward links are in place
89--check that all forward and backward links are in place
86−validateGraph :: TransactionGraph -> Maybe RelationalError
90+validateGraph :: TransactionGraph -> Maybe [RelationalError]
87−validateGraph (TransactionGraph heads transSet) = undefined
91+validateGraph graph@(TransactionGraph heads transSet) = do
92+ errors <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
93+ mapM (walkChildTransactions S.empty graph) (S.toList transSet)
94+
95+--verify that all parent links exist and that all children exist
96+--maybe verify that all parents end at UUID nil and all children end at leaves
97+walkParentTransactions :: S.Set UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
98+walkParentTransactions seenTransSet graph trans =
99+ let transUUID = transactionUUID trans in
100+ if transUUID == nil then
101+ Nothing
102+ else if S.member transUUID seenTransSet then
103+ Just $ TransactionGraphCycleError transUUID
104+ else
105+ let parentTransSetOrError = parentTransactions trans graph in
106+ case parentTransSetOrError of
107+ Left err -> Just err
108+ Right parentTransSet -> do
109+ walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)
110+ case walk of
111+ err:xs -> Just err
112+ _ -> Nothing
88
113
114+--refactor: needless duplication in these two functions
89−validateTransaction :: Transaction -> TransactionGraph -> Maybe RelationalError
115+walkChildTransactions :: S.Set UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
90−validateTransaction trans@(Transaction sUUID pUUID info) = undefined
116+walkChildTransactions seenTransSet graph trans =
117+ let transUUID = transactionUUID trans in
118+ if childTransactions trans graph == Right S.empty then
119+ Nothing
120+ else if S.member transUUID seenTransSet then
121+ Just $ TransactionGraphCycleError transUUID
122+ else
123+ let childTransSetOrError = childTransactions trans graph in
124+ case childTransSetOrError of
125+ Left err -> Just err
126+ Right childTransSet -> do
127+ walk <- mapM (walkChildTransactions (S.insert transUUID seenTransSet) graph) (S.toList childTransSet)
128+ case walk of
129+ err:xs -> Just err
130+ _ -> Nothing
131+
TutorialDInterpreter.hs+13−13
@@ -370,8 +370,8 @@ evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOpe
370
370
371--affects only disconncted transaction
371--affects only disconncted transaction
372evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
372evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
373− Nothing -> Left $ NoSuchTransactionError jumpUUID
373+ Left err -> Left err
374− Just parentTrans -> Right (newTrans, graph)
374+ Right parentTrans -> Right (newTrans, graph)
375 where
375 where
376 newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
376 newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
377
377
@@ -398,22 +398,22 @@ evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) gr
398-- create a new commit and add it to the heads
398-- create a new commit and add it to the heads
399-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
399-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
400evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
400evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
401− Nothing -> Left $ NoSuchTransactionError parentUUID
401+ Left err -> Left err
402− Just parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
402+ Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
403− Nothing -> Left $ NoSuchTransactionError parentUUID -- improve error
403+ Left err -> Left err
404− Just (newTrans, newGraph) -> Right (newDiscon, newGraph)
404+ Right (newTrans, newGraph) -> Right (newDiscon, newGraph)
405 where
405 where
406 newDiscon = DisconnectedTransaction newUUID disconContext
406 newDiscon = DisconnectedTransaction newUUID disconContext
407
407
408-- add the disconnected transaction to the graph
408-- add the disconnected transaction to the graph
409-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
409-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
410evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
410evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
411− Nothing -> Left $ NoSuchTransactionError parentUUID
411+ Left err -> Left err
412− Just parentTransaction -> case headNameForTransaction parentTransaction graph of
412+ Right parentTransaction -> case headNameForTransaction parentTransaction graph of
413− Nothing -> Left $ TransactionIsNotAHead parentUUID
413+ Nothing -> Left $ TransactionIsNotAHeadError parentUUID
414 Just headName -> case maybeUpdatedGraph of
414 Just headName -> case maybeUpdatedGraph of
415− Nothing -> Left $ TransactionIsNotAHead parentUUID -- add better error
415+ Left err-> Left err
416− Just (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
416+ Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
417 where
417 where
418 newDisconnectedTrans = newDisconnectedTransaction newTransUUID context
418 newDisconnectedTrans = newDisconnectedTransaction newTransUUID context
419 --parentTransaction = transactionForUUID parentUUID graph
419 --parentTransaction = transactionForUUID parentUUID graph
@@ -438,8 +438,8 @@ promptText :: DisconnectedTransaction -> TransactionGraph -> String
438promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "
438promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "
439 where
439 where
440 transInfo = case transactionForUUID parentUUID graph of
440 transInfo = case transactionForUUID parentUUID graph of
441− Nothing -> "unknown"
441+ Left err -> "unknown"
442− Just parentTrans -> case headNameForTransaction parentTrans graph of
442+ Right parentTrans -> case headNameForTransaction parentTrans graph of
443 Nothing -> show $ transactionUUID parentTrans
443 Nothing -> show $ transactionUUID parentTrans
444 Just headName -> headName
444 Just headName -> headName
445
445
TutorialDInterpreterTest.hs+7−5
@@ -4,6 +4,7 @@ import RelationExpr
4import Relation
4import Relation
5import RelationalError
5import RelationalError
6import RelationType
6import RelationType
7+import RelationalTransaction
7import qualified Data.HashSet as HS
8import qualified Data.HashSet as HS
8import qualified Data.Map as M
9import qualified Data.Map as M
9import System.Exit
10import System.Exit
@@ -52,14 +53,15 @@ assertTutdEqual databaseContext tutd expected = assertEqual tutd interpreted exp
52 (Just err, _) -> Left err
53 (Just err, _) -> Left err
53 (Nothing, context) -> Right $ (relationVariables context) M.! "x"
54 (Nothing, context) -> Right $ (relationVariables context) M.! "x"
54
55
55−transactionGraphTest1 = TestCase $ assertEqual "validate bootstrapped graph"
56+transactionGraphTest1 = TestCase $ do
56− where
57+ (discon, graph) <- dateExamplesGraph
57− interpreted = interpretOps U.nextRandom
58+ assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
58− (discon, graph) = dateExampleGraph
59+
60+
59
61
60dateExamplesGraph :: IO (DisconnectedTransaction, TransactionGraph)
62dateExamplesGraph :: IO (DisconnectedTransaction, TransactionGraph)
61dateExamplesGraph = do
63dateExamplesGraph = do
62− firstTransactionUUID <- U.nextRandom
64+ firstTransactionUUID <- nextRandom
63 let graph = bootstrapTransactionGraph firstTransactionUUID dateExamples
65 let graph = bootstrapTransactionGraph firstTransactionUUID dateExamples
64 let discon = newDisconnectedTransaction firstTransactionUUID dateExamples
66 let discon = newDisconnectedTransaction firstTransactionUUID dateExamples
65 return (discon, graph)
67 return (discon, graph)