git.iko.soy/project-m36
on 3a76afa help sign in
project-m36/TutorialD/Interpreter.hs
132 lines 5.3 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 ExportOp DataExportOperator
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 ExportOp (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 (ExportOp execOp) -> do
103 evalDataExportOperator execOp
104{- (DisconnectedTransaction _ context) <- disconnectedTransaction conn -- !
105 exprErr <- evalDataExportOperator execOp context
106 case exprErr of
107 Just err -> barf err
108 Nothing -> return QuietSuccessResult-}
110 where
111 barf err = return $ DisplayErrorResult (T.pack (show err))
113data InterpreterConfig = InterpreterConfig {
114 persistenceStrategy :: PersistenceStrategy
115 }
117reprLoop :: InterpreterConfig -> C.Connection -> IO ()
118reprLoop config conn = do
119 homeDirectory <- getHomeDirectory
120 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
121 mHeadName <- C.headName conn
122 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText mHeadName))
123 case maybeLine of
124 Nothing -> return ()
125 Just line -> do
126 case parseTutorialD line of
127 Left err -> do
128 displayOpResult $ DisplayErrorResult (T.pack (show err))
129 Right parsed -> do
130 evald <- evalTutorialD conn parsed
131 displayOpResult evald
132 reprLoop config conn