git.iko.soy/project-m36
on 802f2ce help sign in
project-m36/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs
50 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 qualified ProjectM36.Client as C
8import TutorialD.Interpreter.Base
9import TutorialD.Interpreter.RelationalExpr
11import Text.Megaparsec
12import Text.Megaparsec.Text
14import qualified Data.Text as T
16instance RelationalMarkerExpr TransactionIdLookup where
17 parseMarkerP = string "@" *> transactionIdLookupP
19newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr
20 deriving Show
22transactionIdLookupP :: Parser TransactionIdLookup
23transactionIdLookupP = (TransactionIdLookup <$> uuidP) <|>
24 (TransactionIdHeadNameLookup <$> identifier <*> many transactionIdHeadBacktrackP)
26transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack
27transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <$> backtrackP)) <|>
28 (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP)) <|>
29 (string "@" *> (TransactionStampHeadBacktrack <$> utcTimeP))
31backtrackP :: Parser Int
32backtrackP = do
33 steps <- integer <|> pure 1
34 pure (fromIntegral steps)
36transGraphRelationalOpP :: Parser TransGraphRelationalOperator
37transGraphRelationalOpP = showTransGraphRelationalOpP
39showTransGraphRelationalOpP :: Parser TransGraphRelationalOperator
40showTransGraphRelationalOpP = do
41 reservedOp ":showtransgraphexpr"
42 ShowTransGraphRelation <$> relExprP
44evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO TutorialDOperatorResult
45evalTransGraphRelationalOp sessionId conn (ShowTransGraphRelation expr) = do
46 res <- C.executeTransGraphRelationalExpr sessionId conn expr
47 case res of
48 Left err -> pure $ DisplayErrorResult $ T.pack (show err)
49 Right rel -> pure $ DisplayRelationResult rel