git.iko.soy/project-m36
on master help sign in
refactor transaction graph display away from interpreter for preparation for client library
7bbe8c3AgentM
ProjectM36/TransactionGraph.hs+118
compare with master
unifiedsplit
@@ -2,11 +2,28 @@
2module ProjectM36.TransactionGraph where
2module ProjectM36.TransactionGraph where
3import ProjectM36.Base
3import ProjectM36.Base
4import ProjectM36.Error
4import ProjectM36.Error
5+import ProjectM36.Transaction
6+import ProjectM36.Relation
7+import ProjectM36.TupleSet
8+import ProjectM36.Tuple
9+import qualified Data.HashSet as HS
10+import qualified Data.Vector as V
11+import qualified ProjectM36.Attribute as A
5import qualified Data.UUID as U
12import qualified Data.UUID as U
6import qualified Data.Set as S
13import qualified Data.Set as S
7import qualified Data.Map as M
14import qualified Data.Map as M
8import Control.Applicative ((<$>))
15import Control.Applicative ((<$>))
9import Control.Monad
16import Control.Monad
17+import qualified Data.Text as T
18+
19+--operators which manipulate a transaction graph
20+data TransactionGraphOperator = JumpToHead HeadName |
21+ JumpToTransaction U.UUID |
22+ Branch HeadName |
23+ Commit |
24+ Rollback
25+
26+data ROTransactionGraphOperator = ShowGraph
10
27
11bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph
28bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph
12bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
29bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
@@ -126,3 +143,104 @@ walkChildTransactions seenTransSet graph trans =
126 case walk of
143 case walk of
127 err:_ -> Just err
144 err:_ -> Just err
128 _ -> Nothing
145 _ -> Nothing
146+
147+-- returns the new "current" transaction, updated graph, and tutorial d result
148+-- the current transaction is not part of the transaction graph until it is committed
149+evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
150+
151+--affects only disconncted transaction
152+evalGraphOp _ _ graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
153+ Left err -> Left err
154+ Right parentTrans -> Right (newTrans, graph)
155+ where
156+ newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
157+
158+-- switch from one head to another
159+-- affects only disconnectedtransaction
160+evalGraphOp _ _ graph (JumpToHead headName) =
161+ case transactionForHead headName graph of
162+ Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in
163+ Right (disconnectedTrans, graph)
164+ Nothing -> Left $ NoSuchHeadNameError headName
165+-- add new head pointing to branchPoint
166+-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
167+-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
168+ {-
169+evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
170+ Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
171+ Just parentTrans -> case addBranch newBranchName parentTrans graph of
172+ Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
173+ Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
174+ where
175+ newDiscon = DisconnectedTransaction (transactionUUID parentTrans) disconContext
176+-}
177+
178+-- create a new commit and add it to the heads
179+-- 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)
180+evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
181+ Left err -> Left err
182+ Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
183+ Left err -> Left err
184+ Right (_, newGraph) -> Right (newDiscon, newGraph)
185+ where
186+ newDiscon = DisconnectedTransaction newUUID disconContext
187+
188+-- add the disconnected transaction to the graph
189+-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
190+evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
191+ Left err -> Left err
192+ Right parentTransaction -> case headNameForTransaction parentTransaction graph of
193+ Nothing -> Left $ TransactionIsNotAHeadError parentUUID
194+ Just headName -> case maybeUpdatedGraph of
195+ Left err-> Left err
196+ Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
197+ where
198+ newDisconnectedTrans = newDisconnectedTransaction newTransUUID context
199+ maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
200+
201+-- refresh the disconnected transaction, return the same graph
202+evalGraphOp _ (DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
203+ Left err -> Left err
204+ Right parentTransaction -> Right (newDiscon, graph)
205+ where
206+ newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
207+
208+--display transaction graph as relation
209+evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
210+evalROGraphOp discon graph ShowGraph = do
211+ graphRel <- graphAsRelation discon graph
212+ return graphRel
213+
214+--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
215+graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
216+graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do
217+ tupleMatrix <- mapM tupleGenerator (S.toList transSet)
218+ mkRelationFromList attrs tupleMatrix
219+ where
220+ attrs = A.attributesFromList [Attribute "id" StringAtomType,
221+ Attribute "parents" (RelationAtomType parentAttributes),
222+ Attribute "current" IntAtomType,
223+ Attribute "head" StringAtomType
224+ ]
225+ parentAttributes = A.attributesFromList [Attribute "id" StringAtomType]
226+ tupleGenerator transaction = case transactionParentsRelation transaction graph of
227+ Left err -> Left err
228+ Right parentTransRel -> Right [StringAtom $ T.pack $ show (transactionUUID transaction),
229+ RelationAtom parentTransRel,
230+ IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0,
231+ StringAtom $ case headNameForTransaction transaction graph of
232+ Just headName -> headName
233+ Nothing -> ""
234+ ]
235+
236+transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
237+transactionParentsRelation trans graph = do
238+ if isRootTransaction trans graph then do
239+ mkRelation attrs emptyTupleSet
240+ else do
241+ parentTransSet <- parentTransactions trans graph
242+ let tupleSet = HS.fromList $ map trans2tuple (S.toList parentTransSet)
243+ mkRelation attrs tupleSet
244+ where
245+ attrs = A.attributesFromList [Attribute "id" StringAtomType]
246+ trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (StringAtom (T.pack (show $ transactionUUID trans2)))
ProjectM36/TransactionGraph/Show.hs+1−40
@@ -1,16 +1,9 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module ProjectM36.TransactionGraph.Show where
2module ProjectM36.TransactionGraph.Show where
3import ProjectM36.Base
3import ProjectM36.Base
4−import ProjectM36.Relation
5−import ProjectM36.Tuple
6−import ProjectM36.TupleSet
7−import ProjectM36.Error
8import ProjectM36.TransactionGraph
4import ProjectM36.TransactionGraph
9−import qualified ProjectM36.Attribute as A
10−import qualified Data.HashSet as HS
11import qualified Data.Set as S
5import qualified Data.Set as S
12−import qualified Data.Vector as V
6+
13−import qualified Data.Text as T
14
7
15showTransactionStructure :: Transaction -> TransactionGraph -> String
8showTransactionStructure :: Transaction -> TransactionGraph -> String
16showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo
9showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo
@@ -25,39 +18,7 @@ showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" trans
25 where
18 where
26 folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"
19 folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"
27
20
28−--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
29−graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
30−graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do
31− tupleMatrix <- mapM tupleGenerator (S.toList transSet)
32− mkRelationFromList attrs tupleMatrix
33− where
34− attrs = A.attributesFromList [Attribute "id" StringAtomType,
35− Attribute "parents" (RelationAtomType parentAttributes),
36− Attribute "current" IntAtomType,
37− Attribute "head" StringAtomType
38− ]
39− parentAttributes = A.attributesFromList [Attribute "id" StringAtomType]
40− tupleGenerator transaction = case transactionParentsRelation transaction graph of
41− Left err -> Left err
42− Right parentTransRel -> Right [StringAtom $ T.pack $ show (transactionUUID transaction),
43− RelationAtom parentTransRel,
44− IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0,
45− StringAtom $ case headNameForTransaction transaction graph of
46− Just headName -> headName
47− Nothing -> ""
48− ]
49
21
50−transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
51−transactionParentsRelation trans graph = do
52− if isRootTransaction trans graph then do
53− mkRelation attrs emptyTupleSet
54− else do
55− parentTransSet <- parentTransactions trans graph
56− let tupleSet = HS.fromList $ map trans2tuple (S.toList parentTransSet)
57− mkRelation attrs tupleSet
58− where
59− attrs = A.attributesFromList [Attribute "id" StringAtomType]
60− trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (StringAtom (T.pack (show $ transactionUUID trans2)))
61
22
62
23
63
24
TutorialD/Interpreter.hs+9−3
@@ -5,6 +5,7 @@ import TutorialD.Interpreter.RODatabaseContextOperator
5import TutorialD.Interpreter.DatabaseExpr
5import TutorialD.Interpreter.DatabaseExpr
6import TutorialD.Interpreter.TransactionGraphOperator
6import TutorialD.Interpreter.TransactionGraphOperator
7import ProjectM36.Base
7import ProjectM36.Base
8+import ProjectM36.Relation.Show.Term
8import ProjectM36.TransactionGraph
9import ProjectM36.TransactionGraph
9import Text.Parsec
10import Text.Parsec
10import Text.Parsec.String
11import Text.Parsec.String
@@ -25,12 +26,14 @@ graph ops are read-write operations which change the transaction graph
25-}
26-}
26data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
27data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
27 DatabaseExprOp DatabaseExpr |
28 DatabaseExprOp DatabaseExpr |
28− GraphOp TransactionGraphOperator
29+ GraphOp TransactionGraphOperator |
30+ ROGraphOp ROTransactionGraphOperator
29
31
30interpreterParserP :: Parser ParsedOperation
32interpreterParserP :: Parser ParsedOperation
31interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
33interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
32 liftM GraphOp (transactionGraphOpP <* eof) <|>
34 liftM GraphOp (transactionGraphOpP <* eof) <|>
35+ liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>
33− liftM DatabaseExprOp (databaseExprOpP <* eof)
36+ liftM DatabaseExprOp (databaseExprOpP <* eof)
34
37
35promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
38promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
36promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
39promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
@@ -50,7 +53,10 @@ interpret freshUUID discon@(DisconnectedTransaction parentUUID context) graph in
50 Right context' -> (QuietSuccessResult, DisconnectedTransaction parentUUID context', graph, False)
53 Right context' -> (QuietSuccessResult, DisconnectedTransaction parentUUID context', graph, False)
51 Right (GraphOp execOp) -> case evalGraphOp freshUUID discon graph execOp of
54 Right (GraphOp execOp) -> case evalGraphOp freshUUID discon graph execOp of
52 Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph, False)
55 Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph, False)
53− Right (discon', graph', result') -> (result', discon', graph', True)
56+ Right (discon', graph') -> (QuietSuccessResult, discon', graph', True)
57+ Right (ROGraphOp execOp) -> case evalROGraphOp discon graph execOp of
58+ Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph, False)
59+ Right rel -> (DisplayResult $ showRelation rel, discon, graph, False)
54
60
55data InterpreterConfig = InterpreterConfig {
61data InterpreterConfig = InterpreterConfig {
56 persistenceStrategy :: PersistenceStrategy
62 persistenceStrategy :: PersistenceStrategy
TutorialD/Interpreter/TransactionGraphOperator.hs+4−80
@@ -3,24 +3,11 @@ module TutorialD.Interpreter.TransactionGraphOperator where
3import TutorialD.Interpreter.Base
3import TutorialD.Interpreter.Base
4import Text.Parsec
4import Text.Parsec
5import Text.Parsec.String
5import Text.Parsec.String
6−import ProjectM36.Base
7import qualified Data.UUID as U
6import qualified Data.UUID as U
8import qualified Data.Text as T
7import qualified Data.Text as T
9−import ProjectM36.Error
10−import ProjectM36.Transaction
11import ProjectM36.TransactionGraph
8import ProjectM36.TransactionGraph
12−import ProjectM36.TransactionGraph.Show
13import ProjectM36.Relation.Show.Term
9import ProjectM36.Relation.Show.Term
14
10
15−--operators which manipulate a transaction graph
16−data TransactionGraphOperator where
17− JumpToHead :: HeadName -> TransactionGraphOperator
18− JumpToTransaction :: U.UUID -> TransactionGraphOperator
19− Branch :: HeadName -> TransactionGraphOperator
20− Commit :: TransactionGraphOperator
21− Rollback :: TransactionGraphOperator
22− ShowGraph :: TransactionGraphOperator
23−
24jumpToHeadP :: Parser TransactionGraphOperator
11jumpToHeadP :: Parser TransactionGraphOperator
25jumpToHeadP = do
12jumpToHeadP = do
26 reservedOp ":jumphead"
13 reservedOp ":jumphead"
@@ -49,7 +36,7 @@ rollbackTransactionP = do
49 reservedOp ":rollback"
36 reservedOp ":rollback"
50 return $ Rollback
37 return $ Rollback
51
38
52−showGraphP :: Parser TransactionGraphOperator
39+showGraphP :: Parser ROTransactionGraphOperator
53showGraphP = do
40showGraphP = do
54 reservedOp ":showgraph"
41 reservedOp ":showgraph"
55 return $ ShowGraph
42 return $ ShowGraph
@@ -61,7 +48,9 @@ transactionGraphOpP = do
61 <|> branchTransactionP
48 <|> branchTransactionP
62 <|> commitTransactionP
49 <|> commitTransactionP
63 <|> rollbackTransactionP
50 <|> rollbackTransactionP
51+
52+roTransactionGraphOpP :: Parser ROTransactionGraphOperator
64− <|> showGraphP
53+roTransactionGraphOpP = showGraphP
65
54
66uuidP :: Parser U.UUID
55uuidP :: Parser U.UUID
67uuidP = do
56uuidP = do
@@ -70,71 +59,6 @@ uuidP = do
70 Nothing -> fail "Invalid uuid string"
59 Nothing -> fail "Invalid uuid string"
71 Just uuid -> return uuid
60 Just uuid -> return uuid
72
61
73−-- returns the new "current" transaction, updated graph, and tutorial d result
74−-- the current transaction is not part of the transaction graph until it is committed
75−evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
76−
77−--affects only disconncted transaction
78−evalGraphOp _ _ graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
79− Left err -> Left err
80− Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)
81− where
82− newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
83−
84−-- switch from one head to another
85−-- affects only disconnectedtransaction
86−evalGraphOp _ _ graph (JumpToHead headName) =
87− case transactionForHead headName graph of
88− Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in
89− Right (disconnectedTrans, graph, QuietSuccessResult)
90− Nothing -> Left $ NoSuchHeadNameError headName
91−-- add new head pointing to branchPoint
92−-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
93−-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
94− {-
95−evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
96− Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
97− Just parentTrans -> case addBranch newBranchName parentTrans graph of
98− Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
99− Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
100− where
101− newDiscon = DisconnectedTransaction (transactionUUID parentTrans) disconContext
102−-}
103−
104−-- create a new commit and add it to the heads
105−-- 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)
106−evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
107− Left err -> Left err
108− Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
109− Left err -> Left err
110− Right (_, newGraph) -> Right (newDiscon, newGraph, QuietSuccessResult)
111− where
112− newDiscon = DisconnectedTransaction newUUID disconContext
113−
114−-- add the disconnected transaction to the graph
115−-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
116−evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
117− Left err -> Left err
118− Right parentTransaction -> case headNameForTransaction parentTransaction graph of
119− Nothing -> Left $ TransactionIsNotAHeadError parentUUID
120− Just headName -> case maybeUpdatedGraph of
121− Left err-> Left err
122− Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph, QuietSuccessResult)
123− where
124− newDisconnectedTrans = newDisconnectedTransaction newTransUUID context
125− maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
126−
127−-- refresh the disconnected transaction, return the same graph
128−evalGraphOp _ (DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
129− Left err -> Left err
130− Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)
131− where
132− newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
133−
134−--display transaction graph as relation
135−evalGraphOp _ discon graph ShowGraph = do
136− graphStr <- graphAsRelation discon graph
137− return (discon, graph, DisplayResult $ showRelation graphStr)
138
62
139{-
63{-
140-- for interpreter-specific operations
64-- for interpreter-specific operations