git.iko.soy/project-m36
on master help sign in
add -e string to tutd to execute arbitrary one-off TutorialD commands

resolves #147

commit034ed442102e4eabf090e5b8b9a8c41994283f74 authorAgentM <agentm@themactionfaction.com> dateMon 18 Sep 2017, 21:41 (9 years ago) parent3c5ad79
2 files changed+41−19
compare with master
unifiedsplit
src/bin/TutorialD/Interpreter.hs+16−10 src/bin/TutorialD/tutd.hs+25−9
src/bin/TutorialD/Interpreter.hs+16−10
@@ -181,8 +181,10 @@ evalTutorialD sessionId conn safe expr = case expr of
181181 Right () -> return QuietSuccessResult
182182
183183type GhcPkgPath = String
184−data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] |
185− RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName
184+type TutorialDExec = String
185+
186+data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] |
187+ RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName (Maybe TutorialDExec)
186188
187189outputNotificationCallback :: C.NotificationCallback
188190outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ show (reportExpr (C.notification evaldNot)) ++ "\n" ++ prettyEvaluatedNotification evaldNot
@@ -203,12 +205,16 @@ reprLoop config sessionId conn = do
203205 case maybeLine of
204206 Nothing -> return ()
205207 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."))
208+ runTutorialD sessionId conn (T.pack line)
214209 reprLoop config sessionId conn
210+
211+runTutorialD :: C.SessionId -> C.Connection -> T.Text -> IO ()
212+runTutorialD sessionId conn tutd = do
213+ case parseTutorialD tutd of
214+ Left err ->
215+ displayOpResult $ DisplayParseErrorResult 0 err
216+ Right parsed ->
217+ catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do
218+ evald <- evalTutorialD sessionId conn UnsafeEvaluation parsed
219+ displayOpResult evald)
220+ (\_ -> displayOpResult (DisplayErrorResult "Request timed out."))
src/bin/TutorialD/tutd.hs+25−9
@@ -6,10 +6,11 @@ import System.IO
66import Options.Applicative
77import System.Exit
88import Data.Monoid
9+import qualified Data.Text as T
910
1011parseArgs :: Parser InterpreterConfig
11−parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseGhcPkgPaths <|>
12− RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName
12+parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> parseGhcPkgPaths <|>
13+ RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec
1314
1415parsePersistenceStrategy :: Parser PersistenceStrategy
1516parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>
@@ -47,6 +48,13 @@ parseNodeId = createNodeId <$>
4748 help "Remote port" <>
4849 value defaultServerPort)
4950
51+--just execute some tutd and exit
52+parseTutDExec :: Parser (Maybe TutorialDExec)
53+parseTutDExec = optional $ strOption (long "exec-tutd" <>
54+ short 'e' <>
55+ help "Execute TutorialD expression and exit"
56+ )
57+
5058parseGhcPkgPaths :: Parser [GhcPkgPath]
5159parseGhcPkgPaths = many (strOption (long "ghc-pkg-dir" <>
5260 metavar "GHC_PACKAGE_DIRECTORY"))
@@ -55,12 +63,16 @@ opts :: ParserInfo InterpreterConfig
5563opts = info parseArgs idm
5664
5765connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo
58−connectionInfoForConfig (LocalInterpreterConfig pStrategy _ ghcPkgPaths) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths
59−connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback
66+connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths
67+connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback
6068
6169headNameForConfig :: InterpreterConfig -> HeadName
62−headNameForConfig (LocalInterpreterConfig _ headn _) = headn
63−headNameForConfig (RemoteInterpreterConfig _ _ headn) = headn
70+headNameForConfig (LocalInterpreterConfig _ headn _ _) = headn
71+headNameForConfig (RemoteInterpreterConfig _ _ headn _) = headn
72+
73+execTutDForConfig :: InterpreterConfig -> Maybe String
74+execTutDForConfig (LocalInterpreterConfig _ _ t _) = t
75+execTutDForConfig (RemoteInterpreterConfig _ _ _ t) = t
6476
6577{-
6678ghcPkgPathsForConfig :: InterpreterConfig -> [GhcPkgPath]
@@ -95,7 +107,11 @@ main = do
95107 case eSessionId of
96108 Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)
97109 Right sessionId -> do
98− printWelcome
99− _ <- reprLoop interpreterConfig sessionId conn
100− pure ()
110+ case execTutDForConfig interpreterConfig of
111+ Nothing -> do
112+ printWelcome
113+ _ <- reprLoop interpreterConfig sessionId conn
114+ pure ()
115+ Just tutdStr -> do
116+ runTutorialD sessionId conn (T.pack tutdStr)
101117