git.iko.soy/project-m36
on fc8cc5e help sign in
project-m36/TutorialD/Interpreter/TransactionGraphOperator.hs
98 lines 3.4 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialD.Interpreter.TransactionGraphOperator where
3import TutorialD.Interpreter.Base
4import Text.Parsec
5import Text.Parsec.String
6import qualified Data.UUID as U
7import qualified Data.Text as T
8import ProjectM36.TransactionGraph
9import ProjectM36.Client
10import ProjectM36.Error
11import ProjectM36.Base
13jumpToHeadP :: Parser TransactionGraphOperator
14jumpToHeadP = do
15 reservedOp ":jumphead"
16 headid <- identifier
17 return $ JumpToHead (T.pack headid)
19jumpToTransactionP :: Parser TransactionGraphOperator
20jumpToTransactionP = do
21 reservedOp ":jump"
22 uuid <- uuidP
23 return $ JumpToTransaction uuid
25branchTransactionP :: Parser TransactionGraphOperator
26branchTransactionP = do
27 reservedOp ":branch"
28 branchName <- identifier
29 return $ Branch (T.pack branchName)
31commitTransactionP :: Parser TransactionGraphOperator
32commitTransactionP = do
33 reservedOp ":commit"
34 return $ Commit
36rollbackTransactionP :: Parser TransactionGraphOperator
37rollbackTransactionP = do
38 reservedOp ":rollback"
39 return $ Rollback
41showGraphP :: Parser ROTransactionGraphOperator
42showGraphP = do
43 reservedOp ":showgraph"
44 return $ ShowGraph
46mergeTransactionStrategyP :: Parser MergeStrategy
47mergeTransactionStrategyP = (reserved "union" *> pure UnionMergeStrategy) <|>
48 (do
49 reserved "selectedbranch"
50 branch <- identifier
51 pure (SelectedBranchMergeStrategy (T.pack branch))) <|>
52 (do
53 reserved "unionpreferbranch"
54 branch <- identifier
55 pure (UnionPreferMergeStrategy (T.pack branch)))
57mergeTransactionsP :: Parser TransactionGraphOperator
58mergeTransactionsP = do
59 reservedOp ":mergetrans"
60 strategy <- mergeTransactionStrategyP
61 headA <- identifier
62 headB <- identifier
63 pure (MergeTransactions strategy (T.pack headA) (T.pack headB))
65transactionGraphOpP :: Parser TransactionGraphOperator
66transactionGraphOpP = do
67 jumpToHeadP
68 <|> jumpToTransactionP
69 <|> branchTransactionP
70 <|> commitTransactionP
71 <|> rollbackTransactionP
72 <|> mergeTransactionsP
74roTransactionGraphOpP :: Parser ROTransactionGraphOperator
75roTransactionGraphOpP = showGraphP
77uuidP :: Parser U.UUID
78uuidP = do
79 uuidStr <- many (alphaNum <|> char '-')
80 case U.fromString uuidStr of
81 Nothing -> fail "Invalid uuid string"
82 Just uuid -> return uuid
85{-
86-- for interpreter-specific operations
87interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
88interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
89 Left _ -> (trans, transGraph, NoActionResult)
90 Right ops -> case ops of
91 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
92 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
93 Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
94 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
95-}
97evalROGraphOp :: SessionId -> Connection -> ROTransactionGraphOperator -> IO (Either RelationalError Relation)
98evalROGraphOp sessionId conn ShowGraph = transactionGraphAsRelation sessionId conn