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