git.iko.soy/project-m36
on 802f2ce help sign in
project-m36/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs
113 lines 4.0 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialD.Interpreter.TransactionGraphOperator where
3import TutorialD.Interpreter.Base
4import Text.Megaparsec.Text
5import Text.Megaparsec
6import ProjectM36.TransactionGraph hiding (autoMergeToHead)
7import ProjectM36.Client
8import ProjectM36.Base
9import Data.Functor
11data ConvenienceTransactionGraphOperator = AutoMergeToHead MergeStrategy HeadName
12 deriving (Show)
14convenienceTransactionGraphOpP :: Parser ConvenienceTransactionGraphOperator
15convenienceTransactionGraphOpP = autoMergeToHeadP
17autoMergeToHeadP :: Parser ConvenienceTransactionGraphOperator
18autoMergeToHeadP = do
19 reserved ":automergetohead"
20 AutoMergeToHead <$> mergeTransactionStrategyP <*> identifier
22jumpToHeadP :: Parser TransactionGraphOperator
23jumpToHeadP = do
24 reservedOp ":jumphead"
25 JumpToHead <$> identifier
27jumpToTransactionP :: Parser TransactionGraphOperator
28jumpToTransactionP = do
29 reservedOp ":jump"
30 JumpToTransaction <$> uuidP
32walkBackToTimeP :: Parser TransactionGraphOperator
33walkBackToTimeP = do
34 reservedOp ":walkbacktotime"
35 WalkBackToTime <$> utcTimeP
37branchTransactionP :: Parser TransactionGraphOperator
38branchTransactionP = do
39 reservedOp ":branch"
40 Branch <$> identifier
42deleteBranchP :: Parser TransactionGraphOperator
43deleteBranchP = do
44 reserved ":deletebranch"
45 DeleteBranch <$> identifier
47commitTransactionP :: Parser TransactionGraphOperator
48commitTransactionP = do
49 reservedOp ":commit"
50 pure Commit
52rollbackTransactionP :: Parser TransactionGraphOperator
53rollbackTransactionP = do
54 reservedOp ":rollback"
55 return Rollback
57showGraphP :: Parser ROTransactionGraphOperator
58showGraphP = do
59 reservedOp ":showgraph"
60 return ShowGraph
62mergeTransactionStrategyP :: Parser MergeStrategy
63mergeTransactionStrategyP = (reserved "union" $> UnionMergeStrategy) <|>
64 (do
65 reserved "selectedbranch"
66 branch <- identifier
67 pure (SelectedBranchMergeStrategy branch)) <|>
68 (do
69 reserved "unionpreferbranch"
70 branch <- identifier
71 pure (UnionPreferMergeStrategy branch))
73mergeTransactionsP :: Parser TransactionGraphOperator
74mergeTransactionsP = do
75 reservedOp ":mergetrans"
76 strategy <- mergeTransactionStrategyP
77 headA <- identifier
78 headB <- identifier
79 pure (MergeTransactions strategy headA headB)
81transactionGraphOpP :: Parser TransactionGraphOperator
82transactionGraphOpP =
83 jumpToHeadP
84 <|> jumpToTransactionP
85 <|> walkBackToTimeP
86 <|> branchTransactionP
87 <|> deleteBranchP
88 <|> commitTransactionP
89 <|> rollbackTransactionP
90 <|> mergeTransactionsP
92roTransactionGraphOpP :: Parser ROTransactionGraphOperator
93roTransactionGraphOpP = showGraphP
97{-
98-- for interpreter-specific operations
99interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
100interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
101 Left _ -> (trans, transGraph, NoActionResult)
102 Right ops -> case ops of
103 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
104 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
105 Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
106 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
107-}
109evalROGraphOp :: SessionId -> Connection -> ROTransactionGraphOperator -> IO (Either RelationalError Relation)
110evalROGraphOp sessionId conn ShowGraph = transactionGraphAsRelation sessionId conn
112evalConvenienceGraphOp :: SessionId -> Connection -> ConvenienceTransactionGraphOperator -> IO (Either RelationalError ())
113evalConvenienceGraphOp sessionId conn (AutoMergeToHead strat head') = autoMergeToHead sessionId conn strat head'