Add numeric-version option for wrapper and server

Also correctly shuts down the language server if `--version` was given. Minor rework of argument parser.
haskell · Jul 26, 2020 · fa44b4d · fa44b4d
1 parent c609be8
commit fa44b4d
Show file tree

Hide file tree

Showing 3 changed files with 61 additions and 14 deletions.
diff --git a/exe/Arguments.hs b/exe/Arguments.hs
@@ -9,8 +9,11 @@
 
 module Arguments
   ( Arguments(..)
+  , LspArguments(..)
+  , PrintVersion(..)
   , getArguments
   , haskellLanguageServerVersion
+  , haskellLanguageServerNumericVersion
   ) where
 
 import Data.Version
@@ -21,11 +24,15 @@ import System.Environment
 
 -- ---------------------------------------------------------------------
 
-data Arguments = Arguments
+data Arguments
+  = VersionMode PrintVersion
+  | LspMode LspArguments
+  deriving Show
+
+data LspArguments = LspArguments
     {argLSP :: Bool
     ,argsCwd :: Maybe FilePath
     ,argFiles :: [FilePath]
-    ,argsVersion :: Bool
     ,argsShakeProfiling :: Maybe FilePath
     ,argsTesting :: Bool
     ,argsExamplePlugin :: Bool
@@ -37,22 +44,36 @@ data Arguments = Arguments
     , argsProjectGhcVersion :: Bool
     } deriving Show
 
+data PrintVersion
+  = PrintVersion
+  | PrintNumericVersion
+  deriving (Show, Eq, Ord)
+
 getArguments :: String -> IO Arguments
 getArguments exeName = execParser opts
   where
-    opts = info (arguments exeName <**> helper)
+    opts = info ((
+      VersionMode <$> printVersionParser exeName
+      <|> LspMode <$> arguments)
+      <**> helper)
       ( fullDesc
      <> progDesc "Used as a test bed to check your IDE Client will work"
      <> header (exeName ++ " - GHC Haskell LSP server"))
 
-arguments :: String -> Parser Arguments
-arguments exeName = Arguments
+printVersionParser :: String -> Parser PrintVersion
+printVersionParser exeName =
+  flag' PrintVersion
+    (long "version" <> help ("Show " ++ exeName  ++ " and GHC versions"))
+  <|>
+  flag' PrintNumericVersion
+    (long "numeric-version" <> help ("Show numeric version of " ++ exeName))
+
+arguments :: Parser LspArguments
+arguments = LspArguments
       <$> switch (long "lsp" <> help "Start talking to an LSP server")
       <*> optional (strOption $ long "cwd" <> metavar "DIR"
                   <> help "Change to this directory")
       <*> many (argument str (metavar "FILES/DIRS..."))
-      <*> switch (long "version"
-                  <> help ("Show " ++ exeName  ++ " and GHC versions"))
       <*> optional (strOption $ long "shake-profiling" <> metavar "DIR"
                   <> help "Dump profiling reports to this directory")
       <*> switch (long "test"
@@ -83,13 +104,16 @@ arguments exeName = Arguments
 
 -- ---------------------------------------------------------------------
 
+haskellLanguageServerNumericVersion :: String
+haskellLanguageServerNumericVersion = showVersion version
+
 haskellLanguageServerVersion :: IO String
 haskellLanguageServerVersion = do
   path <- getExecutablePath
   let gitHashSection = case $(gitHash) of
         x | x == "UNKNOWN" -> ""
         x -> " (GIT hash: " <> x <> ")"
-  return $ "haskell-language-server version: " <> showVersion version
+  return $ "haskell-language-server version: " <> haskellLanguageServerNumericVersion
              <> " (GHC: " <> VERSION_ghc
              <> ") (PATH: " <> path <> ")"
              <> gitHashSection

diff --git a/exe/Main.hs b/exe/Main.hs
@@ -125,12 +125,23 @@ main :: IO ()
 main = do
     -- WARNING: If you write to stdout before runLanguageServer
     --          then the language server will not work
-    args@Arguments{..} <- getArguments "haskell-language-server"
+    args <- getArguments "haskell-language-server"
 
     hlsVer <- haskellLanguageServerVersion
-    if argsVersion then putStrLn hlsVer
-    else hPutStrLn stderr hlsVer {- see WARNING above -}
+    case args of
+        VersionMode PrintVersion ->
+            putStrLn hlsVer
 
+        VersionMode PrintNumericVersion ->
+            putStrLn haskellLanguageServerNumericVersion
+
+        LspMode lspArgs -> do
+            {- see WARNING above -}
+            hPutStrLn stderr hlsVer
+            runLspMode lspArgs
+
+runLspMode :: LspArguments -> IO ()
+runLspMode lspArgs@LspArguments {..} = do
     LSP.setupLogger argsLogFile ["hls", "hie-bios"]
       $ if argsDebugOn then L.DEBUG else L.INFO
 
@@ -157,7 +168,7 @@ main = do
     if argLSP then do
         t <- offsetTime
         hPutStrLn stderr "Starting (haskell-language-server)LSP server..."
-        hPutStrLn stderr $ "  with arguments: " <> show args
+        hPutStrLn stderr $ "  with arguments: " <> show lspArgs
         hPutStrLn stderr $ "  with plugins: " <> show (Map.keys $ ipMap idePlugins')
         hPutStrLn stderr $ "  in directory: " <> dir
         hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"

diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs
@@ -26,16 +26,28 @@ main :: IO ()
 main = do
   -- WARNING: If you write to stdout before runLanguageServer
   --          then the language server will not work
-  Arguments{..} <- getArguments "haskell-language-server-wrapper"
+  args <- getArguments "haskell-language-server"
 
+  hlsVer <- haskellLanguageServerVersion
+  case args of
+      VersionMode PrintVersion ->
+          putStrLn hlsVer
+
+      VersionMode PrintNumericVersion ->
+          putStrLn haskellLanguageServerNumericVersion
+
+      LspMode lspArgs ->
+          launchHaskellLanguageServer lspArgs
+
+launchHaskellLanguageServer :: LspArguments -> IO ()
+launchHaskellLanguageServer LspArguments{..} = do
   d <- getCurrentDirectory
 
   -- Get the cabal directory from the cradle
   cradle <- findLocalCradle (d </> "a")
   setCurrentDirectory $ cradleRootDir cradle
 
   when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess
-  when argsVersion $ haskellLanguageServerVersion >>= putStrLn >> exitSuccess
 
   whenJust argsCwd setCurrentDirectory