TransGraphRelationalOperator.hs

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TutorialD.Interpreter.TransGraphRelationalOperator where
import ProjectM36.TransGraphRelationalExpression
import ProjectM36.TransactionGraph
import qualified ProjectM36.Client as C

import TutorialD.Interpreter.Base
import TutorialD.Interpreter.RelationalExpr

import Text.Megaparsec
import Text.Megaparsec.Text

import qualified Data.Text as T

instance RelationalMarkerExpr TransactionIdLookup where
  parseMarkerP = string "@" *> transactionIdLookupP
    
data TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr
                                  deriving Show

transactionIdLookupP :: Parser TransactionIdLookup
transactionIdLookupP =  (TransactionIdLookup <$> uuidP) <|>
                        (TransactionIdHeadNameLookup <$> identifier <*> many transactionIdHeadBacktrackP)
                        
transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack                        
transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <$> backtrackP)) <|>
                              (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP))
                              
backtrackP :: Parser Int
backtrackP = do
  steps <- integer <|> pure 1
  pure (fromIntegral steps)
  
transGraphRelationalOpP :: Parser TransGraphRelationalOperator                     
transGraphRelationalOpP = showTransGraphRelationalOpP
  
showTransGraphRelationalOpP :: Parser TransGraphRelationalOperator
showTransGraphRelationalOpP = do
  reservedOp ":showtransgraphexpr"
  ShowTransGraphRelation <$> relExprP  
  
evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO TutorialDOperatorResult
evalTransGraphRelationalOp sessionId conn (ShowTransGraphRelation expr) = do
  res <- C.executeTransGraphRelationalExpr sessionId conn expr
  case res of
    Left err -> pure $ DisplayErrorResult $ T.pack (show err)
    Right rel -> pure $ DisplayRelationResult rel