git.iko.soy/project-m36
on 2fbb67a help sign in
project-m36/src/bin/TutorialD/Interpreter.hs
270 lines 12 kB history raw
1{-# LANGUAGE GADTs, LambdaCase, CPP #-}
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)
31#if __GLASGOW_HASKELL__ <= 802
32import Data.Monoid
33#endif
34import Data.List (isPrefixOf)
35import Control.Exception
36import System.Exit
38{-
39context ops are read-only operations which only operate on the database context (relvars and constraints)
40database ops are read-write operations which change the database context (such as relvar assignment)
41graph ops are read-write operations which change the transaction graph
42-}
43data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
44 DatabaseContextExprOp DatabaseContextExpr |
45 DatabaseContextIOExprOp DatabaseContextIOExpr |
46 InfoOp InformationOperator |
47 GraphOp TransactionGraphOperator |
48 ConvenienceGraphOp ConvenienceTransactionGraphOperator |
49 ROGraphOp ROTransactionGraphOperator |
50 ImportRelVarOp RelVarDataImportOperator |
51 ImportDBContextOp DatabaseContextDataImportOperator |
52 ImportBasicExampleOp ImportBasicExampleOperator |
53 RelVarExportOp RelVarDataExportOperator |
54 TransGraphRelationalOp TransGraphRelationalOperator |
55 SchemaOp SchemaOperator
56 deriving (Show)
58interpreterParserP :: Parser ParsedOperation
59interpreterParserP = safeInterpreterParserP <|>
60 fmap ImportRelVarOp (importCSVP <* eof) <|>
61 fmap ImportDBContextOp (tutdImportP <* eof) <|>
62 fmap RelVarExportOp (exportCSVP <* eof) <|>
63 fmap DatabaseContextIOExprOp (dbContextIOExprP <* eof)
65-- the safe interpreter never reads or writes the file system
66safeInterpreterParserP :: Parser ParsedOperation
67safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
68 fmap InfoOp (infoOpP <* eof) <|>
69 fmap GraphOp (transactionGraphOpP <* eof) <|>
70 fmap ConvenienceGraphOp (convenienceTransactionGraphOpP <* eof) <|>
71 fmap ROGraphOp (roTransactionGraphOpP <* eof) <|>
72 fmap DatabaseContextExprOp (databaseExprOpP <* eof) <|>
73 fmap ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>
74 fmap TransGraphRelationalOp (transGraphRelationalOpP <* eof) <|>
75 fmap SchemaOp (schemaOperatorP <* eof)
77promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType
78promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): "
79 where
80 transInfo = either (const "<unknown>") id eHeadName <> "/" <> either (const "<no schema>") id eSchemaName
82parseTutorialD :: T.Text -> Either ParserError ParsedOperation
83parseTutorialD = parse interpreterParserP ""
85--only parse tutoriald which doesn't result in file I/O
86safeParseTutorialD :: T.Text -> Either ParserError ParsedOperation
87safeParseTutorialD = parse safeInterpreterParserP ""
89data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq)
91type InteractiveConsole = Bool
93evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO TutorialDOperatorResult
94evalTutorialD sessionId conn safe = evalTutorialDInteractive sessionId conn safe False
96--execute the operation and display result
97evalTutorialDInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> ParsedOperation -> IO TutorialDOperatorResult
98evalTutorialDInteractive sessionId conn safe interactive expr = case expr of
99 --this does not pass through the ProjectM36.Client library because the operations
100 --are specific to the interpreter, though some operations may be of general use in the future
101 (RODatabaseContextOp execOp) -> do
102 res <- evalRODatabaseContextOp sessionId conn execOp
103 case res of
104 QuitResult -> if safe == UnsafeEvaluation && interactive then
105 putStrLn "Goodbye." >> exitSuccess
106 else
107 pure res
108 _ -> pure res
110 (DatabaseContextExprOp execOp) ->
111 eHandler $ C.executeDatabaseContextExpr sessionId conn execOp
113 (DatabaseContextIOExprOp execOp) ->
114 if needsSafe then
115 unsafeError
116 else
117 eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp
119 (GraphOp execOp) -> do
120 -- warn if the graph op could cause uncommited changes to be discarded
121 eIsDirty <- C.disconnectedTransactionIsDirty sessionId conn
122 let runGraphOp = eHandler $ C.executeGraphExpr sessionId conn execOp
123 settings = Settings {complete = noCompletion,
124 historyFile = Nothing,
125 autoAddHistory = False}
126 case eIsDirty of
127 Left err -> barf err
128 Right False -> runGraphOp
129 Right True -> do
130 cancel <- runInputT settings $ do
131 let promptDiscardChanges = do
132 isatty <- haveTerminalUI
133 if isatty && interactive && execOp /= Commit && execOp /= Rollback then do
134 mYesOrNo <- getInputLine "The current transaction has uncommitted changes. If you continue, the changes will be lost. Continue? (Y/n): "
135 case mYesOrNo of
136 Nothing -> promptDiscardChanges
137 Just "" -> promptDiscardChanges
138 Just yesOrNo -> pure (not ("Y" `isPrefixOf` yesOrNo))
139 else
140 pure False
141 promptDiscardChanges
142 if cancel then
143 pure (DisplayErrorResult "Graph operation cancelled.")
144 else
145 runGraphOp
147 (ConvenienceGraphOp execOp) ->
148 eHandler $ evalConvenienceGraphOp sessionId conn execOp
150 (ROGraphOp execOp) -> do
151 opResult <- evalROGraphOp sessionId conn execOp
152 case opResult of
153 Left err -> barf err
154 Right rel -> pure (DisplayRelationResult rel)
156 (SchemaOp execOp) ->
157 eHandler $ evalSchemaOperator sessionId conn execOp
159 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) ->
160 if needsSafe then
161 unsafeError
162 else do
163 -- collect attributes from relvar name
164 -- is there a race condition here? The attributes of the relvar may have since changed, no?
165 eImportType <- C.typeForRelationalExpr sessionId conn (RelationVariable relVarName ())
166 case eImportType of
167 Left err -> barf err
168 Right importType -> do
169 eTConsMap <- C.typeConstructorMapping sessionId conn
170 case eTConsMap of
171 Left err -> barf err
172 Right tConsMap -> do
173 exprErr <- evalRelVarDataImportOperator execOp tConsMap (attributes importType)
174 case exprErr of
175 Left err -> barf err
176 Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr)
178 (ImportDBContextOp execOp) ->
179 if needsSafe then
180 unsafeError
181 else do
182 eErr <- evalDatabaseContextDataImportOperator execOp
183 case eErr of
184 Left err -> barf err
185 Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs)
187 (InfoOp execOp) ->
188 if needsSafe then
189 unsafeError
190 else
191 case evalInformationOperator execOp of
192 Left err -> pure (DisplayErrorResult err)
193 Right info -> pure (DisplayResult info)
195 (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) ->
196 --eval relexpr to relation and pass to export function
197 if needsSafe then
198 unsafeError
199 else do
200 eRel <- C.executeRelationalExpr sessionId conn relExpr
201 case eRel of
202 Left err -> barf err
203 Right rel -> do
204 exportResult <- evalRelVarDataExportOperator execOp rel
205 case exportResult of
206 Just err -> barf err
207 Nothing -> pure QuietSuccessResult
208 (ImportBasicExampleOp execOp) -> do
209 let dbcontextexpr = evalImportBasicExampleOperator execOp
210 evalTutorialD sessionId conn safe (DatabaseContextExprOp dbcontextexpr)
211 (TransGraphRelationalOp execOp) ->
212 evalTransGraphRelationalOp sessionId conn execOp
213 where
214 needsSafe = safe == SafeEvaluation
215 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."
216 barf :: RelationalError -> IO TutorialDOperatorResult
217 barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))
218 barf err = return $ DisplayErrorResult (T.pack (show err))
219 eHandler io = do
220 eErr <- io
221 case eErr of
222 Left err -> barf err
223 Right () -> return QuietSuccessResult
225type GhcPkgPath = String
226type TutorialDExec = String
227type CheckFS = Bool
229data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] CheckFS |
230 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS
232outputNotificationCallback :: C.NotificationCallback
233outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot
235prettyEvaluatedNotification :: C.EvaluatedNotification -> String
236prettyEvaluatedNotification eNotif = let eRelShow eRel = case eRel of
237 Left err -> show err
238 Right reportRel -> T.unpack (showRelation reportRel) in
239 eRelShow (C.reportOldRelation eNotif) <> "\n" <> eRelShow (C.reportNewRelation eNotif)
241reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO ()
242reprLoop config sessionId conn = do
243 homeDirectory <- getHomeDirectory
244 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
245 eHeadName <- C.headName sessionId conn
246 eSchemaName <- C.currentSchemaName sessionId conn
247 let prompt = promptText eHeadName eSchemaName
248 catchInterrupt = handleJust (\case
249 UserInterrupt -> Just Nothing
250 _ -> Nothing) (\_ -> do
251 hPutStrLn stderr "Statement cancelled. Use \":quit\" to exit tutd."
252 pure (Just ""))
253 maybeLine <- catchInterrupt $ runInputT settings $ getInputLine (T.unpack prompt)
254 case maybeLine of
255 Nothing -> return ()
256 Just line -> do
257 runTutorialD sessionId conn (Just (T.length prompt)) (T.pack line)
258 reprLoop config sessionId conn
261runTutorialD :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO ()
262runTutorialD sessionId conn mPromptLength tutd =
263 case parseTutorialD tutd of
264 Left err ->
265 displayOpResult $ DisplayParseErrorResult mPromptLength err
266 Right parsed ->
267 catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do
268 evald <- evalTutorialDInteractive sessionId conn UnsafeEvaluation True parsed
269 displayOpResult evald)
270 (\_ -> displayOpResult (DisplayErrorResult "Request timed out."))