git.iko.soy/project-m36
on b2fbc13 help sign in
project-m36/TutorialD/Interpreter.hs
125 lines 5.0 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 ProjectM36.Client
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 Control.Applicative ((<*))
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 ImportOp DataImportOperator |
37 ExportOp DataExportOperator
39interpreterParserP :: Parser ParsedOperation
40interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
41 liftM GraphOp (transactionGraphOpP <* eof) <|>
42 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>
43 liftM DatabaseExprOp (databaseExprOpP <* eof) <|>
44 liftM ImportOp ((importCSVP <|> tutdImportP) <* eof) <|>
45 liftM ExportOp (exportCSVP <* eof)
47promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
48promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
49 where
50 transInfo = case transactionForUUID parentUUID graph of
51 Left _ -> "unknown"
52 Right parentTrans -> case headNameForTransaction parentTrans graph of
53 Nothing -> T.pack (show $ transactionUUID parentTrans)
54 Just headName -> headName
56parseTutorialD :: Connection -> String -> Either ParseError ParsedOperation
57parseTutorialD (InProcessConnection _ _) inputString = parse interpreterParserP "" inputString
59--execute the operation and display result
60evalTutorialD :: 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 (DisconnectedTransaction _ context) <- disconnectedTransaction conn
67 return $ evalRODatabaseContextOp context execOp
69 (DatabaseExprOp execOp) -> do
70 maybeErr <- executeDatabaseContextExpr conn execOp
71 case maybeErr of
72 Just err -> barf err
73 Nothing -> return QuietSuccessResult
75 (GraphOp execOp) -> do
76 maybeErr <- executeGraphExpr conn execOp
77 case maybeErr of
78 Just err -> barf err
79 Nothing -> return QuietSuccessResult
81 (ROGraphOp execOp) -> do
82 discon <- disconnectedTransaction conn
83 graph <- transactionGraph conn
84 case evalROGraphOp discon graph execOp of
85 Left err -> barf err
86 Right rel -> return $ DisplayResult $ showRelation rel
88 (ImportOp execOp) -> do
89 (DisconnectedTransaction _ context) <- disconnectedTransaction conn
90 exprErr <- evalDataImportOperator execOp context
91 case exprErr of
92 Left err -> barf err
93 Right dbexpr -> evalTutorialD conn (DatabaseExprOp dbexpr)
95 (ExportOp execOp) -> do
96 (DisconnectedTransaction _ context) <- disconnectedTransaction conn
97 exprErr <- evalDataExportOperator execOp context
98 case exprErr of
99 Just err -> barf err
100 Nothing -> return QuietSuccessResult
102 where
103 barf err = return $ DisplayErrorResult (T.pack (show err))
105data InterpreterConfig = InterpreterConfig {
106 persistenceStrategy :: PersistenceStrategy
107 }
109reprLoop :: InterpreterConfig -> Connection -> IO ()
110reprLoop config conn = do
111 homeDirectory <- getHomeDirectory
112 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
113 discon <- disconnectedTransaction conn
114 graph <- transactionGraph conn
115 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText discon graph))
116 case maybeLine of
117 Nothing -> return ()
118 Just line -> do
119 case parseTutorialD conn line of
120 Left err -> do
121 displayOpResult $ DisplayErrorResult (T.pack (show err))
122 Right parsed -> do
123 evald <- evalTutorialD conn parsed
124 displayOpResult evald
125 reprLoop config conn