git.iko.soy/project-m36
on fbfa2ea help sign in
project-m36/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs
116 lines 4.1 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.Error
9import ProjectM36.Base
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 headid <- identifier
26 return $ JumpToHead headid
28jumpToTransactionP :: Parser TransactionGraphOperator
29jumpToTransactionP = do
30 reservedOp ":jump"
31 uuid <- uuidP
32 return $ JumpToTransaction uuid
34walkBackToTimeP :: Parser TransactionGraphOperator
35walkBackToTimeP = do
36 reservedOp ":walkbacktotime"
37 WalkBackToTime <$> utcTimeP
39branchTransactionP :: Parser TransactionGraphOperator
40branchTransactionP = do
41 reservedOp ":branch"
42 branchName <- identifier
43 return $ Branch branchName
45deleteBranchP :: Parser TransactionGraphOperator
46deleteBranchP = do
47 reserved ":deletebranch"
48 DeleteBranch <$> identifier
50commitTransactionP :: Parser TransactionGraphOperator
51commitTransactionP = do
52 reservedOp ":commit"
53 pure Commit
55rollbackTransactionP :: Parser TransactionGraphOperator
56rollbackTransactionP = do
57 reservedOp ":rollback"
58 return Rollback
60showGraphP :: Parser ROTransactionGraphOperator
61showGraphP = do
62 reservedOp ":showgraph"
63 return ShowGraph
65mergeTransactionStrategyP :: Parser MergeStrategy
66mergeTransactionStrategyP = (reserved "union" *> pure UnionMergeStrategy) <|>
67 (do
68 reserved "selectedbranch"
69 branch <- identifier
70 pure (SelectedBranchMergeStrategy branch)) <|>
71 (do
72 reserved "unionpreferbranch"
73 branch <- identifier
74 pure (UnionPreferMergeStrategy branch))
76mergeTransactionsP :: Parser TransactionGraphOperator
77mergeTransactionsP = do
78 reservedOp ":mergetrans"
79 strategy <- mergeTransactionStrategyP
80 headA <- identifier
81 headB <- identifier
82 pure (MergeTransactions strategy headA headB)
84transactionGraphOpP :: Parser TransactionGraphOperator
85transactionGraphOpP =
86 jumpToHeadP
87 <|> jumpToTransactionP
88 <|> walkBackToTimeP
89 <|> branchTransactionP
90 <|> deleteBranchP
91 <|> commitTransactionP
92 <|> rollbackTransactionP
93 <|> mergeTransactionsP
95roTransactionGraphOpP :: Parser ROTransactionGraphOperator
96roTransactionGraphOpP = showGraphP
100{-
101-- for interpreter-specific operations
102interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
103interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
104 Left _ -> (trans, transGraph, NoActionResult)
105 Right ops -> case ops of
106 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
107 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
108 Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
109 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
110-}
112evalROGraphOp :: SessionId -> Connection -> ROTransactionGraphOperator -> IO (Either RelationalError Relation)
113evalROGraphOp sessionId conn ShowGraph = transactionGraphAsRelation sessionId conn
115evalConvenienceGraphOp :: SessionId -> Connection -> ConvenienceTransactionGraphOperator -> IO (Either RelationalError ())
116evalConvenienceGraphOp sessionId conn (AutoMergeToHead strat head') = autoMergeToHead sessionId conn strat head'