git.iko.soy/project-m36
on fd05d50 help sign in
project-m36/src/bin/TutorialD/tutd.hs
101 lines 4.2 kB history raw
1{-# LANGUAGE CPP #-}
2import TutorialD.Interpreter
3import ProjectM36.Base
4import ProjectM36.Client
5import System.IO
6import Options.Applicative
7import System.Exit
8import Data.Monoid
10parseArgs :: Parser InterpreterConfig
11parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseGhcPkgPaths <|>
12 RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName
14parsePersistenceStrategy :: Parser PersistenceStrategy
15parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>
16 MinimalPersistence <$> dbdirOpt <|>
17 pure NoPersistence
18 where
19 dbdirOpt = strOption (short 'd' <>
20 long "database-directory" <>
21 metavar "DIRECTORY" <>
22 showDefaultWith show
23 )
24 fsyncOpt = switch (short 'f' <>
25 long "fsync" <>
26 help "Fsync all new transactions.")
28parseHeadName :: Parser HeadName
29parseHeadName = option auto (long "head" <>
30 help "Start session at head name." <>
31 value "master"
32 )
34parseDatabaseName :: Parser DatabaseName
35parseDatabaseName = strOption (long "database" <>
36 short 'n' <>
37 help "Remote database name")
39parseNodeId :: Parser NodeId
40parseNodeId = createNodeId <$>
41 strOption (long "host" <>
42 short 'h' <>
43 help "Remote host name" <>
44 value "127.0.0.1") <*>
45 option auto (long "port" <>
46 short 'p' <>
47 help "Remote port" <>
48 value defaultServerPort)
50parseGhcPkgPaths :: Parser [GhcPkgPath]
51parseGhcPkgPaths = many (strOption (long "ghc-pkg-dir" <>
52 metavar "GHC_PACKAGE_DIRECTORY"))
54opts :: ParserInfo InterpreterConfig
55opts = info parseArgs idm
57connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo
58connectionInfoForConfig (LocalInterpreterConfig pStrategy _ ghcPkgPaths) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths
59connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback
61headNameForConfig :: InterpreterConfig -> HeadName
62headNameForConfig (LocalInterpreterConfig _ headn _) = headn
63headNameForConfig (RemoteInterpreterConfig _ _ headn) = headn
65{-
66ghcPkgPathsForConfig :: InterpreterConfig -> [GhcPkgPath]
67ghcPkgPathsForConfig (LocalInterpreterConfig _ _ paths) = paths
68ghcPkgPathsForConfig _ = error "Clients cannot configure remote ghc package paths."
69-}
71errDie :: String -> IO ()
72errDie err = hPutStrLn stderr err >> exitFailure
74#ifndef VERSION_project_m36
75#error VERSION_project_m36 is not defined
76#endif
77printWelcome :: IO ()
78printWelcome = do
79 putStrLn $ "Project:M36 TutorialD Interpreter " ++ VERSION_project_m36
80 putStrLn "Type \":help\" for more information."
81 putStrLn "A full tutorial is available at:"
82 putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown"
84main :: IO ()
85main = do
86 interpreterConfig <- execParser opts
87 let connInfo = connectionInfoForConfig interpreterConfig
88 dbconn <- connectProjectM36 connInfo
89 case dbconn of
90 Left err ->
91 errDie ("Failed to create database connection: " ++ show err)
92 Right conn -> do
93 let connHeadName = headNameForConfig interpreterConfig
94 eSessionId <- createSessionAtHead conn connHeadName
95 case eSessionId of
96 Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)
97 Right sessionId -> do
98 printWelcome
99 _ <- reprLoop interpreterConfig sessionId conn
100 pure ()