git.iko.soy/project-m36
on d4fbf56 help sign in
project-m36/TutorialD/Interpreter/TransactionGraphOperator.hs
72 lines 2.3 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialD.Interpreter.TransactionGraphOperator where
3import TutorialD.Interpreter.Base
4import Text.Parsec
5import Text.Parsec.String
6import qualified Data.UUID as U
7import qualified Data.Text as T
8import ProjectM36.TransactionGraph
10jumpToHeadP :: Parser TransactionGraphOperator
11jumpToHeadP = do
12 reservedOp ":jumphead"
13 headid <- identifier
14 return $ JumpToHead (T.pack headid)
16jumpToTransactionP :: Parser TransactionGraphOperator
17jumpToTransactionP = do
18 reservedOp ":jump"
19 uuid <- uuidP
20 return $ JumpToTransaction uuid
22branchTransactionP :: Parser TransactionGraphOperator
23branchTransactionP = do
24 reservedOp ":branch"
25 branchName <- identifier
26 return $ Branch (T.pack branchName)
28commitTransactionP :: Parser TransactionGraphOperator
29commitTransactionP = do
30 reservedOp ":commit"
31 return $ Commit
33rollbackTransactionP :: Parser TransactionGraphOperator
34rollbackTransactionP = do
35 reservedOp ":rollback"
36 return $ Rollback
38showGraphP :: Parser ROTransactionGraphOperator
39showGraphP = do
40 reservedOp ":showgraph"
41 return $ ShowGraph
43transactionGraphOpP :: Parser TransactionGraphOperator
44transactionGraphOpP = do
45 jumpToHeadP
46 <|> jumpToTransactionP
47 <|> branchTransactionP
48 <|> commitTransactionP
49 <|> rollbackTransactionP
51roTransactionGraphOpP :: Parser ROTransactionGraphOperator
52roTransactionGraphOpP = showGraphP
54uuidP :: Parser U.UUID
55uuidP = do
56 uuidStr <- many (alphaNum <|> char '-')
57 case U.fromString uuidStr of
58 Nothing -> fail "Invalid uuid string"
59 Just uuid -> return uuid
62{-
63-- for interpreter-specific operations
64interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
65interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
66 Left _ -> (trans, transGraph, NoActionResult)
67 Right ops -> case ops of
68 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
69 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
70 Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
71 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
72-}