git.iko.soy/project-m36
on b522248 help sign in
project-m36/TutorialD/Interpreter/TransactionGraphOperator.hs
149 lines 6.7 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.TransactionGraph
12import ProjectM36.TransactionGraph.Show
13import ProjectM36.Relation.Show.Term
15--operators which manipulate a transaction graph
16data TransactionGraphOperator where
17 JumpToHead :: HeadName -> TransactionGraphOperator
18 JumpToTransaction :: U.UUID -> TransactionGraphOperator
19 Branch :: HeadName -> TransactionGraphOperator
20 Commit :: TransactionGraphOperator
21 Rollback :: TransactionGraphOperator
22 ShowGraph :: TransactionGraphOperator
24jumpToHeadP :: Parser TransactionGraphOperator
25jumpToHeadP = do
26 reservedOp ":jumphead"
27 headid <- identifier
28 return $ JumpToHead (T.pack headid)
30jumpToTransactionP :: Parser TransactionGraphOperator
31jumpToTransactionP = do
32 reservedOp ":jump"
33 uuid <- uuidP
34 return $ JumpToTransaction uuid
36branchTransactionP :: Parser TransactionGraphOperator
37branchTransactionP = do
38 reservedOp ":branch"
39 branchName <- identifier
40 return $ Branch (T.pack branchName)
42commitTransactionP :: Parser TransactionGraphOperator
43commitTransactionP = do
44 reservedOp ":commit"
45 return $ Commit
47rollbackTransactionP :: Parser TransactionGraphOperator
48rollbackTransactionP = do
49 reservedOp ":rollback"
50 return $ Rollback
52showGraphP :: Parser TransactionGraphOperator
53showGraphP = do
54 reservedOp ":showgraph"
55 return $ ShowGraph
57transactionGraphOpP :: Parser TransactionGraphOperator
58transactionGraphOpP = do
59 jumpToHeadP
60 <|> jumpToTransactionP
61 <|> branchTransactionP
62 <|> commitTransactionP
63 <|> rollbackTransactionP
64 <|> showGraphP
66uuidP :: Parser U.UUID
67uuidP = do
68 uuidStr <- many (alphaNum <|> char '-')
69 case U.fromString uuidStr of
70 Nothing -> fail "Invalid uuid string"
71 Just uuid -> return uuid
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
75evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
77--affects only disconncted transaction
78evalGraphOp _ _ 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)
84-- switch from one head to another
85-- affects only disconnectedtransaction
86evalGraphOp _ _ 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 {-
95evalGraphOp 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-}
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)
106evalGraphOp 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
114-- add the disconnected transaction to the graph
115-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
116evalGraphOp 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
127-- refresh the disconnected transaction, return the same graph
128evalGraphOp _ (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)
134--display transaction graph as relation
135evalGraphOp _ discon graph ShowGraph = do
136 graphStr <- graphAsRelation discon graph
137 return (discon, graph, DisplayResult $ showRelation graphStr)
139{-
140-- for interpreter-specific operations
141interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
142interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
143 Left _ -> (trans, transGraph, NoActionResult)
144 Right ops -> case ops of
145 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
146 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
147 Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
148 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
149-}