git.iko.soy/project-m36
on master help sign in
refactor transaction graph display away from interpreter for preparation for client library

-the client library may wish to access the transaction graph as a relation

commit7bbe8c3ebfd319d8309dec23ba034ccf73df4277 authorAgentM <agentm@themactionfaction.com> dateThu 16 Jul 2015, 23:45 (11 years ago) parent106da6d
4 files changed+132−123
compare with master
unifiedsplit
ProjectM36/TransactionGraph.hs+118 ProjectM36/TransactionGraph/Show.hs+1−40 TutorialD/Interpreter.hs+9−3 TutorialD/Interpreter/TransactionGraphOperator.hs+4−80
ProjectM36/TransactionGraph.hs+118
@@ -2,11 +2,28 @@
22module ProjectM36.TransactionGraph where
33import ProjectM36.Base
44import 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
512import qualified Data.UUID as U
613import qualified Data.Set as S
714import qualified Data.Map as M
815import Control.Applicative ((<$>))
916import 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
1027
1128bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph
1229bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
@@ -126,3 +143,104 @@ walkChildTransactions seenTransSet graph trans =
126143 case walk of
127144 err:_ -> Just err
128145 _ -> 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 @@
11{-# LANGUAGE OverloadedStrings #-}
22module ProjectM36.TransactionGraph.Show where
33import ProjectM36.Base
4−import ProjectM36.Relation
5−import ProjectM36.Tuple
6−import ProjectM36.TupleSet
7−import ProjectM36.Error
84import ProjectM36.TransactionGraph
9−import qualified ProjectM36.Attribute as A
10−import qualified Data.HashSet as HS
115import qualified Data.Set as S
12−import qualified Data.Vector as V
13−import qualified Data.Text as T
6+
147
158showTransactionStructure :: Transaction -> TransactionGraph -> String
169showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo
@@ -25,39 +18,7 @@ showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" trans
2518 where
2619 folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"
2720
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− ]
4921
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)))
6122
6223
6324
TutorialD/Interpreter.hs+9−3
@@ -5,6 +5,7 @@ import TutorialD.Interpreter.RODatabaseContextOperator
55import TutorialD.Interpreter.DatabaseExpr
66import TutorialD.Interpreter.TransactionGraphOperator
77import ProjectM36.Base
8+import ProjectM36.Relation.Show.Term
89import ProjectM36.TransactionGraph
910import Text.Parsec
1011import Text.Parsec.String
@@ -25,12 +26,14 @@ graph ops are read-write operations which change the transaction graph
2526-}
2627data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
2728 DatabaseExprOp DatabaseExpr |
28− GraphOp TransactionGraphOperator
29+ GraphOp TransactionGraphOperator |
30+ ROGraphOp ROTransactionGraphOperator
2931
3032interpreterParserP :: Parser ParsedOperation
3133interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
3234 liftM GraphOp (transactionGraphOpP <* eof) <|>
33− liftM DatabaseExprOp (databaseExprOpP <* eof)
35+ liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>
36+ liftM DatabaseExprOp (databaseExprOpP <* eof)
3437
3538promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
3639promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
@@ -50,7 +53,10 @@ interpret freshUUID discon@(DisconnectedTransaction parentUUID context) graph in
5053 Right context' -> (QuietSuccessResult, DisconnectedTransaction parentUUID context', graph, False)
5154 Right (GraphOp execOp) -> case evalGraphOp freshUUID discon graph execOp of
5255 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)
5460
5561data InterpreterConfig = InterpreterConfig {
5662 persistenceStrategy :: PersistenceStrategy
TutorialD/Interpreter/TransactionGraphOperator.hs+4−80
@@ -3,24 +3,11 @@ module TutorialD.Interpreter.TransactionGraphOperator where
33import TutorialD.Interpreter.Base
44import Text.Parsec
55import Text.Parsec.String
6−import ProjectM36.Base
76import qualified Data.UUID as U
87import qualified Data.Text as T
9−import ProjectM36.Error
10−import ProjectM36.Transaction
118import ProjectM36.TransactionGraph
12−import ProjectM36.TransactionGraph.Show
139import ProjectM36.Relation.Show.Term
1410
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−
2411jumpToHeadP :: Parser TransactionGraphOperator
2512jumpToHeadP = do
2613 reservedOp ":jumphead"
@@ -49,7 +36,7 @@ rollbackTransactionP = do
4936 reservedOp ":rollback"
5037 return $ Rollback
5138
52−showGraphP :: Parser TransactionGraphOperator
39+showGraphP :: Parser ROTransactionGraphOperator
5340showGraphP = do
5441 reservedOp ":showgraph"
5542 return $ ShowGraph
@@ -61,7 +48,9 @@ transactionGraphOpP = do
6148 <|> branchTransactionP
6249 <|> commitTransactionP
6350 <|> rollbackTransactionP
64− <|> showGraphP
51+
52+roTransactionGraphOpP :: Parser ROTransactionGraphOperator
53+roTransactionGraphOpP = showGraphP
6554
6655uuidP :: Parser U.UUID
6756uuidP = do
@@ -70,71 +59,6 @@ uuidP = do
7059 Nothing -> fail "Invalid uuid string"
7160 Just uuid -> return uuid
7261
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)
13862
13963{-
14064-- for interpreter-specific operations