git.iko.soy/project-m36
on fd05d50 help sign in
project-m36/src/bin/TutorialD/Interpreter.hs
214 lines 9.6 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
10import TutorialD.Interpreter.SchemaOperator
12import TutorialD.Interpreter.Import.CSV
13import TutorialD.Interpreter.Import.TutorialD
14import TutorialD.Interpreter.Import.BasicExamples
15import TutorialD.Interpreter.Import.Base
17import TutorialD.Interpreter.Export.CSV
18import TutorialD.Interpreter.Export.Base
20import ProjectM36.Base
21import ProjectM36.Error
22import ProjectM36.Relation.Show.Term
23import ProjectM36.TransactionGraph
24import qualified ProjectM36.Client as C
25import ProjectM36.Relation (attributes)
27import Text.Megaparsec
28import Text.Megaparsec.Text
29import System.Console.Haskeline
30import System.Directory (getHomeDirectory)
31import qualified Data.Text as T
32import System.IO (hPutStrLn, stderr)
33import Data.Monoid
34import Control.Exception
36{-
37context ops are read-only operations which only operate on the database context (relvars and constraints)
38database ops are read-write operations which change the database context (such as relvar assignment)
39graph ops are read-write operations which change the transaction graph
40-}
41data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
42 DatabaseContextExprOp DatabaseContextExpr |
43 DatabaseContextIOExprOp DatabaseContextIOExpr |
44 InfoOp InformationOperator |
45 GraphOp TransactionGraphOperator |
46 ConvenienceGraphOp ConvenienceTransactionGraphOperator |
47 ROGraphOp ROTransactionGraphOperator |
48 ImportRelVarOp RelVarDataImportOperator |
49 ImportDBContextOp DatabaseContextDataImportOperator |
50 ImportBasicExampleOp ImportBasicExampleOperator |
51 RelVarExportOp RelVarDataExportOperator |
52 TransGraphRelationalOp TransGraphRelationalOperator |
53 SchemaOp SchemaOperator
54 deriving (Show)
56interpreterParserP :: Parser ParsedOperation
57interpreterParserP = safeInterpreterParserP <|>
58 fmap ImportRelVarOp (importCSVP <* eof) <|>
59 fmap ImportDBContextOp (tutdImportP <* eof) <|>
60 fmap RelVarExportOp (exportCSVP <* eof) <|>
61 fmap DatabaseContextIOExprOp (dbContextIOExprP <* eof)
63-- the safe interpreter never reads or writes the file system
64safeInterpreterParserP :: Parser ParsedOperation
65safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
66 fmap InfoOp (infoOpP <* eof) <|>
67 fmap GraphOp (transactionGraphOpP <* eof) <|>
68 fmap ConvenienceGraphOp (convenienceTransactionGraphOpP <* eof) <|>
69 fmap ROGraphOp (roTransactionGraphOpP <* eof) <|>
70 fmap DatabaseContextExprOp (databaseExprOpP <* eof) <|>
71 fmap ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>
72 fmap TransGraphRelationalOp (transGraphRelationalOpP <* eof) <|>
73 fmap SchemaOp (schemaOperatorP <* eof)
75promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType
76promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): "
77 where
78 transInfo = either (const "<unknown>") id eHeadName <> "/" <> either (const "<no schema>") id eSchemaName
80parseTutorialD :: T.Text -> Either (ParseError Char Dec) ParsedOperation
81parseTutorialD = parse interpreterParserP ""
83--only parse tutoriald which doesn't result in file I/O
84safeParseTutorialD :: T.Text -> Either (ParseError Char Dec) ParsedOperation
85safeParseTutorialD = parse safeInterpreterParserP ""
87data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq)
89--execute the operation and display result
90evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO TutorialDOperatorResult
91evalTutorialD sessionId conn safe expr = case expr of
92 --this does not pass through the ProjectM36.Client library because the operations
93 --are specific to the interpreter, though some operations may be of general use in the future
94 (RODatabaseContextOp execOp) ->
95 evalRODatabaseContextOp sessionId conn execOp
97 (DatabaseContextExprOp execOp) ->
98 eHandler $ C.executeDatabaseContextExpr sessionId conn execOp
100 (DatabaseContextIOExprOp execOp) ->
101 if needsSafe then
102 unsafeError
103 else
104 eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp
106 (GraphOp execOp) ->
107 eHandler $ C.executeGraphExpr sessionId conn execOp
109 (ConvenienceGraphOp execOp) ->
110 eHandler $ evalConvenienceGraphOp sessionId conn execOp
112 (ROGraphOp execOp) -> do
113 opResult <- evalROGraphOp sessionId conn execOp
114 case opResult of
115 Left err -> barf err
116 Right rel -> pure (DisplayRelationResult rel)
118 (SchemaOp execOp) ->
119 eHandler $ evalSchemaOperator sessionId conn execOp
121 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) ->
122 if needsSafe then
123 unsafeError
124 else do
125 -- collect attributes from relvar name
126 -- is there a race condition here? The attributes of the relvar may have since changed, no?
127 eImportType <- C.typeForRelationalExpr sessionId conn (RelationVariable relVarName ())
128 case eImportType of
129 Left err -> barf err
130 Right importType -> do
131 exprErr <- evalRelVarDataImportOperator execOp (attributes importType)
132 case exprErr of
133 Left err -> barf err
134 Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr)
136 (ImportDBContextOp execOp) ->
137 if needsSafe then
138 unsafeError
139 else do
140 eErr <- evalDatabaseContextDataImportOperator execOp
141 case eErr of
142 Left err -> barf err
143 Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs)
145 (InfoOp execOp) ->
146 if needsSafe then
147 unsafeError
148 else
149 case evalInformationOperator execOp of
150 Left err -> pure (DisplayErrorResult err)
151 Right info -> pure (DisplayResult info)
153 (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) ->
154 --eval relexpr to relation and pass to export function
155 if needsSafe then
156 unsafeError
157 else do
158 eRel <- C.executeRelationalExpr sessionId conn relExpr
159 case eRel of
160 Left err -> barf err
161 Right rel -> do
162 exportResult <- evalRelVarDataExportOperator execOp rel
163 case exportResult of
164 Just err -> barf err
165 Nothing -> pure QuietSuccessResult
166 (ImportBasicExampleOp execOp) -> do
167 let dbcontextexpr = evalImportBasicExampleOperator execOp
168 evalTutorialD sessionId conn safe (DatabaseContextExprOp dbcontextexpr)
169 (TransGraphRelationalOp execOp) ->
170 evalTransGraphRelationalOp sessionId conn execOp
171 where
172 needsSafe = safe == SafeEvaluation
173 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."
174 barf :: RelationalError -> IO TutorialDOperatorResult
175 barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))
176 barf err = return $ DisplayErrorResult (T.pack (show err))
177 eHandler io = do
178 eErr <- io
179 case eErr of
180 Left err -> barf err
181 Right () -> return QuietSuccessResult
183type GhcPkgPath = String
184data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] |
185 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName
187outputNotificationCallback :: C.NotificationCallback
188outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ show (reportExpr (C.notification evaldNot)) ++ "\n" ++ prettyEvaluatedNotification evaldNot
190prettyEvaluatedNotification :: C.EvaluatedNotification -> String
191prettyEvaluatedNotification eNotif = case C.reportRelation eNotif of
192 Left err -> show err
193 Right reportRel -> T.unpack (showRelation reportRel)
195reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO ()
196reprLoop config sessionId conn = do
197 homeDirectory <- getHomeDirectory
198 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
199 eHeadName <- C.headName sessionId conn
200 eSchemaName <- C.currentSchemaName sessionId conn
201 let prompt = promptText eHeadName eSchemaName
202 maybeLine <- runInputT settings $ getInputLine (T.unpack prompt)
203 case maybeLine of
204 Nothing -> return ()
205 Just line -> do
206 case parseTutorialD (T.pack line) of
207 Left err ->
208 displayOpResult $ DisplayParseErrorResult (T.length prompt) err
209 Right parsed ->
210 catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do
211 evald <- evalTutorialD sessionId conn UnsafeEvaluation parsed
212 displayOpResult evald)
213 (\_ -> displayOpResult (DisplayErrorResult "Request timed out."))
214 reprLoop config sessionId conn