git.iko.soy/project-m36
on f7fc888 help sign in
project-m36/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs
115 lines 4.2 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialD.Interpreter.TransactionGraphOperator where
3import TutorialD.Interpreter.Base
4import ProjectM36.TransactionGraph hiding (autoMergeToHead)
5import ProjectM36.Client as C
6import ProjectM36.Base
7import ProjectM36.Relation (relationTrue)
8import Data.Functor
10data ConvenienceTransactionGraphOperator = AutoMergeToHead MergeStrategy HeadName
11 deriving (Show)
13convenienceTransactionGraphOpP :: Parser ConvenienceTransactionGraphOperator
14convenienceTransactionGraphOpP = autoMergeToHeadP
16autoMergeToHeadP :: Parser ConvenienceTransactionGraphOperator
17autoMergeToHeadP = do
18 reserved ":automergetohead"
19 AutoMergeToHead <$> mergeTransactionStrategyP <*> identifier
21jumpToHeadP :: Parser TransactionGraphOperator
22jumpToHeadP = do
23 reservedOp ":jumphead"
24 JumpToHead <$> identifier
26jumpToTransactionP :: Parser TransactionGraphOperator
27jumpToTransactionP = do
28 reservedOp ":jump"
29 JumpToTransaction <$> uuidP
31walkBackToTimeP :: Parser TransactionGraphOperator
32walkBackToTimeP = do
33 reservedOp ":walkbacktotime"
34 WalkBackToTime <$> utcTimeP
36branchTransactionP :: Parser TransactionGraphOperator
37branchTransactionP = do
38 reservedOp ":branch"
39 Branch <$> identifier
41deleteBranchP :: Parser TransactionGraphOperator
42deleteBranchP = do
43 reserved ":deletebranch"
44 DeleteBranch <$> identifier
46commitTransactionP :: Parser TransactionGraphOperator
47commitTransactionP = do
48 reservedOp ":commit"
49 pure Commit
51rollbackTransactionP :: Parser TransactionGraphOperator
52rollbackTransactionP = do
53 reservedOp ":rollback"
54 return Rollback
56showGraphP :: Parser ROTransactionGraphOperator
57showGraphP = do
58 reservedOp ":showgraph"
59 return ShowGraph
61mergeTransactionStrategyP :: Parser MergeStrategy
62mergeTransactionStrategyP = (reserved "union" $> UnionMergeStrategy) <|>
63 (do
64 reserved "selectedbranch"
65 SelectedBranchMergeStrategy <$> identifier) <|>
66 (do
67 reserved "unionpreferbranch"
68 UnionPreferMergeStrategy <$> identifier)
70mergeTransactionsP :: Parser TransactionGraphOperator
71mergeTransactionsP = do
72 reservedOp ":mergetrans"
73 MergeTransactions <$> mergeTransactionStrategyP <*> identifier <*> identifier
75validateMerkleHashesP :: Parser ROTransactionGraphOperator
76validateMerkleHashesP = reservedOp ":validatemerklehashes" $> ValidateMerkleHashes
78transactionGraphOpP :: Parser TransactionGraphOperator
79transactionGraphOpP =
80 jumpToHeadP
81 <|> jumpToTransactionP
82 <|> walkBackToTimeP
83 <|> branchTransactionP
84 <|> deleteBranchP
85 <|> commitTransactionP
86 <|> rollbackTransactionP
87 <|> mergeTransactionsP
89roTransactionGraphOpP :: Parser ROTransactionGraphOperator
90roTransactionGraphOpP = showGraphP <|> validateMerkleHashesP
94{-
95-- for interpreter-specific operations
96interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
97interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
98 Left _ -> (trans, transGraph, NoActionResult)
99 Right ops -> case ops of
100 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
101 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
102 Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
103 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
104-}
106evalROGraphOp :: SessionId -> Connection -> ROTransactionGraphOperator -> IO (Either RelationalError Relation)
107evalROGraphOp sessionId conn ShowGraph = transactionGraphAsRelation sessionId conn
108evalROGraphOp sessionId conn ValidateMerkleHashes = do
109 eVal <- C.validateMerkleHashes sessionId conn
110 case eVal of
111 Left err -> pure (Left err)
112 Right _ -> pure (Right relationTrue)
114evalConvenienceGraphOp :: SessionId -> Connection -> ConvenienceTransactionGraphOperator -> IO (Either RelationalError ())
115evalConvenienceGraphOp sessionId conn (AutoMergeToHead strat head') = autoMergeToHead sessionId conn strat head'