git.iko.soy/project-m36
on 18f736a help sign in
project-m36/src/bin/TutorialD/tutd.hs
108 lines 4.5 kB history raw
1{-# LANGUAGE CPP #-}
2import TutorialD.Interpreter
3import ProjectM36.Base
4import ProjectM36.Client
5import ProjectM36.Server.ParseArgs
6import ProjectM36.Server
7import System.IO
8import Options.Applicative
9import System.Exit
10import Data.Monoid
11import Data.Maybe
12import qualified Data.Text as T
14#if !defined(VERSION_project_m36)
15# warning Failed to discover proper version from cabal_macros.h
16# define VERSION_project_m36 "<unknown>"
17#endif
19parseArgs :: Parser InterpreterConfig
20parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> many parseGhcPkgPath <*> parseCheckFS <|>
21 RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS
23parseHeadName :: Parser HeadName
24parseHeadName = option auto (long "head" <>
25 help "Start session at head name." <>
26 value "master"
27 )
29parseNodeId :: Parser NodeId
30parseNodeId = createNodeId <$>
31 strOption (long "host" <>
32 short 'h' <>
33 help "Remote host name" <>
34 value "127.0.0.1") <*>
35 option auto (long "port" <>
36 short 'p' <>
37 help "Remote port" <>
38 value defaultServerPort)
40--just execute some tutd and exit
41parseTutDExec :: Parser (Maybe TutorialDExec)
42parseTutDExec = optional $ strOption (long "exec-tutd" <>
43 short 'e' <>
44 help "Execute TutorialD expression and exit"
45 )
47opts :: ParserInfo InterpreterConfig
48opts = info parseArgs idm
50connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo
51connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths
52connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback
54headNameForConfig :: InterpreterConfig -> HeadName
55headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn
56headNameForConfig (RemoteInterpreterConfig _ _ headn _ _) = headn
58execTutDForConfig :: InterpreterConfig -> Maybe String
59execTutDForConfig (LocalInterpreterConfig _ _ t _ _) = t
60execTutDForConfig (RemoteInterpreterConfig _ _ _ t _) = t
62checkFSForConfig :: InterpreterConfig -> Bool
63checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c
64checkFSForConfig (RemoteInterpreterConfig _ _ _ _ c) = c
66persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy
67persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat
68persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing
70errDie :: String -> IO ()
71errDie err = hPutStrLn stderr err >> exitFailure
73#ifndef VERSION_project_m36
74#error VERSION_project_m36 is not defined
75#endif
76printWelcome :: IO ()
77printWelcome = do
78 putStrLn $ "Project:M36 TutorialD Interpreter " ++ VERSION_project_m36
79 putStrLn "Type \":help\" for more information."
80 putStrLn "A full tutorial is available at:"
81 putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown"
83main :: IO ()
84main = do
85 interpreterConfig <- execParser opts
86 let connInfo = connectionInfoForConfig interpreterConfig
87 fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig))
88 if not fscheck then
89 errDie checkFSErrorMsg
90 else do
91 dbconn <- connectProjectM36 connInfo
92 case dbconn of
93 Left err ->
94 errDie ("Failed to create database connection: " ++ show err)
95 Right conn -> do
96 let connHeadName = headNameForConfig interpreterConfig
97 eSessionId <- createSessionAtHead conn connHeadName
98 case eSessionId of
99 Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)
100 Right sessionId ->
101 case execTutDForConfig interpreterConfig of
102 Nothing -> do
103 printWelcome
104 _ <- reprLoop interpreterConfig sessionId conn
105 pure ()
106 Just tutdStr ->
107 runTutorialD sessionId conn Nothing (T.pack tutdStr)