git.iko.soy/project-m36
on 82a6791 help sign in
project-m36/TutorialD/Interpreter/TransactionGraphOperator.hs
148 lines 6.6 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialD.Interpreter.TransactionGraphOperator where
3import TutorialD.Interpreter.Base
4import Text.Parsec
5import Text.Parsec.String
6import ProjectM36.Base
7import qualified Data.UUID as U
8import qualified Data.Text as T
9import ProjectM36.Error
10import ProjectM36.Transaction
11import ProjectM36.Transaction.Show
12import ProjectM36.Relation.Show.Term
14--operators which manipulate a transaction graph
15data TransactionGraphOperator where
16 JumpToHead :: HeadName -> TransactionGraphOperator
17 JumpToTransaction :: U.UUID -> TransactionGraphOperator
18 Branch :: HeadName -> TransactionGraphOperator
19 Commit :: TransactionGraphOperator
20 Rollback :: TransactionGraphOperator
21 ShowGraph :: TransactionGraphOperator
23jumpToHeadP :: Parser TransactionGraphOperator
24jumpToHeadP = do
25 reservedOp ":jumphead"
26 headid <- identifier
27 return $ JumpToHead (T.pack headid)
29jumpToTransactionP :: Parser TransactionGraphOperator
30jumpToTransactionP = do
31 reservedOp ":jump"
32 uuid <- uuidP
33 return $ JumpToTransaction uuid
35branchTransactionP :: Parser TransactionGraphOperator
36branchTransactionP = do
37 reservedOp ":branch"
38 branchName <- identifier
39 return $ Branch (T.pack branchName)
41commitTransactionP :: Parser TransactionGraphOperator
42commitTransactionP = do
43 reservedOp ":commit"
44 return $ Commit
46rollbackTransactionP :: Parser TransactionGraphOperator
47rollbackTransactionP = do
48 reservedOp ":rollback"
49 return $ Rollback
51showGraphP :: Parser TransactionGraphOperator
52showGraphP = do
53 reservedOp ":showgraph"
54 return $ ShowGraph
56transactionGraphOpP :: Parser TransactionGraphOperator
57transactionGraphOpP = do
58 jumpToHeadP
59 <|> jumpToTransactionP
60 <|> branchTransactionP
61 <|> commitTransactionP
62 <|> rollbackTransactionP
63 <|> showGraphP
65uuidP :: Parser U.UUID
66uuidP = do
67 uuidStr <- many (alphaNum <|> char '-')
68 case U.fromString uuidStr of
69 Nothing -> fail "Invalid uuid string"
70 Just uuid -> return uuid
72-- returns the new "current" transaction, updated graph, and tutorial d result
73-- the current transaction is not part of the transaction graph until it is committed
74evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
76--affects only disconncted transaction
77evalGraphOp _ _ graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
78 Left err -> Left err
79 Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)
80 where
81 newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
83-- switch from one head to another
84-- affects only disconnectedtransaction
85evalGraphOp _ _ graph (JumpToHead headName) =
86 case transactionForHead headName graph of
87 Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in
88 Right (disconnectedTrans, graph, QuietSuccessResult)
89 Nothing -> Left $ NoSuchHeadNameError headName
90-- add new head pointing to branchPoint
91-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
92-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
93 {-
94evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
95 Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
96 Just parentTrans -> case addBranch newBranchName parentTrans graph of
97 Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
98 Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
99 where
100 newDiscon = DisconnectedTransaction (transactionUUID parentTrans) disconContext
101-}
103-- create a new commit and add it to the heads
104-- 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)
105evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
106 Left err -> Left err
107 Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
108 Left err -> Left err
109 Right (_, newGraph) -> Right (newDiscon, newGraph, QuietSuccessResult)
110 where
111 newDiscon = DisconnectedTransaction newUUID disconContext
113-- add the disconnected transaction to the graph
114-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
115evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
116 Left err -> Left err
117 Right parentTransaction -> case headNameForTransaction parentTransaction graph of
118 Nothing -> Left $ TransactionIsNotAHeadError parentUUID
119 Just headName -> case maybeUpdatedGraph of
120 Left err-> Left err
121 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph, QuietSuccessResult)
122 where
123 newDisconnectedTrans = newDisconnectedTransaction newTransUUID context
124 maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
126-- refresh the disconnected transaction, return the same graph
127evalGraphOp _ (DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
128 Left err -> Left err
129 Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)
130 where
131 newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
133--display transaction graph as relation
134evalGraphOp _ discon graph ShowGraph = do
135 graphStr <- graphAsRelation discon graph
136 return (discon, graph, DisplayResult $ showRelation graphStr)
138{-
139-- for interpreter-specific operations
140interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
141interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
142 Left _ -> (trans, transGraph, NoActionResult)
143 Right ops -> case ops of
144 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
145 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
146 Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
147 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
148-}