git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/bin/TutorialD/tutd.hs
112 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
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 metavar "GRAPH HEAD NAME" <>
27 value "master"
28 )
30parseNodeId :: Parser NodeId
31parseNodeId = createNodeId <$>
32 strOption (long "host" <>
33 short 'h' <>
34 help "Remote host name" <>
35 metavar "HOSTNAME" <>
36 value "127.0.0.1") <*>
37 option auto (long "port" <>
38 metavar "PORT NUMBER" <>
39 short 'p' <>
40 help "Remote port" <>
41 value defaultServerPort)
43--just execute some tutd and exit
44parseTutDExec :: Parser (Maybe TutorialDExec)
45parseTutDExec = optional $ strOption (long "exec-tutd" <>
46 short 'e' <>
47 metavar "TUTORIALD" <>
48 help "Execute TutorialD expression and exit"
49 )
51opts :: ParserInfo InterpreterConfig
52opts = info (parseArgs <**> helpOption) idm
54connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo
55connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths
56connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback
58headNameForConfig :: InterpreterConfig -> HeadName
59headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn
60headNameForConfig (RemoteInterpreterConfig _ _ headn _ _) = headn
62execTutDForConfig :: InterpreterConfig -> Maybe String
63execTutDForConfig (LocalInterpreterConfig _ _ t _ _) = t
64execTutDForConfig (RemoteInterpreterConfig _ _ _ t _) = t
66checkFSForConfig :: InterpreterConfig -> Bool
67checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c
68checkFSForConfig (RemoteInterpreterConfig _ _ _ _ c) = c
70persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy
71persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat
72persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing
74errDie :: String -> IO ()
75errDie err = hPutStrLn stderr err >> exitFailure
77#ifndef VERSION_project_m36
78#error VERSION_project_m36 is not defined
79#endif
80printWelcome :: IO ()
81printWelcome = do
82 putStrLn $ "Project:M36 TutorialD Interpreter " ++ VERSION_project_m36
83 putStrLn "Type \":help\" for more information."
84 putStrLn "A full tutorial is available at:"
85 putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown"
87main :: IO ()
88main = do
89 interpreterConfig <- execParser opts
90 let connInfo = connectionInfoForConfig interpreterConfig
91 fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig))
92 if not fscheck then
93 errDie checkFSErrorMsg
94 else do
95 dbconn <- connectProjectM36 connInfo
96 case dbconn of
97 Left err ->
98 errDie ("Failed to create database connection: " ++ show err)
99 Right conn -> do
100 let connHeadName = headNameForConfig interpreterConfig
101 eSessionId <- createSessionAtHead conn connHeadName
102 case eSessionId of
103 Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)
104 Right sessionId ->
105 case execTutDForConfig interpreterConfig of
106 Nothing -> do
107 printWelcome
108 _ <- reprLoop interpreterConfig sessionId conn
109 pure ()
110 Just tutdStr ->
111 runTutorialD sessionId conn Nothing (T.pack tutdStr)