git.iko.soy/project-m36
on 46b4509 help sign in
project-m36/TutorialD/Interpreter.hs
133 lines 5.5 kB history raw
1{-# LANGUAGE GADTs,OverloadedStrings #-}
2module TutorialD.Interpreter where
3import TutorialD.Interpreter.Base
4import TutorialD.Interpreter.RODatabaseContextOperator
5import TutorialD.Interpreter.DatabaseExpr
6import TutorialD.Interpreter.TransactionGraphOperator
8import TutorialD.Interpreter.Import.CSV
9import TutorialD.Interpreter.Import.TutorialD
10import TutorialD.Interpreter.Import.Base
12import TutorialD.Interpreter.Export.CSV
13import TutorialD.Interpreter.Export.Base
15import ProjectM36.Base
16import ProjectM36.Relation.Show.Term
17import ProjectM36.TransactionGraph
18import qualified ProjectM36.Client as C
19import Text.Parsec
20import Text.Parsec.String
21import Control.Monad.State
22import System.Console.Haskeline
23import System.Directory (getHomeDirectory)
24import qualified Data.Text as T
25import Data.Maybe (fromMaybe)
27{-
28context ops are read-only operations which only operate on the database context (relvars and constraints)
29database ops are read-write operations which change the database context (such as relvar assignment)
30graph ops are read-write operations which change the transaction graph
31-}
32data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
33 DatabaseExprOp DatabaseExpr |
34 GraphOp TransactionGraphOperator |
35 ROGraphOp ROTransactionGraphOperator |
36 ImportRelVarOp RelVarDataImportOperator |
37 ImportDBContextOp DatabaseContextDataImportOperator |
38 RelVarExportOp RelVarDataExportOperator
40interpreterParserP :: Parser ParsedOperation
41interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
42 liftM GraphOp (transactionGraphOpP <* eof) <|>
43 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>
44 liftM DatabaseExprOp (databaseExprOpP <* eof) <|>
45 liftM ImportRelVarOp (importCSVP <* eof) <|>
46 liftM ImportDBContextOp (tutdImportP <* eof) <|>
47 liftM RelVarExportOp (exportCSVP <* eof)
49promptText :: Maybe HeadName -> StringType
50promptText mHeadName = "TutorialD (" `T.append` transInfo `T.append` "): "
51 where
52 transInfo = fromMaybe "<unknown>" mHeadName
54parseTutorialD :: String -> Either ParseError ParsedOperation
55parseTutorialD inputString = parse interpreterParserP "" inputString
57--execute the operation and display result
58evalTutorialD :: C.Connection -> ParsedOperation -> IO (TutorialDOperatorResult)
59evalTutorialD conn expr = case expr of
61 --this does not pass through the ProjectM36.Client library because the operations
62 --are specific to the interpreter, though some operations may be of general use in the future
63 (RODatabaseContextOp execOp) -> do
64 evalRODatabaseContextOp conn execOp
66 (DatabaseExprOp execOp) -> do
67 maybeErr <- C.executeDatabaseContextExpr conn execOp
68 case maybeErr of
69 Just err -> barf err
70 Nothing -> return QuietSuccessResult
72 (GraphOp execOp) -> do
73 maybeErr <- C.executeGraphExpr conn execOp
74 case maybeErr of
75 Just err -> barf err
76 Nothing -> return QuietSuccessResult
78 (ROGraphOp execOp) -> do
79 opResult <- evalROGraphOp conn execOp
80 case opResult of
81 Left err -> barf err
82 Right rel -> return $ DisplayResult $ showRelation rel
84 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do
85 -- collect attributes from relvar name
86 -- is there a race condition here? The attributes of the relvar may have since changed, no?
87 eImportAttributes <- C.attributesForRelationalExpr conn (RelationVariable relVarName)
88 case eImportAttributes of
89 Left err -> barf err
90 Right importAttributes -> do
91 exprErr <- evalRelVarDataImportOperator execOp importAttributes
92 case exprErr of
93 Left err -> barf err
94 Right dbexpr -> evalTutorialD conn (DatabaseExprOp dbexpr)
96 (ImportDBContextOp execOp) -> do
97 mDbexprs <- evalDatabaseContextDataImportOperator execOp
98 case mDbexprs of
99 Left err -> barf err
100 Right dbexprs -> evalTutorialD conn (DatabaseExprOp dbexprs)
102 (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) -> do
103 --eval relexpr to relation and pass to export function
104 eRel <- C.executeRelationalExpr conn relExpr
105 case eRel of
106 Left err -> barf err
107 Right rel -> do
108 exportResult <- evalRelVarDataExportOperator execOp rel
109 case exportResult of
110 Just err -> barf err
111 Nothing -> pure QuietSuccessResult
112 where
113 barf err = return $ DisplayErrorResult (T.pack (show err))
115data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy |
116 RemoteInterpreterConfig C.NodeId C.DatabaseName
118reprLoop :: InterpreterConfig -> C.Connection -> IO ()
119reprLoop config conn = do
120 homeDirectory <- getHomeDirectory
121 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
122 mHeadName <- C.headName conn
123 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText mHeadName))
124 case maybeLine of
125 Nothing -> return ()
126 Just line -> do
127 case parseTutorialD line of
128 Left err -> do
129 displayOpResult $ DisplayErrorResult (T.pack (show err))
130 Right parsed -> do
131 evald <- evalTutorialD conn parsed
132 displayOpResult evald
133 reprLoop config conn