Allow HLS-wrapper to send LSP messages

Introduces better error handling to HLS-wrapper to show LSP clients
dedicated error messages.
This should help users understand why their Language Server isn't
starting.

Author: fendor

exe/Wrapper.hs

@@ -1,25 +1,39 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
 -- | This module is based on the hie-wrapper.sh script in
 -- https://github.com/alanz/vscode-hie-server
 module Main where
 
 import           Control.Monad.Extra
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Except
+import qualified Data.Aeson              as Aeson
+import qualified Data.ByteString.Lazy    as BSL
 import           Data.Default
 import           Data.Foldable
 import           Data.List
+import           Data.Maybe
+import qualified Data.Text               as T
+import qualified Data.Text.IO            as T
+import qualified Data.Text.Lazy          as TL
+import qualified Data.Text.Lazy.Encoding as TL
 import           Data.Void
 import qualified Development.IDE.Session as Session
 import qualified HIE.Bios.Environment    as HieBios
 import           HIE.Bios.Types
 import           Ide.Arguments
 import           Ide.Version
+import qualified Language.LSP.Types      as J
 import           System.Directory
 import           System.Environment
 import           System.Exit
 import           System.FilePath
 import           System.IO
 import           System.Info
 import           System.Process
+import Control.Concurrent.Strict (threadDelay)
 
 -- ---------------------------------------------------------------------
 
@@ -46,9 +60,17 @@ main = do
       BiosMode PrintCradleType ->
           print =<< findProjectCradle
 
-      _ -> launchHaskellLanguageServer args
-
-launchHaskellLanguageServer :: Arguments -> IO ()
+      _ -> launchHaskellLanguageServer args >>= \case
+        Right () -> pure ()
+        Left err -> do
+          T.hPutStrLn stderr "*** Startup ERROR"
+          T.hPutStrLn stderr (prettyError err NoShorten)
+          putWindowMessage J.MtError (prettyError err Shorten)
+          -- Wait for 45 seconds before shutdown, so we don't spam the same message
+          -- since some LSP clients attempt to re-launch the server.
+          threadDelay (45 * 1_000_000)
+
+launchHaskellLanguageServer :: Arguments -> IO (Either WrapperSetupError ())
 launchHaskellLanguageServer parsedArgs = do
   case parsedArgs of
     Ghcide GhcideArguments{..} -> whenJust argsCwd setCurrentDirectory
@@ -64,7 +86,10 @@ launchHaskellLanguageServer parsedArgs = do
 
   case parsedArgs of
     Ghcide GhcideArguments{..} ->
