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