git.iko.soy/project-m36
on add5922 help sign in
project-m36/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs
111 lines 4.0 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 branch <- identifier
65 pure (SelectedBranchMergeStrategy branch)) <|>
66 (do
67 reserved "unionpreferbranch"
68 branch <- identifier
69 pure (UnionPreferMergeStrategy branch))
71mergeTransactionsP :: Parser TransactionGraphOperator
72mergeTransactionsP = do
73 reservedOp ":mergetrans"
74 strategy <- mergeTransactionStrategyP
75 headA <- identifier
76 headB <- identifier
77 pure (MergeTransactions strategy headA headB)
79transactionGraphOpP :: Parser TransactionGraphOperator
80transactionGraphOpP =
81 jumpToHeadP
82 <|> jumpToTransactionP
83 <|> walkBackToTimeP
84 <|> branchTransactionP
85 <|> deleteBranchP
86 <|> commitTransactionP
87 <|> rollbackTransactionP
88 <|> mergeTransactionsP
90roTransactionGraphOpP :: Parser ROTransactionGraphOperator
91roTransactionGraphOpP = showGraphP
95{-
96-- for interpreter-specific operations
97interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
98interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
99 Left _ -> (trans, transGraph, NoActionResult)
100 Right ops -> case ops of
101 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
102 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
103 Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
104 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
105-}
107evalROGraphOp :: SessionId -> Connection -> ROTransactionGraphOperator -> IO (Either RelationalError Relation)
108evalROGraphOp sessionId conn ShowGraph = transactionGraphAsRelation sessionId conn
110evalConvenienceGraphOp :: SessionId -> Connection -> ConvenienceTransactionGraphOperator -> IO (Either RelationalError ())
111evalConvenienceGraphOp sessionId conn (AutoMergeToHead strat head') = autoMergeToHead sessionId conn strat head'