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