-      when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess
+      when argsProjectGhcVersion $ do
+        runExceptT (getRuntimeGhcVersion' cradle) >>= \case
+          Right ghcVersion -> putStrLn ghcVersion >> exitSuccess
+          Left err -> T.putStrLn (prettyError err NoShorten) >> exitFailure
     _ -> pure ()
 
   progName <- getProgName
@@ -83,51 +108,53 @@ launchHaskellLanguageServer parsedArgs = do
   hPutStrLn stderr ""
   -- Get the ghc version -- this might fail!
   hPutStrLn stderr "Consulting the cradle to get project GHC version..."
-  ghcVersion <- getRuntimeGhcVersion' cradle
-  hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion
-
-  let
-    hlsBin = "haskell-language-server-" ++ ghcVersion
-    candidates' = [hlsBin, "haskell-language-server"]
-    candidates = map (++ exeExtension) candidates'
-
-  hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates
-
-  mexes <- traverse findExecutable candidates
-
-  case asum mexes of
-    Nothing -> hPutStrLn stderr $ "Cannot find any haskell-language-server exe, looked for: " ++ intercalate ", " candidates
-    Just e -> do
-      hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e
-      callProcess e args
-
--- | Version of 'getRuntimeGhcVersion' that dies if we can't get it, and also
--- checks to see if the tool is missing if it is one of
-getRuntimeGhcVersion' :: Show a => Cradle a -> IO String
+  runExceptT (getRuntimeGhcVersion' cradle) >>= \case
+    Left err -> pure $ Left err
+    Right ghcVersion -> do
+      hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion
+
+      let
+        hlsBin = "haskell-language-server-" ++ ghcVersion
+        candidates' = [hlsBin, "haskell-language-server"]
+        candidates = map (++ exeExtension) candidates'
+
+      hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates
+
+      mexes <- traverse findExecutable candidates
+
+      case asum mexes of
+        Nothing -> pure $ Left $ NoLanguageServer ghcVersion candidates
+        Just e -> do
+          hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e
+          callProcess e args
+          pure $ Right ()
+
+-- | Version of 'getRuntimeGhcVersion' that throws a 'WrapperSetupError' if we
+-- can't get it, and also checks if run-time tool dependencies are missing.
+getRuntimeGhcVersion' :: Cradle Void -> ExceptT WrapperSetupError IO String
 getRuntimeGhcVersion' cradle = do
 
+  let cradleName = actionName (cradleOptsProg cradle)
   -- See if the tool is installed
-  case actionName (cradleOptsProg cradle) of
+  case cradleName of
     Stack   -> checkToolExists "stack"
     Cabal   -> checkToolExists "cabal"
     Default -> checkToolExists "ghc"
     Direct  -> checkToolExists "ghc"
     _       -> pure ()
 
-  ghcVersionRes <- HieBios.getRuntimeGhcVersion cradle
+  ghcVersionRes <- liftIO $ HieBios.getRuntimeGhcVersion cradle
   case ghcVersionRes of
     CradleSuccess ver -> do
       return ver
-    CradleFail error -> die $ "Failed to get project GHC version:" ++ show error
-    CradleNone -> die "Failed get project GHC version, since we have a none cradle"
+    CradleFail error -> throwE $ FailedToObtainGhcVersion cradleName error
+    CradleNone -> throwE $ NoneCradleGhcVersion cradleName
   where
     checkToolExists exe = do
-      exists <- findExecutable exe
+      exists <- liftIO $ findExecutable exe
       case exists of
         Just _ -> pure ()
-        Nothing ->
-          die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n"
-           ++ show cradle
+        Nothing -> throwE $ ToolRequirementMissing exe (actionName (cradleOptsProg cradle))
 
 findProjectCradle :: IO (Cradle Void)
 findProjectCradle = do
@@ -142,3 +169,69 @@ findProjectCradle = do
     Nothing -> hPutStrLn stderr "No 'hie.yaml' found. Try to discover the project type!"
 
   Session.loadCradle def hieYaml d
+
+data WrapperSetupError
+    = FailedToObtainGhcVersion (ActionName Void) CradleError
+    | NoneCradleGhcVersion (ActionName Void)
+    | NoLanguageServer String [FilePath]
+    | ToolRequirementMissing String (ActionName Void)
+    deriving (Show)
+
+data Shorten = Shorten | NoShorten
+
+-- | Pretty error message displayable to the future.
+-- Extra argument 'Shorten' can be used to shorten error message.
+-- Reduces usefulness, but allows us to show the error message via LSP
+-- as LSP doesn't allow any newlines and makes it really hard to read
+-- the message otherwise.
+prettyError :: WrapperSetupError -> Shorten ->  T.Text
+prettyError (FailedToObtainGhcVersion name crdlError) shorten =
+  "Failed to find the GHC version of this " <> T.pack (show name) <> " project." <>
+  case shorten of
+    Shorten ->
+      "\n" <> T.pack (fromMaybe "" . listToMaybe $ cradleErrorStderr crdlError)
+    NoShorten ->
+      "\n" <> T.pack (intercalate "\r\n" (cradleErrorStderr crdlError))
+prettyError (NoneCradleGhcVersion name) _ =
+  "Failed to get the GHC version of the " <> T.pack (show name) <>
+  " project, since we have a none cradle"
+prettyError (NoLanguageServer ghcVersion candidates) _ =
+  "Failed to find a HLS version for GHC " <> T.pack ghcVersion <>
+  "\nExecutable names we failed to find: " <> T.pack (intercalate "," candidates)
+prettyError (ToolRequirementMissing toolExe name) _ =
+  "This is a " <> T.pack (show name) <> " Project, but we failed to find \"" <>
+  T.pack toolExe <> "\" on the $PATH"
+
+-- LSP Helper functions
+-- ~~~~~~~~~~~~~~~~~~~~
+--
+-- To send lsp messages without a full-fledged LSP server.
+-- Should be used to indicate errors to the user.
+
+putWindowMessage :: J.MessageType -> T.Text -> IO ()
+putWindowMessage mt message = do
+  let bsMessage = toLspMessage windowMsg
+  BSL.hPut stdout bsMessage
+  hFlush stdout
+  where
+    windowMsg = windowMessage mt message
+
+    windowMessage :: J.MessageType -> T.Text -> J.FromServerMessage
+    windowMessage mt message = J.FromServerMess J.SWindowShowMessage $
+      J.NotificationMessage "2.0" J.SWindowShowMessage
+        (J.ShowMessageParams mt message)
+
+
+-- | Given a server message, attach the relevant header information.
+toLspMessage :: J.FromServerMessage -> BSL.ByteString
+toLspMessage msg =
+  BSL.concat
+  [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str)
+  , _TWO_CRLF
+  , str ]
+  where
+    str = Aeson.encode msg
+
+-- | Constant taken from the 'lsp' package.
+_TWO_CRLF :: BSL.ByteString
+_TWO_CRLF = "\r\n\r\n"

haskell-language-server.cabal

@@ -1,7 +1,7 @@
 cabal-version:      2.4
 category:           Development
 name:               haskell-language-server
-version:            1.5.1.0
+version:            1.5.2.0
 synopsis:           LSP server for GHC
 description:
   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>
@@ -404,15 +404,20 @@ executable haskell-language-server-wrapper
     "-with-rtsopts=-I0 -A128M"
 
   build-depends:
+    , aeson
+    , bytestring
     , data-default
     , ghc
     , ghc-paths
     , ghcide
     , gitrev
     , haskell-language-server
     , hie-bios
+    , lsp-types
     , optparse-applicative
     , optparse-simple
+    , text
+    , transformers
     , process
 
   default-language: Haskell2010