git.iko.soy/project-m36
on 8b7e4e4 help sign in
project-m36/src/bin/TutorialD/Interpreter.hs
202 lines 8.7 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialD.Interpreter where
3import TutorialD.Interpreter.Base
4import TutorialD.Interpreter.RODatabaseContextOperator
5import TutorialD.Interpreter.DatabaseContextExpr
6import TutorialD.Interpreter.TransactionGraphOperator
7import TutorialD.Interpreter.InformationOperator
8import TutorialD.Interpreter.DatabaseContextIOOperator
9import TutorialD.Interpreter.TransGraphRelationalOperator
11import TutorialD.Interpreter.Import.CSV
12import TutorialD.Interpreter.Import.TutorialD
13import TutorialD.Interpreter.Import.BasicExamples
14import TutorialD.Interpreter.Import.Base
16import TutorialD.Interpreter.Export.CSV
17import TutorialD.Interpreter.Export.Base
19import ProjectM36.Base
20import ProjectM36.Relation.Show.Term
21import ProjectM36.TransactionGraph
22import qualified ProjectM36.Client as C
23import ProjectM36.Relation (attributes)
25import Text.Megaparsec
26import Text.Megaparsec.Text
27import Control.Monad.State
28import System.Console.Haskeline
29import System.Directory (getHomeDirectory)
30import qualified Data.Text as T
31import Data.Maybe (fromMaybe)
32import System.IO (hPutStrLn, stderr)
34{-
35context ops are read-only operations which only operate on the database context (relvars and constraints)
36database ops are read-write operations which change the database context (such as relvar assignment)
37graph ops are read-write operations which change the transaction graph
38-}
39data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
40 DatabaseContextExprOp DatabaseContextExpr |
41 DatabaseContextIOExprOp DatabaseContextIOExpr |
42 InfoOp InformationOperator |
43 GraphOp TransactionGraphOperator |
44 ROGraphOp ROTransactionGraphOperator |
45 ImportRelVarOp RelVarDataImportOperator |
46 ImportDBContextOp DatabaseContextDataImportOperator |
47 ImportBasicExampleOp ImportBasicExampleOperator |
48 RelVarExportOp RelVarDataExportOperator |
49 TransGraphRelationalOp TransGraphRelationalOperator
51interpreterParserP :: Parser ParsedOperation
52interpreterParserP = safeInterpreterParserP <|>
53 liftM ImportRelVarOp (importCSVP <* eof) <|>
54 liftM ImportDBContextOp (tutdImportP <* eof) <|>
55 liftM RelVarExportOp (exportCSVP <* eof) <|>
56 liftM DatabaseContextIOExprOp (addAtomFunctionExprP <* eof)
58-- the safe interpreter never reads or writes the file system
59safeInterpreterParserP :: Parser ParsedOperation
60safeInterpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
61 liftM InfoOp (infoOpP <* eof) <|>
62 liftM GraphOp (transactionGraphOpP <* eof) <|>
63 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>
64 liftM DatabaseContextExprOp (databaseExprOpP <* eof) <|>
65 liftM ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>
66 liftM TransGraphRelationalOp (transGraphRelationalOpP <* eof)
69promptText :: Maybe HeadName -> StringType
70promptText mHeadName = "TutorialD (" `T.append` transInfo `T.append` "): "
71 where
72 transInfo = fromMaybe "<unknown>" mHeadName
74parseTutorialD :: T.Text -> Either ParseError ParsedOperation
75parseTutorialD inputString = parse interpreterParserP "" inputString
77--only parse tutoriald which doesn't result in file I/O
78safeParseTutorialD :: T.Text -> Either ParseError ParsedOperation
79safeParseTutorialD inputString = parse safeInterpreterParserP "" inputString
81data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq)
83--execute the operation and display result
84evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO (TutorialDOperatorResult)
85evalTutorialD sessionId conn safe expr = case expr of
87 --this does not pass through the ProjectM36.Client library because the operations
88 --are specific to the interpreter, though some operations may be of general use in the future
89 (RODatabaseContextOp execOp) -> do
90 evalRODatabaseContextOp sessionId conn execOp
92 (DatabaseContextExprOp execOp) -> do
93 maybeErr <- C.executeDatabaseContextExpr sessionId conn execOp
94 case maybeErr of
95 Just err -> barf err
96 Nothing -> return QuietSuccessResult
98 (DatabaseContextIOExprOp execOp) -> do
99 if needsSafe then
100 unsafeError
101 else do
102 mErr <- C.executeDatabaseContextIOExpr sessionId conn execOp
103 case mErr of
104 Just err -> barf err
105 Nothing -> pure QuietSuccessResult
107 (GraphOp execOp) -> do
108 maybeErr <- C.executeGraphExpr sessionId conn execOp
109 case maybeErr of
110 Just err -> barf err
111 Nothing -> return QuietSuccessResult
113 (ROGraphOp execOp) -> do
114 opResult <- evalROGraphOp sessionId conn execOp
115 case opResult of
116 Left err -> barf err
117 Right rel -> pure (DisplayRelationResult rel)
119 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do
120 if needsSafe then
121 unsafeError
122 else do
123 -- collect attributes from relvar name
124 -- is there a race condition here? The attributes of the relvar may have since changed, no?
125 eImportType <- C.typeForRelationalExpr sessionId conn (RelationVariable relVarName ())
126 case eImportType of
127 Left err -> barf err
128 Right importType -> do
129 exprErr <- evalRelVarDataImportOperator execOp (attributes importType)
130 case exprErr of
131 Left err -> barf err
132 Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr)
134 (ImportDBContextOp execOp) -> do
135 if needsSafe then
136 unsafeError
137 else do
138 mDbexprs <- evalDatabaseContextDataImportOperator execOp
139 case mDbexprs of
140 Left err -> barf err
141 Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs)
143 (InfoOp execOp) -> do
144 if needsSafe then
145 unsafeError
146 else
147 case evalInformationOperator execOp of
148 Left err -> barf err
149 Right info -> pure (DisplayResult info)
151 (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) -> do
152 --eval relexpr to relation and pass to export function
153 if needsSafe then
154 unsafeError
155 else do
156 eRel <- C.executeRelationalExpr sessionId conn relExpr
157 case eRel of
158 Left err -> barf err
159 Right rel -> do
160 exportResult <- evalRelVarDataExportOperator execOp rel
161 case exportResult of
162 Just err -> barf err
163 Nothing -> pure QuietSuccessResult
164 (ImportBasicExampleOp execOp) -> do
165 let dbcontextexpr = evalImportBasicExampleOperator execOp
166 evalTutorialD sessionId conn safe (DatabaseContextExprOp dbcontextexpr)
167 (TransGraphRelationalOp execOp) -> do
168 evalTransGraphRelationalOp sessionId conn execOp
169 where
170 needsSafe = safe == SafeEvaluation
171 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."
172 barf err = return $ DisplayErrorResult (T.pack (show err))
174type GhcPkgPath = String
175data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] |
176 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName
178outputNotificationCallback :: C.NotificationCallback
179outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ show (reportExpr (C.notification evaldNot)) ++ "\n" ++ prettyEvaluatedNotification evaldNot
181prettyEvaluatedNotification :: C.EvaluatedNotification -> String
182prettyEvaluatedNotification eNotif = case C.reportRelation eNotif of
183 Left err -> show err
184 Right reportRel -> T.unpack (showRelation reportRel)
186reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO ()
187reprLoop config sessionId conn = do
188 homeDirectory <- getHomeDirectory
189 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
190 mHeadName <- C.headName sessionId conn
191 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText mHeadName))
192 case maybeLine of
193 Nothing -> return ()
194 Just line -> do
195 case parseTutorialD (T.pack line) of
196 Left err -> do
197 let strErr = show err --parseErrorPretty new in megaparsec 5
198 displayOpResult $ DisplayErrorResult (T.pack strErr)
199 Right parsed -> do
200 evald <- evalTutorialD sessionId conn UnsafeEvaluation parsed
201 displayOpResult evald
202 reprLoop config sessionId conn