Turn HLS-wrapper into an LSP Server

exe/Wrapper.hs

@@ -1,6 +1,12 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE ExplicitNamespaces         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 -- | This module is based on the hie-wrapper.sh script in
 -- https://github.com/alanz/vscode-hie-server
 module Main where
@@ -28,6 +34,28 @@ import qualified Data.Map.Strict as Map
 #else
 import           System.Process
 #endif
+import qualified Data.Text.IO as T
+import           Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
+import qualified Data.Text as T
+import           Language.LSP.Server (LspM)
+import           Control.Monad.IO.Class (MonadIO (liftIO))
+import           Control.Monad.IO.Unlift (MonadUnliftIO)
+import qualified Language.LSP.Server as LSP
+import qualified Development.IDE.Main as Main
+import           Ide.Plugin.Config (Config)
+import           Language.LSP.Types (RequestMessage, ResponseError, MessageActionItem (MessageActionItem), Method(Initialize), MessageType (MtError), SMethod (SWindowShowMessageRequest, SExit), ShowMessageRequestParams (ShowMessageRequestParams))
+import           Development.IDE.Types.Logger ( makeDefaultStderrRecorder,
+                                                cmapWithPrio,
+                                                Pretty(pretty),
+                                                Logger(Logger),
+                                                Priority(Error, Debug, Info, Warning),
+                                                Recorder(logger_),
+                                                WithPriority(WithPriority) )
+import           Data.Maybe
+import           GHC.Stack.Types (emptyCallStack)
+import           Control.Concurrent (tryPutMVar)
+import           Development.IDE.LSP.LanguageServer (runLanguageServer)
+import           HIE.Bios.Internal.Log
 
 -- ---------------------------------------------------------------------
 
@@ -57,9 +85,15 @@ main = do
           cradle <- findProjectCradle' False
           (CradleSuccess libdir) <- HieBios.getRuntimeGhcLibDir cradle
           putStr libdir
-      _ -> launchHaskellLanguageServer args
+      _ -> launchHaskellLanguageServer args >>= \case
+            Right () -> pure ()
+            Left err -> do
+              T.hPutStrLn stderr (prettyError err NoShorten)
+              case args of
+                Ghcide _ -> launchErrorLSP (prettyError err Shorten)
+                _        -> pure ()
 
-launchHaskellLanguageServer :: Arguments -> IO ()
+launchHaskellLanguageServer :: Arguments -> IO (Either WrapperSetupError ())
 launchHaskellLanguageServer parsedArgs = do
   case parsedArgs of
     Ghcide GhcideArguments{..} -> whenJust argsCwd setCurrentDirectory
@@ -75,7 +109,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
@@ -94,64 +131,74 @@ 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'
+  runExceptT $ do
+      ghcVersion <- getRuntimeGhcVersion' cradle
+      liftIO $ hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion
 
-  hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates
+      let
+        hlsBin = "haskell-language-server-" ++ ghcVersion
+        candidates' = [hlsBin, "haskell-language-server"]
+        candidates = map (++ exeExtension) candidates'
 
-  mexes <- traverse findExecutable candidates
+      liftIO $ hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates
+
+      mexes <- liftIO $ traverse findExecutable candidates
+
+      case asum mexes of
+        Nothing -> throwE (NoLanguageServer ghcVersion candidates)
+        Just e -> do
+          liftIO $ hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e
 
-  case asum mexes of
-    Nothing -> die $ "Cannot find any haskell-language-server exe, looked for: " ++ intercalate ", " candidates
-    Just e -> do
-      hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e
 #ifdef mingw32_HOST_OS
-      callProcess e args
+          liftIO $ callProcess e args
 #else
