git.iko.soy/project-m36
on 2d313ac help sign in
project-m36/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs
49 lines 2.2 kB history raw
1{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module TutorialD.Interpreter.TransGraphRelationalOperator where
4import ProjectM36.TransGraphRelationalExpression
5import ProjectM36.TransactionGraph
6import TutorialD.Interpreter.Types
7import qualified ProjectM36.Client as C
9import TutorialD.Interpreter.Base
10import TutorialD.Interpreter.RelationalExpr
12import Text.Megaparsec
13import Text.Megaparsec.Text
15import qualified Data.Text as T
17instance RelationalMarkerExpr TransactionIdLookup where
18 parseMarkerP = string "@" *> transactionIdLookupP
20newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr
21 deriving Show
23transactionIdLookupP :: Parser TransactionIdLookup
24transactionIdLookupP = (TransactionIdLookup <$> uuidP) <|>
25 (TransactionIdHeadNameLookup <$> identifier <*> many transactionIdHeadBacktrackP)
27transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack
28transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <$> backtrackP)) <|>
29 (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP)) <|>
30 (string "@" *> (TransactionStampHeadBacktrack <$> utcTimeP))
32backtrackP :: Parser Int
33backtrackP = fromIntegral <$> integer <|> pure 1
35transGraphRelationalOpP :: Parser TransGraphRelationalOperator
36transGraphRelationalOpP = showTransGraphRelationalOpP
38showTransGraphRelationalOpP :: Parser TransGraphRelationalOperator
39showTransGraphRelationalOpP = do
40 reservedOp ":showtransgraphexpr"
41 ShowTransGraphRelation <$> relExprP
43evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO TutorialDOperatorResult
44evalTransGraphRelationalOp sessionId conn (ShowTransGraphRelation expr) = do
45 res <- C.executeTransGraphRelationalExpr sessionId conn expr
46 case res of
47 Left err -> pure $ DisplayErrorResult $ T.pack (show err)
48 Right rel -> pure $ DisplayRelationResult rel