git.iko.soy/project-m36
on 0ff751e help sign in
project-m36/src/bin/TutorialD/tutd.hs
114 lines 4.8 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
10#if __GLASGOW_HASKELL__ < 804
11import Data.Monoid
12#endif
13import Data.Maybe
14import qualified Data.Text as T
16#if !defined(VERSION_project_m36)
17# warning Failed to discover proper version from cabal_macros.h
18# define VERSION_project_m36 "<unknown>"
19#endif
21parseArgs :: Parser InterpreterConfig
22parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> many parseGhcPkgPath <*> parseCheckFS <|>
23 RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS
25parseHeadName :: Parser HeadName
26parseHeadName = option auto (long "head" <>
27 help "Start session at head name." <>
28 metavar "GRAPH HEAD NAME" <>
29 value "master"
30 )
32parseNodeId :: Parser NodeId
33parseNodeId = createNodeId <$>
34 strOption (long "host" <>
35 short 'h' <>
36 help "Remote host name" <>
37 metavar "HOSTNAME" <>
38 value "127.0.0.1") <*>
39 option auto (long "port" <>
40 metavar "PORT NUMBER" <>
41 short 'p' <>
42 help "Remote port" <>
43 value defaultServerPort)
45--just execute some tutd and exit
46parseTutDExec :: Parser (Maybe TutorialDExec)
47parseTutDExec = optional $ strOption (long "exec-tutd" <>
48 short 'e' <>
49 metavar "TUTORIALD" <>
50 help "Execute TutorialD expression and exit"
51 )
53opts :: ParserInfo InterpreterConfig
54opts = info (parseArgs <**> helpOption) idm
56connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo
57connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths
58connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback
60headNameForConfig :: InterpreterConfig -> HeadName
61headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn
62headNameForConfig (RemoteInterpreterConfig _ _ headn _ _) = headn
64execTutDForConfig :: InterpreterConfig -> Maybe String
65execTutDForConfig (LocalInterpreterConfig _ _ t _ _) = t
66execTutDForConfig (RemoteInterpreterConfig _ _ _ t _) = t
68checkFSForConfig :: InterpreterConfig -> Bool
69checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c
70checkFSForConfig (RemoteInterpreterConfig _ _ _ _ c) = c
72persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy
73persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat
74persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing
76errDie :: String -> IO ()
77errDie err = hPutStrLn stderr err >> exitFailure
79#ifndef VERSION_project_m36
80#error VERSION_project_m36 is not defined
81#endif
82printWelcome :: IO ()
83printWelcome = do
84 putStrLn $ "Project:M36 TutorialD Interpreter " ++ VERSION_project_m36
85 putStrLn "Type \":help\" for more information."
86 putStrLn "A full tutorial is available at:"
87 putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown"
89main :: IO ()
90main = do
91 interpreterConfig <- execParser opts
92 let connInfo = connectionInfoForConfig interpreterConfig
93 fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig))
94 if not fscheck then
95 errDie checkFSErrorMsg
96 else do
97 dbconn <- connectProjectM36 connInfo
98 case dbconn of
99 Left err ->
100 errDie ("Failed to create database connection: " ++ show err)
101 Right conn -> do
102 let connHeadName = headNameForConfig interpreterConfig
103 eSessionId <- createSessionAtHead conn connHeadName
104 case eSessionId of
105 Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)
106 Right sessionId ->
107 case execTutDForConfig interpreterConfig of
108 Nothing -> do
109 printWelcome
110 _ <- reprLoop interpreterConfig sessionId conn
111 pure ()
112 Just tutdStr ->
113 runTutorialD sessionId conn Nothing (T.pack tutdStr)