-      let Cradle { cradleOptsProg = CradleAction { runGhcCmd } } = cradle
-      -- we need to be compatible with NoImplicitPrelude
-      ghcBinary <- (fmap trim <$> runGhcCmd ["-v0", "-package-env=-", "-ignore-dot-ghci", "-e", "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"])
-        >>= cradleResult "Failed to get project GHC executable path"
-      libdir <- HieBios.getRuntimeGhcLibDir cradle
-        >>= cradleResult "Failed to get project GHC libdir path"
-      env <- Map.fromList <$> getEnvironment
-      let newEnv = Map.insert "GHC_BIN" ghcBinary $ Map.insert "GHC_LIBDIR" libdir env
-      executeFile e True args (Just (Map.toList newEnv))
+
+          let Cradle { cradleOptsProg = CradleAction { runGhcCmd } } = cradle
+
+          let cradleName = actionName (cradleOptsProg cradle)
+          -- we need to be compatible with NoImplicitPrelude
+          ghcBinary <- liftIO (fmap trim <$> runGhcCmd ["-v0", "-package-env=-", "-ignore-dot-ghci", "-e", "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"])
+                         >>= cradleResult cradleName
+
+          libdir <- liftIO (HieBios.getRuntimeGhcLibDir cradle)
+                      >>= cradleResult cradleName
+
+          env <- Map.fromList <$> liftIO getEnvironment
+          let newEnv = Map.insert "GHC_BIN" ghcBinary $ Map.insert "GHC_LIBDIR" libdir env
+          liftIO $ executeFile e True args (Just (Map.toList newEnv))
 #endif
 
 
-cradleResult :: String -> CradleLoadResult a -> IO a
-cradleResult _ (CradleSuccess a) = pure a
-cradleResult str (CradleFail e) = die $ str ++ ": " ++ show e
-cradleResult str CradleNone = die $ str ++ ": no cradle"
+
+cradleResult :: ActionName Void -> CradleLoadResult a -> ExceptT WrapperSetupError IO a
+cradleResult _ (CradleSuccess ver) = pure ver
+cradleResult cradleName (CradleFail error) = throwE $ FailedToObtainGhcVersion cradleName error
+cradleResult cradleName CradleNone = throwE $ NoneCradleGhcVersion cradleName
 
 -- | 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
+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 ()
 
-  HieBios.getRuntimeGhcVersion cradle >>= cradleResult "Failed to get project GHC version"
+  ghcVersionRes <- liftIO $ HieBios.getRuntimeGhcVersion cradle
+  cradleResult cradleName ghcVersionRes
+
   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 = findProjectCradle' True
@@ -175,3 +222,93 @@ trim :: String -> String
 trim s = case lines s of
   [] -> s
   ls -> dropWhileEnd isSpace $ last ls
+
+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 "\n" (cradleErrorStderr crdlError))
+prettyError (NoneCradleGhcVersion name) _ =
+  "Failed to get the GHC version of this " <> T.pack (show name) <>
+  " project because a none cradle is configured"
+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) _ =
+  "Failed to find executable \"" <> T.pack toolExe <> "\" in $PATH for this " <> T.pack (show name) <> " project."
+
+newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, LSP.MonadLsp c)
+
+-- | Launches a LSP that displays an error and presents the user with a request
+-- to shut down the LSP.
+launchErrorLSP :: T.Text -> IO ()
+launchErrorLSP errorMsg = do
+  recorder <- makeDefaultStderrRecorder Nothing Info
+
+  let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack (pretty m))
+
+  let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) logger
+
+  inH <- Main.argsHandleIn defaultArguments
+
+  outH <- Main.argsHandleOut defaultArguments
+
+  let onConfigurationChange cfg _ = Right cfg
+
+  let setup clientMsgVar = do
+        -- Forcefully exit
+        let exit = void $ tryPutMVar clientMsgVar ()
+
+        let doInitialize :: LSP.LanguageContextEnv Config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv Config, ()))
+            doInitialize env _ = do
+
+              let restartTitle = "Try to restart"
+              void $ LSP.runLspT env $ LSP.sendRequest SWindowShowMessageRequest (ShowMessageRequestParams MtError errorMsg (Just [MessageActionItem restartTitle])) $ \case
+                    Right (Just (MessageActionItem title))
+                       | title == restartTitle -> liftIO exit
+                    _ -> pure ()
+
+              pure (Right (env, ()))
+
+        let asyncHandlers = mconcat
+              [ exitHandler exit ]
+
+        let interpretHandler (env,  _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO
+        pure (doInitialize, asyncHandlers, interpretHandler)
+
+  runLanguageServer
+    (Main.argsLspOptions defaultArguments)
+    inH
+    outH
+    (Main.argsDefaultHlsConfig defaultArguments)
+    onConfigurationChange
+    setup
+
+exitHandler :: IO () -> LSP.Handlers (ErrorLSPM c)
+exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit
+
+hlsWrapperLogger :: Logger
+hlsWrapperLogger = Logger $ \pri txt ->
+    case pri of
+      Debug   -> debugm   (T.unpack txt)
+      Info    -> logm     (T.unpack txt)
+      Warning -> warningm (T.unpack txt)
+      Error   -> errorm   (T.unpack txt)