git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/bin/TutorialD/Interpreter.hs
268 lines 12 kB history raw
1{-# LANGUAGE GADTs, LambdaCase #-}
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 System.Console.Haskeline
28import System.Directory (getHomeDirectory)
29import qualified Data.Text as T
30import System.IO (hPutStrLn, stderr)
31import Data.Monoid
32import Data.List (isPrefixOf)
33import Control.Exception
34import System.Exit
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 ParserError ParsedOperation
81parseTutorialD = parse interpreterParserP ""
83--only parse tutoriald which doesn't result in file I/O
84safeParseTutorialD :: T.Text -> Either ParserError ParsedOperation
85safeParseTutorialD = parse safeInterpreterParserP ""
87data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq)
89type InteractiveConsole = Bool
91evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO TutorialDOperatorResult
92evalTutorialD sessionId conn safe = evalTutorialDInteractive sessionId conn safe False
94--execute the operation and display result
95evalTutorialDInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> ParsedOperation -> IO TutorialDOperatorResult
96evalTutorialDInteractive sessionId conn safe interactive expr = case expr of
97 --this does not pass through the ProjectM36.Client library because the operations
98 --are specific to the interpreter, though some operations may be of general use in the future
99 (RODatabaseContextOp execOp) -> do
100 res <- evalRODatabaseContextOp sessionId conn execOp
101 case res of
102 QuitResult -> if safe == UnsafeEvaluation && interactive then
103 putStrLn "Goodbye." >> exitSuccess
104 else
105 pure res
106 _ -> pure res
108 (DatabaseContextExprOp execOp) ->
109 eHandler $ C.executeDatabaseContextExpr sessionId conn execOp
111 (DatabaseContextIOExprOp execOp) ->
112 if needsSafe then
113 unsafeError
114 else
115 eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp
117 (GraphOp execOp) -> do
118 -- warn if the graph op could cause uncommited changes to be discarded
119 eIsDirty <- C.disconnectedTransactionIsDirty sessionId conn
120 let runGraphOp = eHandler $ C.executeGraphExpr sessionId conn execOp
121 settings = Settings {complete = noCompletion,
122 historyFile = Nothing,
123 autoAddHistory = False}
124 case eIsDirty of
125 Left err -> barf err
126 Right False -> runGraphOp
127 Right True -> do
128 cancel <- runInputT settings $ do
129 let promptDiscardChanges = do
130 isatty <- haveTerminalUI
131 if isatty && interactive && execOp /= Commit && execOp /= Rollback then do
132 mYesOrNo <- getInputLine "The current transaction has uncommitted changes. If you continue, the changes will be lost. Continue? (Y/n): "
133 case mYesOrNo of
134 Nothing -> promptDiscardChanges
135 Just "" -> promptDiscardChanges
136 Just yesOrNo -> pure (not ("Y" `isPrefixOf` yesOrNo))
137 else
138 pure False
139 promptDiscardChanges
140 if cancel then
141 pure (DisplayErrorResult "Graph operation cancelled.")
142 else
143 runGraphOp
145 (ConvenienceGraphOp execOp) ->
146 eHandler $ evalConvenienceGraphOp sessionId conn execOp
148 (ROGraphOp execOp) -> do
149 opResult <- evalROGraphOp sessionId conn execOp
150 case opResult of
151 Left err -> barf err
152 Right rel -> pure (DisplayRelationResult rel)
154 (SchemaOp execOp) ->
155 eHandler $ evalSchemaOperator sessionId conn execOp
157 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) ->
158 if needsSafe then
159 unsafeError
160 else do
161 -- collect attributes from relvar name
162 -- is there a race condition here? The attributes of the relvar may have since changed, no?
163 eImportType <- C.typeForRelationalExpr sessionId conn (RelationVariable relVarName ())
164 case eImportType of
165 Left err -> barf err
166 Right importType -> do
167 eTConsMap <- C.typeConstructorMapping sessionId conn
168 case eTConsMap of
169 Left err -> barf err
170 Right tConsMap -> do
171 exprErr <- evalRelVarDataImportOperator execOp tConsMap (attributes importType)
172 case exprErr of
173 Left err -> barf err
174 Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr)
176 (ImportDBContextOp execOp) ->
177 if needsSafe then
178 unsafeError
179 else do
180 eErr <- evalDatabaseContextDataImportOperator execOp
181 case eErr of
182 Left err -> barf err
183 Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs)
185 (InfoOp execOp) ->
186 if needsSafe then
187 unsafeError
188 else
189 case evalInformationOperator execOp of
190 Left err -> pure (DisplayErrorResult err)
191 Right info -> pure (DisplayResult info)
193 (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) ->
194 --eval relexpr to relation and pass to export function
195 if needsSafe then
196 unsafeError
197 else do
198 eRel <- C.executeRelationalExpr sessionId conn relExpr
199 case eRel of
200 Left err -> barf err
201 Right rel -> do
202 exportResult <- evalRelVarDataExportOperator execOp rel
203 case exportResult of
204 Just err -> barf err
205 Nothing -> pure QuietSuccessResult
206 (ImportBasicExampleOp execOp) -> do
207 let dbcontextexpr = evalImportBasicExampleOperator execOp
208 evalTutorialD sessionId conn safe (DatabaseContextExprOp dbcontextexpr)
209 (TransGraphRelationalOp execOp) ->
210 evalTransGraphRelationalOp sessionId conn execOp
211 where
212 needsSafe = safe == SafeEvaluation
213 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."
214 barf :: RelationalError -> IO TutorialDOperatorResult
215 barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))
216 barf err = return $ DisplayErrorResult (T.pack (show err))
217 eHandler io = do
218 eErr <- io
219 case eErr of
220 Left err -> barf err
221 Right () -> return QuietSuccessResult
223type GhcPkgPath = String
224type TutorialDExec = String
225type CheckFS = Bool
227data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] CheckFS |
228 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS
230outputNotificationCallback :: C.NotificationCallback
231outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot
233prettyEvaluatedNotification :: C.EvaluatedNotification -> String
234prettyEvaluatedNotification eNotif = let eRelShow eRel = case eRel of
235 Left err -> show err
236 Right reportRel -> T.unpack (showRelation reportRel) in
237 eRelShow (C.reportOldRelation eNotif) <> "\n" <> eRelShow (C.reportNewRelation eNotif)
239reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO ()
240reprLoop config sessionId conn = do
241 homeDirectory <- getHomeDirectory
242 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
243 eHeadName <- C.headName sessionId conn
244 eSchemaName <- C.currentSchemaName sessionId conn
245 let prompt = promptText eHeadName eSchemaName
246 catchInterrupt = handleJust (\case
247 UserInterrupt -> Just Nothing
248 _ -> Nothing) (\_ -> do
249 hPutStrLn stderr "Statement cancelled. Use \":quit\" to exit tutd."
250 pure (Just ""))
251 maybeLine <- catchInterrupt $ runInputT settings $ getInputLine (T.unpack prompt)
252 case maybeLine of
253 Nothing -> return ()
254 Just line -> do
255 runTutorialD sessionId conn (Just (T.length prompt)) (T.pack line)
256 reprLoop config sessionId conn
259runTutorialD :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO ()
260runTutorialD sessionId conn mPromptLength tutd =
261 case parseTutorialD tutd of
262 Left err ->
263 displayOpResult $ DisplayParseErrorResult mPromptLength err
264 Right parsed ->
265 catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do
266 evald <- evalTutorialDInteractive sessionId conn UnsafeEvaluation True parsed
267 displayOpResult evald)
268 (\_ -> displayOpResult (DisplayErrorResult "Request timed out."))